#!/usr/bin/env tclsh
# tiid: multiprotocol tii node daemon
# can work both over HTTP and Gopher/Nex
# Usage: tiid.tcl [port] [nodename] [dbfile]
# default port is 8080, default dbfile is tii.db
# Depends upon Tcllib and sqlite3
# Created by Luxferre in 2024, released into public domain

package require sqlite3
package require sha256

set scriptpath [file normalize [info script]]
set appdir [file dirname $scriptpath]
# check if we're running from a starpack
if [string match *app-tiid $appdir] {
  set appdir [file normalize [file join $appdir ".." ".." ".." ]]
}
set localdb [file join $appdir "tii.db"]
set listenport 8080

# node name, used for the originating message addresses
set nodename "tiid"

# ensure database file is created
proc createdb {fname} {
  sqlite3 fdb $fname
  fdb eval {
    CREATE TABLE `msg` (`id` INTEGER PRIMARY KEY AUTOINCREMENT,
      `msgid` VARCHAR(20) NOT NULL UNIQUE,
      `timestamp` INT NOT NULL,
      `echoname` VARCHAR(120) NOT NULL,
      `repto` VARCHAR(120) NOT NULL,
      `msgfrom` VARCHAR(120) NOT NULL,
      `msgfromaddr` VARCHAR(120) NOT NULL,
      `msgto` VARCHAR(120) NOT NULL,
      `subj` VARCHAR(120) NOT NULL,
      `body` TEXT NOT NULL,
      `blacklisted` BOOLEAN NOT NULL DEFAULT 0,
      `content_id` VARCHAR(20) NOT NULL
      CHECK (`blacklisted` IN (0, 1)));
    CREATE TABLE `echo` (`id` INTEGER PRIMARY KEY AUTOINCREMENT,
      `name` VARCHAR(120) NOT NULL UNIQUE,
      `description` VARCHAR(500));
    CREATE TABLE `auth` (`id` INTEGER PRIMARY KEY AUTOINCREMENT,
      `username` VARCHAR(64) NOT NULL UNIQUE,
      `authstrhash` VARCHAR(64) NOT NULL,
      `posting_acl` VARCHAR(1024));
  }
  fdb close
}

# node logic here

# echo name validity check
proc validecho {str} {
  set len [string length $str]
  set validator {^[a-z0-9\-_]+\.[a-z0-9\-_\.]+$}
  return [expr {$len > 2 && $len < 121 && [regexp $validator $str]}]
}

# message ID validity check
proc validmsgid {str} {
  set validator {^[a-zA-Z0-9]+$}
  return [expr {[string length $str] == 20 && [regexp $validator $str]}]
}

# url component decoder
proc decurl {string} {
  set mapped [string map {+ { } \[ "\\\[" \] "\\\]" $ "\\$" \\ "\\\\"} $string]
  encoding convertfrom utf-8 [subst [regsub -all {%([[:xdigit:]]{2})} $string {[format %c 0x\1]}]]
}

# parse query parameters into a dict
proc qparams {url args} {
    set dict [list]
    foreach x [split [lindex [split $url ?] 1] &] {
        set x [split $x =]
        if {[llength $x] < 2} { lappend x "" }
        lappend dict {*}$x
    }
    if {[llength $args] > 0} {
        return [dict get $dict [lindex $args 0]]
    }
    return $dict
}

# /list.txt handler
proc listechos {dbfile} {
  sqlite3 db $dbfile -readonly true
  set res [db eval {
    SELECT CONCAT(`echo`.`name`, ':', COUNT(`msg`.`id`), ':', `echo`.`description`) FROM `echo`
      LEFT JOIN `msg` ON `msg`.`echoname` = `echo`.`name` WHERE `msg`.`blacklisted` = 0
      GROUP BY `msg`.`echoname` ORDER BY `echo`.`name`;
  }]
  db close
  return "[string trim [encoding convertto utf-8 [join $res \n]]]\n"
}

# /blacklist.txt handler
proc blacklisted {dbfile} {
  sqlite3 db $dbfile -readonly true
  set res [db eval {SELECT `msgid` FROM `msg` WHERE `blacklisted` = 1 ORDER BY `id` ASC;}]
  db close
  return "[string trim [join $res \n]]\n"
}

# /m handler
proc singlemsg {dbfile msgid} {
  set mdata {}
  sqlite3 db $dbfile -readonly true
  db eval {SELECT * from `msg` WHERE `msgid` = :msgid} msg {
    append mdata {ii/ok}
    if {$msg(repto) ne {}} {append mdata "/repto/$msg(repto)"}
    append mdata "\n$msg(echoname)\n$msg(timestamp)"
    append mdata "\n$msg(msgfrom)\n$msg(msgfromaddr)"
    append mdata "\n$msg(msgto)\n$msg(subj)\n\n[join $msg(body) \n]"
  }
  db close
  return "[string trim [encoding convertto utf-8 $mdata]]\n"
}

