#! /bin/env tclsh

package require Tk
package require nntp
namespace import ::tcl::mathfunc::*
namespace import ::tcl::mathop::*

proc sproc {name argspec svars body} {
    set script [string map [list {{{svars}}} [list $svars]] {
        variable state
        foreach varname [set svars {{svars}}] {
            upvar 0 state($id,$varname) $varname
        }
    }]
    proc $name $argspec "$script$body"
}

proc labelentry {id parent labeltext textvar bindings} {
    label $parent.label -text $labeltext
    entry $parent.entry -textvariable $textvar
    foreach {event action} $bindings {
        bind $parent.entry $event [list $action $id]
    }
    bind $parent.entry <Escape> [list goback $id]
}

proc scrolledlist {id parent data selected updater} {
    scrollbar $parent.y -command [
        list $parent.l yview]
    listbox $parent.l -yscrollc [list $parent.y set]
    set max 20
    foreach data1 $data {
        $parent.l insert end $data1
        set max [max [string length $data1] $max]
        if {$selected eq $data1} {
            $parent.l activate end
        }
    }
    $parent.l configure -width $max
    foreach sequence {<Double-Button-1> <Return>} {
        bind $parent.l $sequence [namespace code $updater]
    }
    bind $parent.l <Escape> [namespace code [list goback $id]]
}

proc main argv {
    variable data
    set id [info cmdcount]
    if {[llength $argv]} {
        lappend cmdargs path [lindex $argv 0]
    }
    lappend cmdargs w [set frame [frame .[info cmdcount]]]
    pack $frame -fill both -expand 1
    ui $id [namespace current]::defaults {*}$cmdargs
}

sproc ui {id statevar args} {busy deadhosts displayheaders firstload 
    from fromcolor group host hosts lastgroup lasthost load loaded messages
    n num username password newcolor seencolor replycolor status subjectcolor
    to w winstack} {
    variable $statevar
    dict with $statevar {dict with args {}}
    set busy [set lastgroup [set lasthost [set messages [set status {}]]]]
    set from [set to [set num {}]]
    set load $firstload

    text [frame $w.intro].msg
    foreach phrase {
        {{A little NNTP Reader} bold \n\n}
        {Invocation: bold \n\n}
        {programname overstrike dirname italic \n}
        {{dirname} italic {
            is the name of a directory that can be used exclusively by the
            program for data storage
        } \n}
        {{Authentication
            {Leave username field blank for an anonynomous session}} {} \n\n}
        {{General Keys:} bold  \n\n}
        {{Escape {return to previous screen}} {} \n}
        {{Return continue} {} \n\n}
        {{Message List Keys:} bold  \n\n}
        {{m {load more messages}} {} \n\n}
        {{Message Keys:} bold \n\n}
        {{h {view headers}} {} \n} 
        {{n {next message}} {} \n}
        {{p {previous message}} {} \n}
        {{b {backward in thread}} {} \n}
        {{f {forward in thread}} {} \n}
    } {
        $w.intro.msg insert end {*}$phrase
    }
    $w.intro.msg mark set insert 1.0
    $w.intro.msg tag configure bold -font bold
    textwrapper $w.intro.msg
    bind $w.intro.msg <Return> [list uiswitch $id ui_hosts]
    bind $w.intro.msg <Escape> [list goback $id]

    scrolledlist $id [frame [frame $w.hosts].listf] $hosts $host [
        list hosts_entry_update $id]
    entry $w.hosts.entry -textvar [namespace current]::state($id,host)
    foreach sequence {<Double-Button-1> <Return>} {
        bind $w.hosts.entry $sequence [
            namespace code [list uiswitch $id ui_authentication]]
    }

    labelentry $id [frame [frame $w.authentication].username] username [
        namespace current]::state($id,username) {<Return> connect}
    labelentry $id [frame $w.authentication.password] password [
        namespace current]::state($id,password) {<Return> connect}
    $w.authentication.password.entry configure -show *

    scrolledlist $id [frame [frame $w.groups].listf] {
        {double-click to load groups}
    } $group [list getgroups $id]   
    $w.groups.listf.l configure -width 27
    entry $w.groups.entry -textvariable [namespace current]::state($id,group)
    bind $w.groups.entry <Return> [list uiswitch $id ui_group]
    bind $w.groups.entry <Escape> [list goback $id]

    scrolledlist $id [frame $w.x] {} {} [list uiswitch $id ui_message]
    bind $w.x.l <Escape> [list goback $id] 
    bind $w.x.l m [list moremessages $id] 

    set textopts {-wrap word -padx 5 -pady 3 -height 12 -font {Helvetica 9}}
    scrollbar [frame $w.h].y -command [list $w.h.t yview]
    textwrapper [text $w.h.t {*}$textopts -yscrollc [list $w.h.y set]]
    foreach color [list $fromcolor $replycolor $subjectcolor] {
        $w.h.t tag configure $color -foreground $color
    }
    bind $w.h.t h [list ui_header $id]

    scrollbar [frame $w.f].y -command [list $w.f.t yview]
    textwrapper [text $w.f.t {*}$textopts -yscrollc [list $w.f.y set]]
    foreach color [list $fromcolor $replycolor $subjectcolor] {
        $w.f.t tag configure $color -foreground $color
    }
    bind $w.f.t <Escape> [list goback $id]
    bind $w.f.t h [list ui_header $id]
    bind $w.f.t n [list nextmessage $id] 
    bind $w.f.t p [list prevmessage $id] 
    bind $w.f.t b [list threadmove $id -1] 
    bind $w.f.t f [list threadmove $id 1] 

    label $w.status -textvariable [namespace current]::state($id,status)
    uiswitch $id ui_intro
}

