tii

Tcl-based suite for working with ii/idec protocol
git clone git://git.luxferre.top/tii.git
Log | Files | Refs | README

tiix.tcl (17583B)


      1 #!/usr/bin/env tclsh
      2 # tiix: GUI client for ii/idec networks that leverages capabilities
      3 # of tiifetch and tiipost and repimplements the tiiview functionality
      4 # Depends on tiifetch, tiipost, Tcllib, SQLite3 and Tk
      5 # Created by Luxferre in 2024, released into public domain
      6 
      7 package require Tk
      8 package require sqlite3
      9 
     10 set scriptpath [file normalize [info script]]
     11 set appdir [file dirname $scriptpath]
     12 # check if we're running from a starpack
     13 if [string match *app-tiix $appdir] {
     14   set appdir [file normalize [file join $appdir ".." ".." ".." ]]
     15 }
     16 
     17 # include tiifetch and tiipost
     18 
     19 source [file join $appdir "tiifetch.tcl"]
     20 source [file join $appdir "tiipost.tcl"]
     21 
     22 # populate general configuration 
     23 set cfg {}
     24 set tiix_font TkFixedFont
     25 set tiix_fontsize 10
     26 set tiix_fgcolor black
     27 set tiix_bgcolor white
     28 set tiix_linkcolor blue
     29 set useragent ""
     30 set proxyhost ""
     31 set proxyport 0
     32 set net_timeout 5000
     33 set cfgfile [file join $appdir "config.txt"]
     34 if {[file exists $cfgfile]} {
     35   set cfg [readfile $cfgfile]
     36   if {[dict exists $cfg useragent]} {
     37     set useragent [dict get $cfg useragent] 
     38     ::http::config -useragent $useragent
     39   }
     40   if {[dict exists $cfg proxyhost]} {
     41     set proxyhost [dict get $cfg proxyhost] 
     42     ::http::config -proxyhost $proxyhost
     43   }
     44   if {[dict exists $cfg proxyport]} {
     45     set proxyport [dict get $cfg proxyport] 
     46     ::http::config -proxyport $proxyport
     47   }
     48   if {[dict exists $cfg net_timeout]} {
     49     set net_timeout [dict get $cfg net_timeout]
     50   }
     51   if {[dict exists $cfg tiix_font]} {
     52     set tiix_font [dict get $cfg tiix_font]
     53   }
     54   if {[dict exists $cfg tiix_fontsize]} {
     55     set tiix_fontsize [dict get $cfg tiix_fontsize]
     56   }
     57   if {[dict exists $cfg tiix_fgcolor]} {
     58     set tiix_fgcolor [dict get $cfg tiix_fgcolor]
     59   }
     60   if {[dict exists $cfg tiix_bgcolor]} {
     61     set tiix_bgcolor [dict get $cfg tiix_bgcolor]
     62   }
     63   if {[dict exists $cfg tiix_linkcolor]} {
     64     set tiix_linkcolor [dict get $cfg tiix_linkcolor]
     65   }
     66 }
     67 
     68 # create the font
     69 font create tiix_font -family "$tiix_font" -size $tiix_fontsize -weight normal
     70 
     71 # create the widget font
     72 font create tiix_widget_font -family "sans-serif" -size 11
     73 option add *font tiix_widget_font
     74 ttk::style configure TButton -font tiix_widget_font
     75 ttk::style configure TCheckbutton -font tiix_widget_font
     76 ttk::style configure TNotebook.Tab -font tiix_widget_font
     77 ttk::style configure TEntry -insertcolor $tiix_fgcolor
     78 ttk::style configure TCombobox -insertcolor $tiix_fgcolor
     79 
     80 # get auth string mapping
     81 set authmap ""
     82 set authfile [file join $appdir "auth.txt"]
     83 if {[file exists $authfile]} {
     84   set authmap [readfile $authfile]
     85 }
     86 
     87 # get the local DB file path
     88 set localdb [file join $appdir "tii.db"]
     89 
     90 # set default GUI parameters
     91 
     92 set tiix_echoname ""
     93 set tiix_post_echoname ""
     94 set tiix_post_sturl ""
     95 set tiix_post_to "All"
     96 set tiix_post_subj ""
     97 set tiix_post_repto ""
     98 set tiix_filter_num 0
     99 set tiix_filter_regex ""
    100 set tiix_filter_rev 0
    101 set tiix_order_byid 0
    102 set tiix_status Ready
    103 set tiix_entry 0
    104 
    105 # viewer logic
    106 set linklist ""
    107 set linkcount 0
    108 
    109 proc clicklink {textw msgid} {
    110   set ci [lindex [$textw tag ranges "orig_tiixlink_$msgid"] 0]
    111   if {$ci ne ""} {$textw see $ci}
    112 }
    113 
    114 proc linkinsert {textw uri is_orig} {
    115   global linkcount linklist tiix_bgcolor tiix_linkcolor tiix_post_repto
    116   if {$is_orig eq 1} {
    117     set tagname "orig_tiixlink_$uri"
    118   } else {
    119     set tagname "tiixlink_$uri"
    120   }
    121   $textw insert end $uri $tagname
    122   $textw tag configure $tagname -underline on -foreground $tiix_linkcolor -background $tiix_bgcolor
    123   $textw tag bind $tagname <Enter> {%W configure -cursor hand2}
    124   $textw tag bind $tagname <Leave> {%W configure -cursor $contentcursor}
    125   if {$is_orig eq 0} { # scroll on click
    126     $textw tag bind $tagname <Button-1> "clicklink $textw $uri"
    127   } else { # insert to repto field on click
    128     $textw tag bind $tagname <Button-1> "set tiix_post_repto $uri; updatefromreps; .tabbar select .tabbar.p"
    129   }
    130   incr linkcount
    131   lappend linklist $uri
    132 }
    133 
    134 proc tiix_viewecho {} {
    135   global localdb linkcount tiix_echoname
    136   global tiix_filter_num tiix_filter_regex tiix_filter_rev tiix_order_byid
    137   if {$tiix_echoname eq ""} {
    138     errmsg "Please select an echo conference to read!"
    139     return
    140   }
    141   # open the message db
    142   sqlite3 msgdb $localdb -readonly true
    143   set query {SELECT * FROM `msg` WHERE `echoname` = $tiix_echoname}
    144   if {$tiix_filter_regex ne {}} {
    145     set flt "%$tiix_filter_regex%"
    146     append query { AND (`body` LIKE $flt OR `subj` LIKE $flt) }
    147   }
    148   if {$tiix_order_byid eq 1} {
    149     append query { ORDER BY `id` }
    150   } else {
    151     append query { ORDER BY `timestamp` }
    152   }
    153   if {$tiix_filter_rev eq 1} {append query DESC} else {append query ASC}
    154   if {$tiix_filter_num > 0} {append query { LIMIT $tiix_filter_num}}
    155   append query ";"
    156   set textw .tabbar.r.content.text
    157   $textw configure -state normal
    158   $textw delete 1.0 end
    159   set linkcount 0
    160   set linklist ""
    161   msgdb eval $query msg {  # iterate over the list after filtering
    162     set globalline [string repeat = 80]
    163     set hdrline [string repeat - 80]
    164     set tz ""
    165     set renderedts ""
    166     catch { # because some servers don't provide timestamps
    167       set renderedts [clock format [string trim $msg(timestamp)] -format {%Y-%m-%d %H:%M:%S} -timezone $tz]
    168     }
    169     set textw .tabbar.r.content.text
    170     $textw insert end "\[$renderedts\] "
    171     linkinsert $textw $msg(msgid) 1
    172     set msg(content_id) [string trim $msg(content_id)]
    173     if {$msg(msgid) ne $msg(content_id)} {
    174       $textw insert end " (ID hash mismatch!)"
    175     }
    176     set msg(echoname) [string trim $msg(echoname)]
    177     set msg(msgfrom) [string trim $msg(msgfrom)]
    178     set msg(msgfromaddr) [string trim $msg(msgfromaddr)]
    179     set msg(msgto) [string trim $msg(msgto)]
    180     set msg(repto) [string trim $msg(repto)]
    181     set msg(subj) [string trim $msg(subj)]
    182     $textw insert end "\n$msg(echoname) - $msg(msgfrom) ($msg(msgfromaddr)) to $msg(msgto)\n"
    183     if {$msg(repto) ne ""} {
    184       $textw insert end "Replied to: "
    185       linkinsert $textw $msg(repto) 0
    186       $textw insert end "\n"
    187     }
    188     set msg(body) [lmap s $msg(body) {string trimright $s}]
    189     $textw insert end "Subj: $msg(subj)\n$hdrline\n[join $msg(body) \n]\n\n$globalline\n\n"
    190   }
    191   $textw configure -state disabled
    192   # close the message db
    193   msgdb close
    194 }
    195 
    196 # fetcher frontend
    197 proc tiix_fetchecho {echoname} {
    198   if {$echoname eq ""} {
    199     set answer [tk_messageBox -title "tiix fetch" -message "Fetch all echos from all registered stations?" \
    200         -icon question -type yesno -detail "This can take some time."]
    201     switch -- $answer {
    202       yes {}
    203       no {return}
    204     }
    205   }
    206   global tiix_status localdb
    207   set tiix_status "Fetching echo contents..."
    208   massfetch $echoname $localdb 0
    209   set tiix_status Ready
    210 }
    211 
    212 proc errmsg {msg} {
    213   tk_messageBox -type ok -title "tiix error" -icon error -message $msg
    214 }
    215 
    216 # GUI part
    217 set contentcursor "left_ptr"
    218 
    219 wm title . "tiix"
    220 wm minsize . 800 600
    221 ttk::notebook .tabbar
    222 ttk::notebook::enableTraversal .tabbar
    223 grid .tabbar -row 0 -column 0 -sticky nswe
    224 grid columnconfigure . 0 -weight 1
    225 grid rowconfigure . 0 -weight 1
    226 .tabbar add [ttk::frame .tabbar.r] -text "Fetch & Read"
    227 .tabbar add [ttk::frame .tabbar.p] -text "Post"
    228 .tabbar add [ttk::frame .tabbar.c] -text "Configuration"
    229 ttk::frame .infoframe
    230 ttk::label .infoframe.author -text "tiix by Luxferre, 2024"
    231 ttk::label .infoframe.status -textvariable tiix_status
    232 pack .infoframe.status -side left
    233 pack .infoframe.author -side right
    234 grid .infoframe -row 1 -column 0 -sticky we
    235 
    236 # Viewer widgets
    237 
    238 ttk::frame .tabbar.r.addrframe
    239 ttk::frame .tabbar.r.addrframe.f
    240 ttk::frame .tabbar.r.addrframe.c
    241 ttk::label .tabbar.r.addrframe.f.el -text "Echo name"
    242 ttk::combobox .tabbar.r.addrframe.f.echo -width 25 -textvariable tiix_echoname -postcommand {
    243   sqlite3 msgdb $localdb -readonly true
    244   set echonames [msgdb eval {SELECT DISTINCT `echoname` FROM `msg` ORDER BY `echoname`;}]
    245   msgdb close
    246   .tabbar.r.addrframe.f.echo config -values $echonames
    247 }
    248 ttk::label .tabbar.r.addrframe.c.aml -text "# Messages:"
    249 ttk::entry .tabbar.r.addrframe.c.amt -textvariable tiix_filter_num -width 8
    250 ttk::checkbutton .tabbar.r.addrframe.c.rev -variable tiix_filter_rev -offvalue 0 -onvalue 1 -text "Reverse"
    251 ttk::checkbutton .tabbar.r.addrframe.c.byid -variable tiix_order_byid -offvalue 0 -onvalue 1 -text "By ID"
    252 grid .tabbar.r.addrframe.c.aml -row 0 -column 0 -sticky nse
    253 grid .tabbar.r.addrframe.c.amt -row 0 -column 1 -sticky w -padx 5
    254 grid .tabbar.r.addrframe.c.rev -row 1 -column 0 -sticky nswe
    255 grid .tabbar.r.addrframe.c.byid -row 1 -column 1 -sticky nswe
    256 grid rowconfigure .tabbar.r.addrframe.c 0 -weight 1
    257 grid rowconfigure .tabbar.r.addrframe.c 1 -weight 1
    258 ttk::label .tabbar.r.addrframe.f.rg -text "Search filter"
    259 ttk::entry .tabbar.r.addrframe.f.rgx -textvariable tiix_filter_regex -width 25
    260 ttk::button .tabbar.r.addrframe.go -text "Read messages" -command tiix_viewecho
    261 ttk::button .tabbar.r.addrframe.f.fetchecho -text "Fetch this echo" -command {tiix_fetchecho $tiix_echoname}
    262 ttk::button .tabbar.r.addrframe.f.fetchall -text "Fetch all echos " -command {tiix_fetchecho ""}
    263 grid .tabbar.r.addrframe.f.fetchecho -row 0 -column 2 -sticky e -padx 5
    264 grid .tabbar.r.addrframe.f.fetchall -row 1 -column 2 -sticky e -padx 5
    265 grid .tabbar.r.addrframe.f.el -row 0 -column 0 -sticky nsw
    266 grid .tabbar.r.addrframe.f.echo -row 0 -column 1 -sticky w
    267 grid .tabbar.r.addrframe.f.rg -row 1 -column 0 -sticky nsw
    268 grid .tabbar.r.addrframe.f.rgx -row 1 -column 1 -sticky w
    269 grid .tabbar.r.addrframe.f -row 0 -column 0 -sticky nswe -pady 2
    270 grid .tabbar.r.addrframe.c -row 0 -column 1 -sticky nswe -pady 2
    271 grid .tabbar.r.addrframe.go -row 0 -column 2 -sticky nswe -pady 2 -padx 10
    272 grid .tabbar.r.addrframe -column 0 -row 0 -sticky nsew
    273 grid columnconfigure .tabbar.r.addrframe 2 -weight 1
    274 
    275 ttk::frame .tabbar.r.content
    276 tk::text .tabbar.r.content.text -cursor $contentcursor -yscrollcommand ".tabbar.r.content.yscroll set" -wrap word \
    277   -font tiix_font -foreground $tiix_fgcolor -background $tiix_bgcolor -state disabled
    278 ttk::scrollbar .tabbar.r.content.yscroll -orient vertical -command ".tabbar.r.content.text yview"
    279 grid .tabbar.r.content -column 0 -row 1 -sticky nsew
    280 grid .tabbar.r.content.text -column 0 -row 0 -sticky nsew
    281 grid .tabbar.r.content.yscroll -column 1 -row 0 -sticky ns
    282 grid columnconfigure .tabbar.r.content 0 -weight 1
    283 grid rowconfigure .tabbar.r.content 0 -weight 1
    284 grid columnconfigure .tabbar.r 0 -weight 1
    285 grid rowconfigure .tabbar.r 0 -weight 0
    286 grid rowconfigure .tabbar.r 1 -weight 1
    287 
    288 # Poster widgets
    289 
    290 ttk::frame .tabbar.p.addrframe
    291 ttk::label .tabbar.p.addrframe.el -text "Echo name"
    292 ttk::combobox .tabbar.p.addrframe.echo -width 25 -textvariable tiix_post_echoname -postcommand {
    293   sqlite3 msgdb $localdb -readonly true
    294   set echonames [msgdb eval {SELECT DISTINCT `echoname` FROM `msg` ORDER BY `echoname`;}]
    295   msgdb close
    296   .tabbar.p.addrframe.echo config -values $echonames
    297 }
    298 ttk::label .tabbar.p.addrframe.stlbl -text "Station "
    299 ttk::combobox .tabbar.p.addrframe.sturl -textvariable tiix_post_sturl -width 25 -postcommand {
    300   .tabbar.p.addrframe.sturl config -values [dict keys $authmap]
    301 }
    302 ttk::label .tabbar.p.addrframe.tolbl -text "To:"
    303 ttk::entry .tabbar.p.addrframe.to -textvariable tiix_post_to -width 20
    304 ttk::label .tabbar.p.addrframe.subjlbl -text "Subj:"
    305 ttk::entry .tabbar.p.addrframe.subj -textvariable tiix_post_subj -width 20
    306 ttk::label .tabbar.p.addrframe.reptolbl -text "Rep:"
    307 ttk::entry .tabbar.p.addrframe.repto -textvariable tiix_post_repto -width 20
    308 ttk::button .tabbar.p.addrframe.send -text "Send!" -command {
    309   set tiix_post_sturl [string trimright [string trim $tiix_post_sturl] "/"]
    310   set tiix_post_echoname [string trim $tiix_post_echoname]
    311   set tiix_post_to [string trim $tiix_post_to]
    312   set tiix_post_subj [string trim $tiix_post_subj]
    313   set tiix_post_repto [string trim $tiix_post_repto]
    314   set tiix_post_text [string trimright [.tabbar.p.content.text get -displaychars 1.0 end]]
    315   if {$tiix_post_sturl eq ""} {
    316     errmsg "Station URL is required!"
    317   } elseif {$tiix_post_echoname eq ""} {
    318     errmsg "Echo name is required!"
    319   } elseif {$tiix_post_subj eq ""} {
    320     errmsg "Subj field is required!"
    321   } elseif {$tiix_post_text eq ""} {
    322     errmsg "Post text cannot be empty!"
    323   } else {
    324     if {$tiix_post_to eq ""} {set tiix_post_to All}
    325     # read auth string for the station
    326     set authstr ""
    327     if {[dict exists $authmap $tiix_post_sturl]} {
    328       set authstr [dict get $authmap $tiix_post_sturl]
    329     }
    330     # call the posting function
    331     set answer [tk_messageBox -title "tiix post" -message "Post the message?" -icon question -type yesno]
    332     if {$answer eq "yes"} {
    333       set prev_status $tiix_status
    334       set tiix_status "Posting to $tiix_post_echoname at $tiix_post_sturl..."
    335       set res [postiidata $tiix_post_sturl $authstr $tiix_post_echoname $tiix_post_to $tiix_post_subj $tiix_post_repto $tiix_post_text]
    336       set status [dict get $res status]
    337       set result [dict get $res result]
    338       if {$status} {
    339         set tiix_status "Posting success: $result"
    340         .tabbar.p.content.text delete 1.0 end
    341       } else {
    342         set tiix_status "Posting error: $result"
    343       }
    344       after 5000 {set tiix_status $prev_status}
    345     }
    346   }
    347 }
    348 grid .tabbar.p.addrframe.el -column 0 -row 0 -sticky nsw
    349 grid .tabbar.p.addrframe.echo -column 1 -row 0 -sticky e
    350 grid .tabbar.p.addrframe.stlbl -column 0 -row 1 -sticky nsw
    351 grid .tabbar.p.addrframe.sturl -column 1 -row 1 -sticky e
    352 grid .tabbar.p.addrframe.tolbl -column 2 -row 0 -sticky nsw
    353 grid .tabbar.p.addrframe.to -column 3 -row 0
    354 grid .tabbar.p.addrframe.subjlbl -column 2 -row 1 -sticky nsw
    355 grid .tabbar.p.addrframe.subj -column 3 -row 1 -columnspan 3 -sticky we
    356 grid .tabbar.p.addrframe.reptolbl -column 4 -row 0 -sticky nsw
    357 grid .tabbar.p.addrframe.repto -column 5 -row 0
    358 grid .tabbar.p.addrframe.send -column 6 -rowspan 2 -row 0 -sticky nswe
    359 grid rowconfigure .tabbar.p.addrframe 0 -pad 2
    360 grid columnconfigure .tabbar.p.addrframe 6 -weight 1
    361 grid .tabbar.p.addrframe -column 0 -row 0 -sticky nws -pady 2
    362 ttk::frame .tabbar.p.content
    363 tk::text .tabbar.p.content.text -cursor $contentcursor -yscrollcommand ".tabbar.p.content.yscroll set" -wrap word \
    364   -font tiix_font -foreground $tiix_fgcolor -background $tiix_bgcolor -insertbackground $tiix_fgcolor -state normal
    365 ttk::scrollbar .tabbar.p.content.yscroll -orient vertical -command ".tabbar.p.content.text yview"
    366 grid .tabbar.p.content -column 0 -row 1 -sticky nsew
    367 grid .tabbar.p.content.text -column 0 -row 0 -sticky nsew
    368 grid .tabbar.p.content.yscroll -column 1 -row 0 -sticky ns
    369 grid columnconfigure .tabbar.p.content 0 -weight 1
    370 grid rowconfigure .tabbar.p.content 0 -weight 1
    371 grid columnconfigure .tabbar.p 0 -weight 1
    372 grid rowconfigure .tabbar.p 0 -weight 0
    373 grid rowconfigure .tabbar.p 1 -weight 1
    374 
    375 # Configuration widgets
    376 
    377 set rownum 0
    378 dict for {cname cval} $cfg {
    379   ttk::label .tabbar.c.cfglbl_$cname -text $cname
    380   if {[string match *color $cname]} {
    381     ttk::button .tabbar.c.cfgtxt_$cname -textvariable $cname -command "set $cname \[tk_chooseColor -initialcolor $cval -title {Choose color}\]"
    382   } else {
    383     ttk::entry .tabbar.c.cfgtxt_$cname -textvariable $cname
    384   }
    385   grid .tabbar.c.cfglbl_$cname -row $rownum -column 0 -sticky nsw -padx 5 -pady 5
    386   grid .tabbar.c.cfgtxt_$cname -row $rownum -column 1 -sticky nswe -pady 5
    387   incr rownum
    388 }
    389 ttk::button .tabbar.c.cfgsave -text "Save configuration" -command {
    390   set answer [tk_messageBox -title "tiix config" -message "Save the config file?" -icon question -type yesno]
    391   if {$answer eq "yes"} {
    392     set cfgtext ""
    393     dict for {cname cval} $cfg {
    394       append cfgtext "$cname \"[set $cname]\"\n"
    395     }
    396     writefileln $cfgfile [string trim $cfgtext]
    397     tk_messageBox -title "tiix config" -type ok -icon info -message "Configuration saved!" -detail "Restart tiix to see the changes"
    398   }
    399 }
    400 grid .tabbar.c.cfgsave -row $rownum -column 0 -sticky nsw -padx 5
    401 grid columnconfigure .tabbar.c 1 -weight 1
    402 
    403 # Custom bindings
    404 
    405 proc updatefromreps {} {
    406   global tiix_post_repto localdb tiix_post_to tiix_post_subj tiix_post_echoname
    407   set tiix_post_repto [string trim $tiix_post_repto]
    408   if {$tiix_post_repto ne ""} {
    409     sqlite3 msgdb $localdb -readonly true
    410     msgdb eval {SELECT * FROM `msg` WHERE `msgid`=$tiix_post_repto;} msg {
    411       set tiix_post_to [string trim $msg(msgfrom)]
    412       set tiix_post_subj [string trim $msg(subj)]
    413       set tiix_post_echoname [string trim $msg(echoname)]
    414       if {![string match "Re: *" $tiix_post_subj]} {
    415         set tiix_post_subj "Re: $tiix_post_subj"
    416       }
    417       set textw .tabbar.p.content.text
    418       # some nickname shortening heuristics
    419       set shortnick $tiix_post_to
    420       set parts [split $shortnick " "]
    421       if {[llength $parts] > 1} {
    422         set shortnick ""
    423         foreach p $parts {
    424           append shortnick [string index $p 0]
    425         }
    426       }
    427       if {![string match "$shortnick>*" [$textw get 1.0 1.end]]} {
    428         $textw insert 1.0 "[string trimright [join [lmap s $msg(body) {string cat $shortnick {> } [string trimright $s]}] \n]]\n"
    429       }
    430     }
    431     msgdb close
    432 
    433   }
    434 }
    435 
    436 bind .tabbar.p.addrframe.repto <Return> updatefromreps
    437 bind .tabbar.p.addrframe.repto <Leave> updatefromreps
    438 
    439 # general keybinding switch
    440 
    441 bind .tabbar.r.content.text <Key> {
    442   if {$tiix_entry eq 0} {
    443     switch "%K" {
    444       Prior -
    445       h {.tabbar.r.content.text yview scroll -1 pages}
    446       Next -
    447       l {.tabbar.r.content.text yview scroll 1 pages}
    448       Down -
    449       j {.tabbar.r.content.text yview scroll 1 units}
    450       Up -
    451       k {.tabbar.r.content.text yview scroll -1 units}
    452       default {}
    453     }
    454   }
    455 }
    456 
    457 # exit
    458 bind . <Control-q> {exit 0}