# /u/m handler
proc multimsg {dbfile idlist} {
  set mdata {}
  set query {SELECT * from `msg` WHERE `msgid` IN (}
  append query [join [lmap s $idlist {string cat ' $s '}] ,] {) ORDER BY `id` ASC;}
  sqlite3 db $dbfile -readonly true
  db eval $query msg {
    set mform {ii/ok}
    if {$msg(repto) ne {}} {append mform "/repto/$msg(repto)"}
    append mform "\n$msg(echoname)\n$msg(timestamp)"
    append mform "\n$msg(msgfrom)\n$msg(msgfromaddr)"
    append mform "\n$msg(msgto)\n$msg(subj)\n\n[join $msg(body) \n]"
    append mdata $msg(msgid) ":" [binary encode base64 [encoding convertto utf-8 $mform]] \n
  }
  db close
  return $mdata
}

# echo indexer for /e and /u/e
proc indexechos {dbfile echolist includenames offset limit} {
  set rdata {}
  set oquery {ORDER BY `id`}
  if {$limit > 0} { # trigger limiting logic only with positive limit value
    if {$offset >= 0} { # normal limiting flow
      append oquery " ASC LIMIT $offset,$limit"
    } else {
      set reallimit [expr {-$offset}]
      set realoffset [expr {$reallimit - $limit}]
      if {$realoffset >= 0} {
        append oquery " DESC LIMIT $realoffset,$reallimit"
      } else { # invalid limit, falling back to full query
        append oquery " ASC"
      }
    }
  }
  set query {SELECT CONCAT(`echoname`, ':', GROUP_CONCAT(`msgid`,'|' ORDER BY `id`)) AS `rowcat` FROM (}
  foreach echo $echolist {
    append query "SELECT * FROM (SELECT `id`, `msgid`, `echoname` FROM `msg` WHERE `echoname` = '$echo' $oquery) UNION ALL "
  }
  append query {SELECT NULL,NULL,NULL) GROUP BY `echoname` ORDER BY `echoname` ASC;}
  sqlite3 db $dbfile -readonly true
  db eval $query echorow {
    if {$echorow(rowcat) ne ""} {
      set eparts [split $echorow(rowcat) :]
      set ename [lindex $eparts 0]
      if {$ename ne ""} {
        if {$includenames > 0} {
          append rdata $ename \n
        }
        append rdata [join [split [lindex $eparts 1] "|"] \n] \n
      }
    }
  }
  db close
  return $rdata
}

# /u/point handler
proc postmsg {dbfile authstr body} {
  global nodename
  set msgfrom ""
  set acl ""
  set authhash [::sha2::sha256 -hex -- [string trim $authstr]]
  sqlite3 db $dbfile -readonly true
  db eval {SELECT `id`, `username`, `posting_acl` FROM `auth` WHERE `authstrhash` = :authhash} user {
    set msgfrom $user(username)
    set msgfromaddr "$nodename,$user(id)"
    set acl [string trim $user(posting_acl)]
  }
  db close

  if {$msgfrom ne ""} {
    # auth successful, process the body
    set p2nmsg [split [encoding convertfrom utf-8 [binary decode base64 $body]] "\n"]
    if {[llength $p2nmsg] > 4} {
      set echoname [string trim [lindex $p2nmsg 0]]
      if {$acl ne "*"} { # check if the user can post in the echo
        set posting_allowed 0
        set acl [split $acl ,]
        foreach acl_echo $acl {
          if {$echoname eq $acl_echo} {
            set posting_allowed 1
            break
          }
        }
        if {posting_allowed eq 0} {
          return "posting to this echo is not allowed for this user"
        }
      }
      set msgto [string trim [lindex $p2nmsg 1]]
      set subj [string trim [lindex $p2nmsg 2]]
      set line4 [string trim [lindex $p2nmsg 4]]
      if {[string match @repto:* $line4]} {
        set repto [string range $line4 7 end]
        if {![validmsgid $repto]} {return "invalid repto message ID"}
        set msgbody [join [lrange $p2nmsg 5 end] "\n"]
      } else {
        set repto ""
        set msgbody [join [lrange $p2nmsg 4 end] "\n"]
      }
      set timestamp [clock seconds]
      set mform {ii/ok}
      if {$repto ne {}} {append mform "/repto/$repto"}
      append mform "\n$echoname\n$timestamp"
      append mform "\n$msgfrom\n$msgfromaddr"
      append mform "\nmsgto\n$subj\n\n$msgbody"
      # generate the message ID
      set hash [::sha2::sha256 -bin -- $mform]
      set trimbased [string range [binary encode base64 $hash] 0 19]
      set msgid [string map {+ A - A / z _ z} $trimbased]
      # perform the insertion
      set msgbody [split $msgbody "\n"]
      sqlite3 db $dbfile
      db eval {INSERT OR IGNORE INTO `msg` (`msgid`, `timestamp`, `echoname`, `repto`,
        `msgfrom`, `msgfromaddr`, `msgto`, `subj`, `body`, `blacklisted`, `content_id`)
        VALUES (:msgid, :timestamp, :echoname, :repto, :msgfrom, :msgfromaddr, :msgto,
        :subj, :msgbody , 0, :msgid);}
      db close
      return "msg ok"
    } else {return "invalid message structure"}
  } else {return "no auth"}
}

