#! /bin/env tclsh

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

proc object id {
    if {[string first :: $id] != 0} {
        set id [string trimright [uplevel namespace current] :]::$id
    }
    namespace eval $id {
        namespace ensemble create
        namespace export -clear
        namespace ensemble configure [namespace current] -unknown [
            list apply [list args {
                return [lindex $args 0]::[lindex $args 1]
            } [namespace current]]
        ]
    }
    namespace eval $id [list namespace import [namespace current]::*]
    return $id
}

proc method {name argspec attributes body} {
    set script [string map [list {{{attributes}}} [list $attributes]] {
        set id [namespace qualifiers [lindex [info level 0] 0]]
        foreach varname [set attributes {{attributes}}] {
            upvar 0 ${id}::$varname $varname
        }
    }]
    proc $name $argspec $script$body
}

proc reader args {
    if {[llength $args]} {
        set args [lassign $args id]
    } else {
        set id [info cmdcount]
    }
    object $id
}

method init {defaults args} {busy deadhosts data displayheaders firstload 
    lbwidth msgfirst msglast fromcolor group host hosts lastgroup lasthost load
    loaded messages n num username path password newcolor seencolor
    replycolor status subjectcolor w winstack} {
    dict with defaults {dict with args {}}
    set busy [set lastgroup [set lasthost [set messages [set status {}]]]]
    set msgfirst [set msglast [set num {}]]
    if {[info exists path] && [file exists $path/data]} {
        $id load
        if {[dict exists $data defaults]} {
            set saveddefaults [dict get $data defaults]
            dict with saveddefaults {}
        }
    }
    set load $firstload
}

method ui {} {fromcolor replycolor group host hosts subjectcolor w} {
    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 bold \n\n}
        {{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}
        {{n {new post}} {} \n}
        {{m {load more post}} {} \n\n}
        {{Message Keys:} bold \n\n}
        {{h {view headers}} {} \n} 
        {{n {next post}} {} \n}
        {{N {next thread}} {} \n}
        {{p {previous post}} {} \n}
        {{P {previous thread}} {} \n}
        {{b {backward in thread}} {} \n}
        {{B {beginning of thread}} {} \n}
        {{f {forward in thread}} {} \n}
        {{F {end of thread}} {} \n}
        {{Post Keys:} bold \n\n}
        {s {send} {} \n}
    } {
        $w.intro.msg insert end {*}$phrase
    }
    $w.intro.msg mark set insert 1.0
    $w.intro.msg tag configure bold -font bold
    $id keys_common $w.intro.msg 
    bind $w.intro.msg <Return> [list $id uiswitch ui_hosts]
    textwrapper $w.intro.msg

    listbox [frame [frame $w.hosts].listf].l
    $id lbconfig $w.hosts.listf.l $hosts $host [list $id hosts_entry_update]
    scrolled $w.hosts.listf.l y
    $id keys_common $w.hosts.listf.l
    entry $w.hosts.entry -textvar ${id}::host
    $id keys_common $w.hosts.entry
    foreach sequence {<Double-Button-1> <Return>} {
        bind $w.hosts.entry $sequence [
            namespace code [list uiswitch $id ui_authentication]]
    }

    labelentry [frame [frame $w.authentication].username] username \
        ${id}::username [list <Return> [list $id connect]]
    $id keys_common $w.authentication.username.entry
    labelentry [frame $w.authentication.password] \
        password ${id}::password [list <Return> [list $id connect]]
    $id keys_common $w.authentication.password.entry
    $w.authentication.password.entry configure -show *

    set groupsmsg {{double-click to load groups}}
    scrolled [$id lbconfig [listbox [frame [frame $w.groups].listf].l] \
        $groupsmsg $group [list $id getgroups]] y
    $id keys_common $w.groups.listf.l
    $w.groups.listf.l configure -width [string length $groupsmsg]
    entry $w.groups.entry -textvariable ${id}::group
    bind $w.groups.entry <Return> [list $id uiswitch ui_group]
    $id keys_common $w.groups.entry

    scrolled [$id lbconfig [listbox [frame $w.x].l] {} {} [
        list $id uiswitch ui_message]] y
    $id keys_common $w.x.l
    bind $w.x.l m [list $id moremessages] 
    bind $w.x.l n [list $id uiswitch ui_post] 

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

    scrolled [text [frame $w.f].t {*}$textopts] y
    textwrapper $w.f.t
    foreach color [list $fromcolor $replycolor $subjectcolor] {
        $w.f.t tag configure $color -foreground $color
    }
    $id keys_common $w.f.t
    bind $w.f.t h [list $id ui_header]
    bind $w.f.t n [list $id nextmessage] 
    bind $w.f.t p [list $id prevmessage] 
    bind $w.f.t b [list $id threadmove back] 
    bind $w.f.t f [list $id threadmove forward] 
    bind $w.f.t B [list $id threadmove first] 
    bind $w.f.t F [list $id threadmove last] 
    bind $w.f.t N [list $id threadmove next] 
    bind $w.f.t P [list $id threadmove prev] 

    scrolled [text [frame $w.post].text] y
    bind $w.post.text s [list $id send]
    
    scrolled [$id lbconfig [listbox [frame [frame $w.settings].listf].l] {
        from
    } {} [list $id uiswitch ui_setting]] y

    labelentry [frame $w.setting] {} ${id}::setting [
        list $id update_setting]

    label $w.status -textvariable ${id}::status
    $id uiswitch ui_intro
}

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