sproc uiswitch {id next args} {w winstack} {
    lappend winstack $next
    pforget $w
    pack $w.status -side bottom -fill x
    $next $id {*}$args
}

sproc ui_intro id {w winstack} {
    pack $w.intro {*}[winfo children $w.intro]
    selection own $w.intro
    focus $w.intro.msg
}

sproc ui_hosts id {w winstack} {
    pack $w.hosts $w.hosts.listf -fill y -expand 1
    pack $w.hosts.listf.y -fill y -side right
    pack $w.hosts.listf.l -fill y -expand 1
    pack $w.hosts.entry -fill x
    focus $w.hosts.listf.l
    selection own $w.hosts.listf.l
    $w.hosts.listf.l selection set active
}

sproc ui_authentication id {w status winstack} {
    set status {}
    pack $w.authentication {*}[winfo children $w.authentication] {*}[
        winfo children $w.authentication.username] {*}[
        winfo children $w.authentication.password] 
    focus $w.authentication.username.entry
    selection own $w.authentication.username.entry
}

sproc ui_groups id w {
    pack $w.groups $w.groups.listf -fill y -expand 1
    pack $w.groups.listf.y -fill y -side right
    pack $w.groups.listf.l -fill y -expand 1
    pack $w.groups.entry -fill x
    if {[$w.groups.listf.l index end] > 1} {
        $w.groups.listf.l selection clear 0 end
        focus $w.groups.listf.l
        selection own $w.groups.listf.l
        $w.groups.listf.l selection set active
    } else {
        focus $w.groups.entry
        selection own $w.groups.entry
    }
}

sproc ui_group id {w} {
    pack $w.x -fill both -expand 1
    pack $w.x.y -fill y -side right
    pack $w.x.l -fill both -expand 1 -side right
    $w.x.l selection clear 0 end
    $w.x.l selection set active
    focus $w.x.l
    group $id
}

sproc ui_header id {displayheaders w} {
    set displayheaders [! $displayheaders]
    uiswitch $id ui_message
}

sproc ui_message id {displayheaders w} {
    if {$displayheaders} {
        pack $w.h -fill both
        pack $w.h.y -fill y -side right
        pack $w.h.t -fill both
    }
    pack $w.f -fill both -expand 1
    pack $w.f.y -fill y -side right
    pack $w.f.t -fill both -expand 1 -side right
    focus $w.f.t
    body $id
}

sproc connect id {host lasthost n username password status w} {
    set status Connecting...
    if {$lasthost ne $host} {
        if {[llength $host] == 1} {
            lappend host 119
        }
        set n [nntp::nntp {*}$host]
        if {$username ne {}} {
            $n authinfo $username $password
        }
        set lasthost $host
    }
    set status {}
    uiswitch $id ui_groups
}

sproc groups_entry_update id {w group} {
    if {[set idx [$w.groups.listf.l curselection]] ne {}} {
        set group [lindex [$w.groups.listf.l get $idx] 0]
        uiswitch $id ui_group 
    }
}