# /u/push handler
proc postbundle {dbfile authstr body} {
  return "push logic is not implemented"
}

# / handler (index page)
proc indexpage {} {
  global nodename
  return [string cat "status: ready\nserver: tiid\nnodename: $nodename\n" \
{apis: /list.txt /blacklist.txt /e /m /u/e /u/m /u/point} \n]
}

# TCP logic here

# error report/reply
proc reperror {sock ishttp errmsg} {
  set errmsg "error: $errmsg\n"
  if {$ishttp eq 1} {
    set msglen [string length $errmsg]
    set hdrs "Content-Type: text/plain;charset=utf-8\r\nContent-Length: $msglen\r\nConnection: close\r\n"
    puts -nonewline $sock "HTTP/1.0 400 Bad Request\r\n$hdrs\r\n$errmsg"
  } else {
    puts -nonewline $sock "$errmsg"
  }
  flush $sock
}

# successful reply with data
proc repdata {sock ishttp data} {
  if {$ishttp eq 1} {
    set msglen [string length $data]
    set hdrs "Content-Type: text/plain;charset=utf-8\r\nContent-Length: $msglen\r\nConnection: close\r\n"
    puts -nonewline $sock "HTTP/1.0 200 OK\r\n$hdrs\r\n$data"
  } else {
    puts -nonewline $sock $data
  }
  flush $sock
}

# path router
# it only must write to the socket, not read from it or close it
# supported paths: /e, /m, /u/e, /u/m, /u/point, /list.txt, /blacklist.txt
proc routepath {dbfile sock ishttp path body} {
  fconfigure $sock -translation binary
  set pathparts [split [string trim $path] /]
  if {[llength $pathparts] > 1} {
    switch -- [lindex $pathparts 1] {
      u { # /u/ subrequests
        if {[llength $pathparts] > 2} {
          switch -- [lindex $pathparts 2] {
            e {
              set erange [lrange $pathparts 3 end]
              if {[llength $erange] > 0} {
                set limit 0
                set offset 0
                set lastel [lindex $erange end]
                if {[string match *?:?* $lastel]} { # slice detected
                  set sparts [split $lastel :]
                  set offset [expr {int([lindex $sparts 0])}]
                  set limit [expr {int([lindex $sparts 1])}]
                  set erange [lrange $erange 0 end-1]
                }
                # validate the rest of the echo list
                set erange [lmap ename $erange {expr {
                  [validecho $ename] ? $ename : [continue]
                }}]
                if {[llength $erange] > 0} { # recheck length after validation
                  repdata $sock $ishttp [indexechos $dbfile $erange 1 $offset $limit]
                } else {
                  reperror $sock $ishttp "invalid request"
                }
              } else {
                reperror $sock $ishttp "invalid request"
              }
            }
            m { # validate and shape the message ID list
              set mrange [lmap mid [lrange $pathparts 3 end] {expr {
                [validmsgid $mid] ? $mid : [continue]
              }}]
              if {[llength $mrange] > 0} { # we have some valid messages
                repdata $sock $ishttp [multimsg $dbfile $mrange]
              } else {
                reperror $sock $ishttp "invalid request"
              }
            }
            point {
              set msgbody ""
              set authstr ""
              if {$body ne ""} { # HTTP POST request
                set params [qparams "?$body"]
                if {[dict exists $params pauth]} {
                  set authstr [decurl [dict get $params pauth]]
                }
                if {[dict exists $params tmsg]} {
                  set msgbody [decurl [dict get $params tmsg]]
                }
              } else { # HTTP GET or a bare TCP request
                if {[llength $pathparts] > 4} {
                  set authstr [lindex $pathparts 3]
                  set msgbody [join [lrange $pathparts 4 end] /]
                  # perform urlsafe substitution
                  set msgbody [string map {- + _ /} $msgbody]
                }
              }
              if {$authstr ne "" && $msgbody ne ""} {
                set postres [postmsg $dbfile $authstr $msgbody]
                if [string match "msg ok*" $postres] {
                  repdata $sock $ishttp $postres
                } else {
                  reperror $sock $ishttp $postres
                }
              } else {
                reperror $sock $ishttp "invalid request"
              }
            }
            push {
              set msgbody ""
              set authstr ""
              if {$body ne ""} { # HTTP POST request
                set params [qparams "?$body"]
                if {[dict exists $params pauth]} {
                  set authstr [decurl [dict get $params nauth]]
                }
                if {[dict exists $params tmsg]} {
                  set msgbody [decurl [dict get $params upush]]
                }
              } else { 
                reperror $sock $ishttp "/u/push is only available over HTTP POST"
                return
              }
              if {$authstr ne "" && $msgbody ne ""} {
                set postres [postbundle $dbfile $authstr $msgbody]
                if [string match "message saved: ok*" $postres] {
                  repdata $sock $ishttp $postres
                } else {
                  reperror $sock $ishttp $postres
                }
              } else {
                reperror $sock $ishttp "invalid request"
              }
            }
            default {
              reperror $sock $ishttp "invalid request"
            }
          }
        } else {
          reperror $sock $ishttp "invalid request"
        }
      }
      e {
        if {[llength $pathparts] > 2} {
          set echoname [string trim [lindex $pathparts 2]]
          if {[validecho $echoname]} {
            repdata $sock $ishttp [indexechos $dbfile [list $echoname] 0 0 0]
          } else {
            reperror $sock $ishttp "invalid request"
          }
          
        } else {
          reperror $sock $ishttp "invalid request"
        }
      }
      m {
        if {[llength $pathparts] > 2} {
          set mid [string trim [lindex $pathparts 2]]
          if {[validmsgid $mid]} {
            repdata $sock $ishttp [singlemsg $dbfile $mid]
          } else {
            reperror $sock $ishttp "invalid request"
          }
        } else {
          reperror $sock $ishttp "invalid request"
        }
      }
      list.txt {
        repdata $sock $ishttp [listechos $dbfile]
      }
      blacklist.txt {
        repdata $sock $ishttp [blacklisted $dbfile]
      }
      {} {
        repdata $sock $ishttp [indexpage]
      }
      default {
        reperror $sock $ishttp "invalid request"
      }
    }
  } else {
    reperror $sock $ishttp "invalid request"
  }
}

