400 lines
13 KiB
Tcl
Executable File
400 lines
13 KiB
Tcl
Executable File
#!/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
|
|
set sock_net_timeout 5000
|
|
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 $sock_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} {
|
|
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 [::http::geturl $url -binary 1 -keepalive 0 -timeout 10000]
|
|
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"]
|
|
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 {$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"
|
|
}
|
|
|