#!/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 2} else {set localtls 0}
      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} else {set localtls 0}
      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"
}