method ui_intro {} {w winstack} {
    pack $w.intro {*}[winfo children $w.intro] -fill both -expand 1
    selection own $w.intro
    focus $w.intro.msg
}

method ui_hosts {} {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
}

method ui_authentication {} {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
}

method ui_groups {} 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
    }
}

method ui_group {} 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
    $id group
}

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

method ui_message {} {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
    $id body
    $id display
}

method ui_post {} {w} {
    pack $w.post $w.post.text -fill both -expand 1
}

method ui_setting {} {} {
    pack $w.setting.entry
}

method ui_settings {} {} {
    pack $w.settings $w.settings.lisft -fill y -expand 1
    pack $w.settings.listf.y -fill y -side right
    pack $w.settings.listf.l -fill y -expand 1
}

method connect {} {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 {}
    $id uiswitch ui_groups
}

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

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

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

method getgroups2 {} {lbwidth n status w} {
    set max $lbwidth
    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 $id groups_entry_update]
    }
    set status {}
}

method group {} {body busy data firstload group lastgroup host lasthost
    load loaded loadnext messages msgfirst msglast n num w} {
    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 msgfirst msglast} {
                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 msgfirst msglast
        set load $firstload 
        set loadnext $msglast
        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
    $id messages
}

method messages {} {busy group host load loaded loadnext messages n 
    msgfirst msglast newcolor num seencolor status w} {
    if {[llength $loaded] >= $load || $loadnext == $msgfirst} {
        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 $id messages]]
}

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

method body {} {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]
    }
}

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

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

#forward back next prev first last
method threadmove mode {w group host messages msg msgselection} {
    switch $mode {
        forward - next - last {
            set direction 1
            set last [$w.x.l index end]
        }
        back - prev - first {
            set direction -1
            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

    set found 0
    while {[set newselection [+ $msgselection [incr i $direction]]] != $last} {
        set newmsg [lindex [$w.x.l get $newselection] 0]
        set newheaders [dict get $messages $newmsg h]
        switch $mode {
            forward - back {
                if {[comparereference] || [comparesubject]} {
                    set found 1
                    break
                }
            }
            next - prev - first - last {
                if {![comparereference] && ![comparesubject]} {
                    switch $mode {
                        next {
                            set found 1
                            break
                        }
                        prev {
                            $w.x.l activate $newselection 
                            $id body
                            tailcall $id threadmove first
                        }
                        first - last {
                            set found 1
                            incr newselection [* $direction -1]
                            break
                        }
                    }
                }
                continue
            }
        }
    }
    if {$found} {
        $w.x.l activate $newselection
        $id ui_message
    }
}

method display {} {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
}

method goback {} winstack {
    lassign [lrange $winstack end-1 end] prev current
    puts "yuck: .. $prev"
    set winstack [lrange $winstack[set winstack {}] 0 end-2]
    after idle [namespace code [list $id uiswitch $prev]]
}

method keys_common w {} {
    #these may be set on an entry widget, so are limited to non-entry keys
    bind $w <Escape> [namespace code [list $id goback]]
    bind $w <Control-`> [namespace code [list uiswitch ui_settings]]
    return $w
}

proc labelentry {parent labeltext textvar bindings} {
    label $parent.label -text $labeltext
    entry $parent.entry -textvariable $textvar
    foreach {event action} $bindings {
        bind $parent.entry $event $action
    }
}


method load {} {data path} {
    set chan [open $path/data]
    set data [read $chan]
    close $chan
}

method myexit {} {group n path} {
    if {[info exists n]} {
        set group {}
        $id group
    }
    if {[info exists path]} {
        $id save
    }
    exit 
}

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

method send {} {n w} {
    set body [$w.post.text get]
    set token [::mime::initialize -canonical text/plain]
    ::mime::setheader $token
}


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

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
}

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

method lbconfig {path data activated updater} {lbwidth} {
    set max $lbwidth
    foreach data1 $data {
        $path insert end $data1
        set max [max [string length $data1] $max]
        if {$activated eq $data1} {
            $path activate end
        }
    }
    $path configure -width $max
    foreach sequence {<Double-Button-1> <Return>} {
        bind $path $sequence [namespace code $updater]
    }
    return $path
}

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

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

proc scrolled {widget dim} {
    set parent [winfo parent $widget]
    foreach dim1 $dim {
        scrollbar $parent.$dim1 -command [list $widget yview]
        $widget configure -${dim1}scrollc [list $parent.$dim1 set]
    }
    return $widget
}

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 {
        {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 {
        {aioe.cjb.net 119}
        {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
    lbwidth 20
    replycolor brown
    sort threads
    displayheaders 1
    winstack myexit
}

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