sproc hosts_entry_update {id} {host w} {
    if {[set idx [$w.hosts.listf.l curselection]] ne {}} {
        set host [lindex [$w.hosts.listf.l get $idx] 0]
        uiswitch $id ui_authentication
    }
}

sproc getgroups id {n status w} {
    $w.groups.listf.l delete 0 end
    set status {Retrieving groups...}
    after idle [list getgroups2 $id]
}

sproc getgroups2 id {n status w} {
    set max 20
    foreach group [lsort [$n list]] {
        set max [max [string length $group] $max]
        $w.groups.listf.l insert end $group
    }
    $w.groups.listf.l activate 0
    if {[string first $w.groups [selection own]] == 0} {
        $w.groups.listf.l selection set 0
    }
    $w.groups.listf.l configure -width $max
    foreach sequence {<Double-Button-1> <Return>} {
        bind $w.groups.listf.l $sequence [list groups_entry_update $id]
    }
    set status {}
}

sproc group id {body busy firstload from group lastgroup host lasthost
    load loaded loadnext messages n num to w} {
    variable data
    if {$lastgroup ne $group || $lasthost ne $host} {
        after cancel $busy
        if {$num ne {}} {
            dict set data h $host g $lastgroup m $messages
            set messages {}
            foreach varname {load loadnext num from to} {
                dict set data h $host g $lastgroup $varname [set $varname] 
                set $varname {}
            }
            $w.x.l delete 0 end
            set body [set loadnext [set loaded {}]]
        }
        lassign [$n group $group] num from to
        set load $firstload 
        set loadnext $to
        if {[dict exists $data h $host g $group m]} {
            set messages [dict get $data h $host g $group m]
            foreach varname {load} {
                set $varname [dict get $data h $host g $group $varname]
            }
        }
    }
    set lastgroup $group
    messages $id 
}

sproc messages id {busy from group host load loaded loadnext
    messages n newcolor num seencolor status to w} {
    if {[llength $loaded] >= $load || $loadnext == $from} {
        set status {}
        return
    } 
    set status [list $host $group [list retrieving record $loadnext]]
    if {$loadnext ni $loaded} {
        if {[dict exists $messages $loadnext h]} {
            set head [dict get $messages $loadnext h]
        } elseif {![catch {set head [headfields [$n head $loadnext]]}]} {
            dict set messages $loadnext h $head
        }
        if {[info exists head]} {
            set msgdict [dict get $messages $loadnext]
            $w.x.l insert 0 [
                list $loadnext [dict get $head Date] [
                dict get $head Subject] [dict get $head From]]
            if {[dict exists $messages $loadnext seen] && [
                dict get $messages $loadnext seen] == 1} {
                $w.x.l itemconfigure 0 -foreground $seencolor
            } else {
                $w.x.l itemconfigure 0 -foreground $newcolor
            }
            if {[$w.x.l index active] eq {}} {
                $w.x.l activate 0
            }
            $w.x.l see end
            lappend loaded $loadnext
        }
    }
    incr loadnext -1
    set busy [after idle [list messages $id]]
}

sproc moremessages id {load loaded} {
    set load [+ [llength $loaded] [entier [* [llength $loaded] .25]]]
    messages $id
}

sproc body id {body messages msg msgselection n seencolor w} {
    if {[set msgselection [$w.x.l index active]] ne {}} {
        set msg [lindex [$w.x.l get $msgselection] 0]
        dict set messages $msg seen 1
        $w.x.l itemconfigure $msgselection -foreground $seencolor 
        set body [$n body $msg]
        display $id 
    }
}

sproc nextmessage id {msgselection w} {
    if {$msgselection >= [$w.x.l index end]} return 
    $w.x.l activate [incr msgselection]
    body $id
}

sproc prevmessage id {msgselection w} {
    if {$msgselection == 0} return 
    $w.x.l activate [incr msgselection -1]
    body $id
}

proc cleansubject subject {
    regsub -nocase {^[[:space:]]*re:[[:space:]]*} $subject {}
}


sproc threadmove {id direction} {w group host messages msg msgselection} {
    if {$direction > 0} {
        set last [$w.x.l index end]
    } else {
        set last -1
    }
    set headers [dict get $messages $msg h]
    set subject [cleansubject [dict get $headers Subject]]
    if {[dict exists $headers References]} {
        set related [split [dict get $headers References]]
    }
    set messageid [dict get $headers Message-ID]
    lappend related $messageid

    while {[set newselection [+ $msgselection [incr i $direction]]] != $last} {
        set newmsg [lindex [$w.x.l get $newselection] 0]
        set newheaders [dict get $messages $newmsg h]
        if {[comparereference] || [comparesubject]} {
            $w.x.l activate $newselection
            body $id
            break
        }
    }
}