# main multiproto request handler
proc reqhandler {dbfile sock} {
  # read the first request line
  # ignore all invalid requests by closing the connection
  if {[gets $sock line] >= 0} {
    if {[string match /* $line]} { # bare TCP request (Gopher/Nex)
      routepath $dbfile $sock 0 [string trim $line] {}
    } elseif {[string match -nocase {GET /*} $line]} { # HTTP GET request
      set rparts [split [string trimleft $line]]
      if {[llength $rparts] > 1} { # valid GET request
        routepath $dbfile $sock 1 [lindex $rparts 1] {}
      }
    } elseif {[string match -nocase {POST /*} $line]} { # HTTP POST request
      set rparts [split [string trimleft $line]]
      if {[llength $rparts] > 1} { # valid POST request, read POST headers and data
        set hdrread 0
        set hdata {}
        set pdata {}
        while {$hdrread < 1} {
          if {[eof $sock] || [catch {gets $sock line}]} {
            break
          } else {
            if {$line eq ""} {
              incr hdrread
              continue
            }
            set hparts [split [string trimleft $line] :]
            if {[llength $hparts] > 1} {
              set hname [string tolower [string trimright [lindex $hparts 0]]]
              set hval [string trim [lindex $hparts 1]]
              dict set hdata $hname $hval 
            }
          }
        }
        set readlen 0
        if {[dict exists $hdata content-length]} {
          set readlen [dict get $hdata content-length]
        }
        if {$readlen > 0} { # read the data defined by content-length header
          fconfigure $sock -translation {binary lf} -buffering none
          set pdata [read $sock $readlen]
        }
        routepath $dbfile $sock 1 [lindex $rparts 1] [string trimleft $pdata]
      }
    }
  }
  catch {close $sock}
}

# request accepter
proc reqaccept {dbfile sock addr port} {
  # set linefeed as the newline character for output
  # and translate anything into LF for input
  fconfigure $sock -translation {auto lf} -buffering line
  fileevent $sock readable [list reqhandler $dbfile $sock]
}

# entry point
if {$argc > 0} {
  set listenport [expr {int([lindex $argv 0])}]
  if {$listenport < 1 || $listenport > 65535} {
    puts "Invalid port specified!"
    exit 1
  }
  if {$argc > 1} {
    set nodename [string trim [lindex $argv 1]]
  }
  if {$argc > 2} {
    set localdb [file normalize [lindex $argv 2]]
  }
}
# create the db file if it doesn't exist
if {![file exists $localdb]} {
  puts "No DB found, creating..."
  createdb $localdb
}

# start the server
puts "tiid daemon $nodename listening on port $listenport"
socket -server [list reqaccept $localdb] $listenport
vwait forever