tii

tiifetch.tcl (13491B)

---

 #!/usr/bin/env tclsh
 # tiifetch: fetch all data from an ii/idec station into the local text db
 # (see https://github.com/idec-net/new-docs/blob/master/protocol-en.md)
 # Usage: tiifetch.tcl [station_url] [echos] [db_file]
 # The echo list should be delimited with slash (/), comma (,) or semicolon (;)
 # if no echos are specified (or "" is passed), then list.txt will be fetched
 # and then all missing echo content from it will be downloaded
 # If db_dir isn't specified, it's fetched and merged into the
 # tiidb directory in the program root with echoconfs and messages respectively
 # This component only fetches the messages, doesn't parse or display them
 # Supported protocols: HTTP, HTTPS, Gemini, Spartan, Gopher/Finger/Nex
 # Depends on Tcllib for URI parsing and SQLite3 for data storage
 # Created by Luxferre in 2024, released into public domain
 
 package require http
 package require uri
 package require sqlite3
 package require sha256
 
 # autodetect TclTLS support and enable HTTPS request support if detected
 set tls_support 0
 catch {package require tls; set tls_support 1}
 if {$tls_support eq 1} {
   ::http::register https 443 [list ::tls::socket -autoservername true]
 }
 
 proc url2dict {inputurl} {
   set out [dict create]
   if [regexp {^(.*)://} $inputurl _ lscheme] {
     dict set out scheme $lscheme
   } else {
     dict set out handler "render_handler_invalid"
     return $out
   }
   set rawout [::uri::split [regsub {^.*://} $inputurl "http://"]]
   set rhost [dict get $rawout host]
   set rpath [dict get $rawout path]
   set rport [dict get $rawout port]
   set secondarydata [dict get $rawout query]
   dict set out host $rhost
   set selector $rpath
   dict set out handler "render_handler_$lscheme"
   # protocol-specific request logic
   switch "$lscheme" {
     gophers -
     gopher {
       if {$rport eq ""} {set rport 70}
       set selector [string cat [string range $rpath 1 end] "\r\n"]
       dict set out handler render_handler_gopher
     }
     finger {
       if {$rport eq ""} {set rport 79}
       set selector "$selector\r\n"
     }
     spartan {
       if {$rport eq ""} {set rport 300}
       if {$rpath eq ""} {set rpath "/"}
       if {![string match "/*" $rpath]} {
         set rpath "/$rpath"
       }
       set blen [string length $secondarydata]
       set selector "$rhost $rpath $blen\r\n$secondarydata"
     }
     nex {
       if {$rport eq ""} {set rport 1900}
       set selector "$selector\r\n"
     }
     gemini {
       if {$rport eq ""} {set rport 1965}
       set selector "$inputurl\r\n"
     }
     default {dict set out handler render_handler_none}
   }
   dict set out path $rpath
   dict set out selector $selector
   dict set out port $rport
   return $out
 }
 
 proc reqresp {host port reqline is_tls encoding} {
   global sock_response net_timeout
   set sock 0
   if {$is_tls eq 1} {
     catch {set sock [::tls::socket -autoservername true -async $host $port]}
   } elseif {$is_tls eq 2} {
     catch {set sock [::tls::socket -autoservername true -async $host $port]}
     if {$sock eq 0} {catch {set sock [socket -async $host $port]}}
   } else {
     catch {set sock [socket -async $host $port]}
   }
   if {$sock eq 0} {set sock_response ""; return}
   global rcv_end_$sock
   unset -nocomplain rcv_end_$sock
   if {$encoding eq ""} {set encoding utf-8}
   fconfigure $sock -translation binary -buffering none -encoding $encoding
   fileevent $sock writable [list connected $sock $reqline]
   proc connected {sock reqline} {
     fileevent $sock writable {}
     puts -nonewline $sock "$reqline"
     flush $sock
     fileevent $sock readable [list rdbl $sock]
   }
   set sock_response ""
   proc rdbl {sock} {
     global sock_response rcv_end_$sock
     while {![eof $sock]} {
       append sock_response [read $sock]
     }
     set rcv_end_$sock 0
   }
   after $net_timeout "global rcv_end_$sock; set rcv_end_$sock 1"
   vwait rcv_end_$sock
   catch {close $sock}
   unset -nocomplain rcv_end_$sock
 }
 
 
 # file download helper
 proc getfile {url} {
   global net_timeout
   set url [regsub -all {([^:])//} $url {\1/}]
   set urlparts [url2dict $url]
   set scheme [dict get $urlparts scheme]
   set host [dict get $urlparts host]
   set port [dict get $urlparts port]
   set sel [dict get $urlparts selector]
   global sock_response tls_support
   switch $tls_support {
     0 {set localtls 0}
     1 {set localtls 2}
   }
   switch $scheme {
     gophers - gopher - finger - nex {
       if {$scheme eq "gophers"} {set localtls 1}
       reqresp $host $port $sel $localtls utf-8
       set body "$sock_response"
       set sock_response ""
       return $body
     }
     gemini - spartan {
       if {$scheme eq "gemini"} {set localtls 1}
       reqresp $host $port $sel $localtls utf-8
       set body "$sock_response"
       set sock_response ""
       if {[regexp {^([^\n]*)\n} $body _ statusline]} {
         set statusline [string trimright $statusline]
         set statusparts [split $statusline " "]
         set statuscode [lindex $statusparts 0]
         set mainstatuscode [string index $statuscode 0]
         if {$mainstatuscode eq 2} {
           regsub {.*?\n} $body "" body
           return $body
         } else {return {}}
       } else {return {}}
     }
     https - http {
       set hs ""
       while {$hs eq ""} {
         set hs [::http::geturl $url -binary 1 -keepalive 0 -timeout $net_timeout]
       }
       if {[::http::ncode $hs] eq "200"} {
         return [::http::data $hs]
       } else {return {}}
     }
     default {return {}}
   }
 }
 
 # file read helper
 proc readfile {fname} {
   set fp [open $fname r]
   fconfigure $fp -encoding utf-8
   set data [read $fp]
   close $fp
   return $data
 }
 
 # file write helper (leaves a newline at the end)
 proc writefileln {fname data} {
   set fp [open $fname w]
   fconfigure $fp -encoding utf-8
   puts $fp $data
   close $fp
 }
 
 # list comparison helper (listcomp $new $old)
 proc listcomp {new old} {
   foreach i $old {
     set new [lsearch -all -inline -not -exact $new $i]
   }
   return $new
 }
 
 # generate ID from the Node-to-Point msg contents
 # (exactly how it was transferred inside base64)
 proc n2p_id {binmsg} {
   set hash [::sha2::sha256 -bin -- $binmsg]
   set trimbased [string range [binary encode base64 $hash] 0 19]
   return [string map {+ A - A / z _ z} $trimbased]
 }
 
 # 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,
       `content_id` VARCHAR(20) NOT NULL);
   }
   fdb close
 }
 
 # main logic proc
 proc fetchiidb {url echos dbfile dolog maxids} {
   if {$maxids < 12} {set maxids 12}
   # trim the parameters 
   set url [string trim $url]
   set echos [string trim $echos]
   set dbfile [file normalize [string trim $dbfile]]
   if {![file exists $dbfile]} {createdb $dbfile}
   sqlite3 msgdb $dbfile
   # attempt to fetch the echolist if echos are empty
   if {$echos eq {}} {
     if {$dolog eq 1} {puts "Fetching echolist..."}
     set echolist [getfile "$url/list.txt"]
     set echos [lmap e [split $echolist "\n"] {lindex [split $e ":"] 0}]
   } else {
     set echos [split $echos "/,;"]
   }
   set echos [string trim [lmap s $echos {string trim $s " \t\r\n"}] " \t\r\n"]
   if {$dolog eq 1} {puts "Echos to fetch: $echos"}
   if {$dolog eq 1} {puts "Building message indexes..."}
   set echodata [getfile [string cat $url "/u/e/" [join $echos "/"]]]
   set datalines [split $echodata \n]
   # iterate over the fetched data and fetch corresponding messages
   set curecho ""
   set echomap ""
   # build the map of lists of message IDs
   foreach line $datalines {
     set line [string trim $line " \t\r\n"]
     if {$line ne ""} {
       # detect if the line is related to echo name or message ID 
       if {[string first "." $line] eq -1} { # message ID
         if {[string length $line] == 20} { # filter out invalid IDs
           if {$curecho ne ""} {
             dict lappend echomap $curecho $line
           }
         }
       } else { # echo name
         set curecho $line
         dict set echomap $curecho ""
       }
     }
   }
   if {$dolog eq 1} {puts "Echomap built"}
   # pass the echo list and fetch the message IDs
   # now, process the map we've built
   dict for {echoname msgids} $echomap {
     if {![string match *.* $echoname]} {continue} 
     if {[llength $msgids] eq 0} {continue}
     # get the existing message IDs in the echo
     set oldmsgids [msgdb eval {SELECT `msgid` FROM `msg` WHERE `echoname` = $echoname ORDER BY `id` ASC;}]
     # pre-filter the new message IDs to fetch
     set newmsgids [listcomp $msgids $oldmsgids] 
     set idgroups ""
     set grcount 0
     set localcount 0
     set globalcount 0
     foreach nmid $newmsgids { # iterate over new messages to group them
       if {$nmid ne ""} {
         set cid [string trim [msgdb eval {SELECT `msgid` FROM `msg` WHERE `msgid` = $nmid;}]]
         if {$nmid ne $cid} {
           incr globalcount
           # insert new message ID to the echo mapping
           dict lappend idgroups $grcount $nmid 
           incr localcount
           if {$localcount > $maxids} {
             incr grcount
             set localcount 0
           } 
         }
       }
     }
     if {$globalcount > 0} {
       if {$dolog eq 1} {puts "Fetching $globalcount new messages from $echoname..."}
       dict for {mgrpind mgrp} $idgroups { # iterate over groups to fetch the messages
         # get the message data in the bundle format
         set plen 0
         set retries 4
         while {$plen < $globalcount} {
           set msgbundle [getfile [string cat $url "/u/m/" [join $mgrp "/"]]]
           set bdata [lmap m [split $msgbundle "\n"] {
             set m [string trim $m]
             if {$m eq ""} {continue}
             set m
           }]
           set plen [llength $bdata]
           incr retries -1
           if {$retries < 1} {break}
         }
         foreach bline $bdata {
           set parts [split $bline ":"]
           if {[llength $parts] > 1} { # valid message
             set mid [string trim [lindex $parts 0]]
             set bdata [binary decode base64 [lindex $parts 1]]
             # calculate ii Node-to-Point ID to verify the message integrity
             set content_id [n2p_id $bdata]
             set mdata [encoding convertfrom utf-8 $bdata]
             set msglines [split $mdata "\n"]
             set replyto ""
             set tags [split [lindex $msglines 0] "/"]
             if {[dict exists $tags repto]} {
               set replyto [dict get $tags repto]
             } else {set replyto ""}
             set echoarea [string trim [lindex $msglines 1]]
             set timestamp [string trim [lindex $msglines 2]]
             set msgfrom [string trim [lindex $msglines 3]]
             set msgfromaddr [string trim [lindex $msglines 4]]
             set msgto [string trim [lindex $msglines 5]]
             set subj [string trim [lindex $msglines 6]]
             set msgbody [string trimright [lrange $msglines 8 end]]
             msgdb eval {INSERT OR IGNORE INTO `msg` (`msgid`, `timestamp`, `echoname`, `repto`, `msgfrom`, 
               `msgfromaddr`, `msgto`, `subj`, `body`, `content_id`) 
               VALUES ($mid, $timestamp, $echoarea, $replyto, $msgfrom, $msgfromaddr, $msgto, $subj, $msgbody, $content_id);}
           }
         }
       }
     }
   }
   msgdb close
 }
 
 proc massfetch {echos db dolog} {
   global appdir
   if {$dolog eq 1} {puts "No ii/idec station URL specified, using stations.txt"}
   set stfile [file join $appdir "stations.txt"]
   if {[file exists $stfile]} {
     set stlist [readfile $stfile]
     dict for {station stmaxids} $stlist {
       set station [string trim $station]
       if {$station ne "" && ![string match "#*" $station]} {
         if {$dolog eq 1} {puts "Fetching from $station"}
         fetchiidb $station $echos $db $dolog $stmaxids
       }
     }
   } else {
     if {$dolog eq 1} {puts "No stations.txt found, bailing out!"}
   }
 }
 
 # end of procs, start the entrypoint
 if {![info exists argv0] || [file tail [info script]] ne [file tail $argv0]} {return}
 
 set scriptpath [file normalize [info script]]
 set appdir [file dirname $scriptpath]
 # check if we're running from a starpack
 if [string match *app-tiifetch $appdir] {
   set appdir [file normalize [file join $appdir ".." ".." ".." ]]
 }
 set localdb [file join $appdir "tii.db"]
 
 # populate general HTTP configuration 
 set cfgfile [file join $appdir "config.txt"]
 set net_timeout 5000
 if {[file exists $cfgfile]} {
   set cfg [readfile $cfgfile]
   if {[dict exists $cfg useragent]} {
     ::http::config -useragent [dict get $cfg useragent] 
   }
   if {[dict exists $cfg proxyhost]} {
     ::http::config -proxyhost [dict get $cfg proxyhost] 
   }
   if {[dict exists $cfg proxyport]} {
     ::http::config -proxyport [dict get $cfg proxyport] 
   }
   if {[dict exists $cfg net_timeout]} {
     set net_timeout [dict get $cfg net_timeout]
   }
 }
 
 if {$argc > 0} {
   if {$argc > 2} {
     set localdb [lindex $argv 2]
   }
   puts "Fetching messages, please wait..."
   set sturl [string trim [lindex $argv 0]]
   if {$sturl eq ""} {
     massfetch [lindex $argv 1] $localdb 1
   } else {
     fetchiidb $sturl [lindex $argv 1] $localdb 1 12
   }
   puts "Messages fetched"
 } else {
   puts "Fetching messages, please wait..."
   massfetch "" $localdb 1
   puts "Messages fetched"
 }