549 lines
18 KiB
Tcl
Executable File
549 lines
18 KiB
Tcl
Executable File
#!/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 msglen [string length $errmsg]
|
|
set hdrs "Content-Type: text/plain;charset=utf-8\r\nContent-Length: $msglen\r\nConnection: close\r\n"
|
|
if {$compfunc ne {none}} {
|
|
set hdrs [string cat $hdrs "Content-Encoding: $compfunc\r\n"]
|
|
set errmsg [repcompress $compfunc $errmsg]
|
|
}
|
|
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 msglen [string length $data]
|
|
set hdrs "Content-Type: text/plain;charset=utf-8\r\nContent-Length: $msglen\r\nConnection: close\r\n"
|
|
if {$compfunc ne {none}} {
|
|
set hdrs [string cat $hdrs "Content-Encoding: $compfunc\r\n"]
|
|
set data [repcompress $compfunc $data]
|
|
}
|
|
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
|