proc comparesubject {} {
    upvar newheaders newheaders subject subject
    set newsubject [cleansubject [dict get $newheaders Subject]]
    expr {[string first $subject $newsubject] >= 0 || [
        string first $newsubject $subject] >= 0}
}

proc comparereference {} {
    upvar newheaders newheaders related related
    if {[dict exists $newheaders References]} {
        set newreferences [split [dict get $newheaders References]]
    }
    lappend newreferences [dict get $newheaders Message-ID] 
    foreach reference $newreferences {
        if {$reference in $related} {
            return 1
        }
    }
    return 0
}


sproc display id {body fromcolor group host messages msg replycolor
    subjectcolor w} {
    $w.h.t | delete 1.0 end
    foreach {key val} [dict get $messages $msg h] {
        set color [switch $key {
            Subject {lindex $subjectcolor}
            From {lindex $fromcolor}
            default {lindex {}}
        }]
        $w.h.t | insert end $key $color { } {} $val\n
    }
    $w.h.t mark set insert 1.0

    $w.f.t | delete 1.0 end
    foreach line $body {
        $w.f.t | insert end $line\n [
            if {[string first > [string trim $line]] == 0} {
            lindex $replycolor
        }]
    }
    $w.f.t mark set insert 1.0
    focus $w.f.t
}

sproc goback id {winstack} {
    lassign [lrange $winstack end-1 end] prev current
    set winstack [lrange $winstack[set winstack {}] 0 end-2]
    after idle [namespace code [list uiswitch $id $prev]]
}

sproc myexit id {group} {
    set group {}
    group $id
    save $id
    exit 
}

sproc load {id path} {} {
    path $path
    variable data
    set chan [open $path/data]
    close $chan[set data [read $chan]]
}

sproc save id {} {
    variable argv
    variable data
    set path [lindex $argv 0]
    if {![file exists $path]} {
        while {[file exists $path/[set uniq [clock clicks]]]} {} 
        file mkdir $path/$uniq
        rename $path/$uniq $path
        file delete -force $path/$uniq
    }
    set chan [open [lindex $argv 0] w]
    close $chan[puts $chan $data]
}

proc headfields headers {
    foreach header $headers {
        set val [string trim [join [lassign [split $header :] key] :]]
        lappend res $key $val
    }
    return $res
}


proc pforget w {foreach window [winfo children $w] {pack forget $window}}

proc textwrapper w {
    rename $w [set wrapped [info cmdcount]]
    proc $w {arg1 args} [string map [list {{{wrapped}}} [list $wrapped]] {
        if {[string tolower $arg1] eq {|}} {
            return [{{wrapped}} {*}$args]
        }
        switch -exact $arg1 {
            insert - delete - replace {}
            default {
                return [{{wrapped}} $arg1 {*}$args]
            }
        }
    }]
    return $wrapped
}

variable defaults {
    hosts {
        {aioe.cjb.net 119}
        {freenews.netfront.net 119}
        {textnews.news.cambrium.nl 119}
        {news.vsi.ru 119}
        {news.grc.com 119}
        {news.amu.edu.pl 119}
        {news.eternal-september.org 119}
        {news.eternal-september.org 563}
        {nntp.aioe.org 119}
        {reader.albasani.net 119}
    }
    deadhosts {
        {allnews.readfreenews.net 119}
        {dp-news.maxwell.syr.edu 119}
        {freetext.usenetserver.com 119}
        {news.f.de.plusline.net 119}
        {news.readfreenews.net 119}
        {pubnews.gradwell.net 119}
        {w3bhost.de 119}
    }
    group comp.lang.tcl
    host textnews.news.cambrium.nl
    firstload 64 loaded {} 
    fromcolor blue subjectcolor red seencolor gray newcolor blue
    replycolor brown
    sort threads
    displayheaders 1
    winstack myexit
}

variable data {}

bind . <F1> {console show}
wm attributes . -fullscreen 1
#wm geometry . [entier [winfo screenwidth .]]x[entier [winfo screenheight .]]
#wm geometry . 600x[entier [* [winfo screenheight .] .90]]
main $argv