tii

tiid.tcl (19015B)

---

 #!/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 {
     PRAGMA journal_mode=WAL;
     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
 
 # compression function
 proc repcompress {compfunc data} {
   if {$compfunc eq {gzip}} {
     return [zlib gzip $data -level 9]
   } else {
     return [zlib $compfunc $data 9]
   }
 }
 
 # error report/reply
 proc reperror {sock ishttp errmsg compfunc} {
   set errmsg "error: $errmsg\n"
   if {$ishttp eq 1} {
     set hdrs "Content-Type: text/plain;charset=utf-8\r\n"
     if {$compfunc ne {none}} {
       set hdrs [string cat $hdrs "Content-Encoding: $compfunc\r\n"]
       set errmsg [repcompress $compfunc $errmsg]
     }
     set msglen [string length $errmsg]
     set hdrs [string cat $hdrs "Content-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 compfunc} {
   if {$ishttp eq 1} {
     set hdrs "Content-Type: text/plain;charset=utf-8\r\n"
     if {$compfunc ne {none}} {
       set hdrs [string cat $hdrs "Content-Encoding: $compfunc\r\n"]
       set data [repcompress $compfunc $data]
     }
     set msglen [string length $data]
     set hdrs [string cat $hdrs "Content-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 compfunc} {
   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] $compfunc
                 } else {
                   reperror $sock $ishttp "invalid request" $compfunc
                 }
               } else {
                 reperror $sock $ishttp "invalid request" $compfunc
               }
             }
             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] $compfunc
               } else {
                 reperror $sock $ishttp "invalid request" $compfunc
               }
             }
             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 $compfunc
                 } else {
                   reperror $sock $ishttp $postres $compfunc
                 }
               } else {
                 reperror $sock $ishttp "invalid request" $compfunc
               }
             }
             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" $compfunc
                 return
               }
               if {$authstr ne "" && $msgbody ne ""} {
                 set postres [postbundle $dbfile $authstr $msgbody]
                 if [string match "message saved: ok*" $postres] {
                   repdata $sock $ishttp $postres $compfunc
                 } else {
                   reperror $sock $ishttp $postres $compfunc
                 }
               } else {
                 reperror $sock $ishttp "invalid request" $compfunc
               }
             }
             default {
               reperror $sock $ishttp "invalid request" $compfunc
             }
           }
         } else {
           reperror $sock $ishttp "invalid request" $compfunc
         }
       }
       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] $compfunc
           } else {
             reperror $sock $ishttp "invalid request" $compfunc
           }
           
         } else {
           reperror $sock $ishttp "invalid request" $compfunc
         }
       }
       m {
         if {[llength $pathparts] > 2} {
           set mid [string trim [lindex $pathparts 2]]
           if {[validmsgid $mid]} {
             repdata $sock $ishttp [singlemsg $dbfile $mid] $compfunc
           } else {
             reperror $sock $ishttp "invalid request" $compfunc
           }
         } else {
           reperror $sock $ishttp "invalid request" $compfunc
         }
       }
       list.txt {
         repdata $sock $ishttp [listechos $dbfile] $compfunc
       }
       blacklist.txt {
         repdata $sock $ishttp [blacklisted $dbfile] $compfunc
       }
       {} {
         repdata $sock $ishttp [indexpage] $compfunc
       }
       default {
         reperror $sock $ishttp "invalid request" $compfunc
       }
     }
   } else {
     reperror $sock $ishttp "invalid request" $compfunc
   }
 }
 
 # 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] {} none
     } else { # HTTP request, read headers
       set hdrread 0
       set hdata {}
       set docomp none
       while {$hdrread < 1} {
         if {[eof $sock] || [catch {gets $sock hline}]} {
           break
         } else {
           if {$hline eq ""} {
             incr hdrread
             continue
           }
           set hparts [split [string trimleft $hline] :]
           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 
           }
         }
       }
       if {[dict exists $hdata accept-encoding]} { # detect if we can gzip the output
         set enclist [dict get $hdata accept-encoding]
         if {[string match -nocase {*gzip*} $enclist]} {
           set docomp gzip
         } elseif {[string match -nocase {*deflate*} $enclist]} {
           set docomp deflate
         } elseif {[string match -nocase {*compress*} $enclist]} {
           set docomp compress
         }
       }
       if {[string match -nocase {GET /*} $line]} { # GET request
         set rparts [split [string trimleft $line]]
         if {[llength $rparts] > 1} { # valid GET request
           routepath $dbfile $sock 1 [lindex $rparts 1] {} $docomp
         }
       } elseif {[string match -nocase {POST /*} $line]} { # POST request
         set rparts [split [string trimleft $line]]
         if {[llength $rparts] > 1} { # valid POST request, read POST headers and data
           set pdata {}
           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] $docomp
         }
       }
     }
   }
   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