[ircbot] / ledmodule.tcl

# maintains local list of users to userv-slurp config from
# each user provides list of
#    monitors
#    devicesets
#
# a monitor specifies
#    name
#    IRC channel(s)
#    nicks ignore totally
#    nicks ignore presence
#    nicks prefer speech
#    time for `a while ago'
#    time for `very-recently'
# syntax
#    nick ignore|nopresence|prefer <glob-pattern> [...]
#    times <very-recently> <a-while-ago>                  (default 120 450)
#      (affect subsequent `monitor' directives)
#    monitor <monname> <#chan>[,<#chan>...]
#      <monname> must start with <username>:
#
# a deviceset specifies
#    monitor
#    led-group
#    led states
# syntax
#    leds <led-group> <monname> <state>=<value>
# where state is one of
#    [pref]talk[now]  any non-ignored (with `pref', only any preferred)
#                     nick(s) spoke at least somewhat recently
#                     (with `now', only if they spoke very recently)
#    present          at least some non-nopresence nicks present
#    default          always matches
# where the first matching state wins; if none, no LEDs are set

set helpfile ledhelp

source irccore.tcl
source parsecmd.tcl
source stdhelp.tcl

# variables
#
#   monitor/$monname(chans)           -> [list $chan1 $chan2 ...]
#   monitor/$monname(ignore)          -> [list $regexp ...]
#   monitor/$monname(prefer)          -> [list $regexp ...]
#   monitor/$monname(present)         -> [list $lnick ...]
#   monitor/$monname(last-talk)       -> $time_t
#   monitor/$monname(last-talkpref)   -> $time_t
#   monitor/$monname(time-recent)     -> $seconds
#   monitor/$monname(time-recentnow)  -> $seconds
#
#   deviceset/$username:$lno(monname) -> $monname
#   deviceset/$username:$lno(group)   -> $led_group
#   deviceset/$username:$lno(states)  -> [list $state1 $value1 $state2 ...]
#   deviceset/$username:$lno(fchan)   -> [open remoteleds ... |]  or unset
#   deviceset/$username:$lno(retry)   -> [after ... ]             or unset
#
#   onchans($chan)        [list mustleave]                 # in config_chane
#   onchans($chan)        [list idle]
#   onchans($chan)        [list forced]                    # for errchan
#   onchans($chan)        [list shortly [after ...]]       # do a NAMES

proc list_objs {vp} {
    set l {}
    foreach v [info globals] {
        if {![regsub ^$vp/ $v {} v]} continue
        lappend l $v
    }
    return $l
}

proc privmsg_unlogged {prefix ischan params} {
    if {!$ischan} {
        prefix_nick
        execute_usercommand $p PRIVMSG $n $n \
                [lindex $params 0] [lindex $params 1]
        return 0
    }

    foreach m [list_objs monitor] {
        mon_speech $m [irctolower [lindex $params 0]] [irctolower $n]
    }
    return 1;
}

proc reporterr {m} {
    global errchan
    sendprivmsg $errchan $m
}

proc proc_mon {name argl body} {
    proc mon_$name [concat m $argl] "
    upvar #0 monitor/\$m mm
    $body"
}

proc_mon speech {chan ln} {
    if {[search -exact $mm(chans) $chan] == -1} return
    if {[mon_nick_is $mm(ignore) $ln]} return
    set now [clock seconds]
    set mm(last-talk) $now
    if {[mon_nick_is $mm(prefer)]} { set mm(last-talkpref) $now }
    mon_updateall $m
}

proc_mon calcstate {} {
    set s " "
    if {[llength $mm(present)]} { append s "present " }
    set now [clock seconds]
    for p {{} pref} {
        foreach t {{} now} {
            set since [expr {$now - $mm(time-recent$t)}]
            if {[expr {$mm(last-talk$pref) < $since}]} continue
            append s "${p}talk${t} "
        }
    }
    return $s
}

proc_mon updateall {} {
    set s [mon_calcstate $m]
    for d [list_objs deviceset] {
        upvar #0 deviceset/$d dd
        if {[string compare $m $dd(monname)]} continue
        dset_setbystate $s
    }
}

proc_mon destroy {} {
    catch { unset mm }
}

proc proc_dset {name argl body} {
    proc dset_$name [concat d $argl] "
    upvar #0 deviceset/\$d dd
    if {[catch {
        $body
    } emsg]} {
        reporterr \"error on \$d: \$emsg\"
    }"
}

proc_dset setbystate {s} {
    set lv {}
    foreach {sq v} {
        if {![string match *$sq* $s]} continue
        set lv $v; break
    }
    puts $dd(fchan) $lv
}

proc dset_destroy {} {
    catch { after cancel $dd(retry) }
    catch { close $dd(fchan) }
    catch { unset dd }
}

proc reloaduser {username} {
    check_username $username
    if {[catch {
        set cfg [exec userv --timeout 3 $username irc-ledcontrol-config \
                < /dev/null]
        set pw [exec userv --timeout 3 $username irc-ledcontrol-passwords \
                < /dev/null > pwdb/p$username]
    } emsg]} {
        reporterr "error reloading $username: $emsg"
    }
    for d [list_objs deviceset] {
        if {![string match $username:* $d]} continue
        dset_destroy $d
    }
    for m [list_objs monitor] {
        if {![string match $username* $m]} continue
        mon_destroy $m
    }
    if {![string length $cfg]} {
        file remove pwdb/$username
    } elseif {[catch {
        foreach cv {ignore nopresence prefer} { set cc($cv) {} }
        set cc(time-recentnow) 120
        set cc(time-recent) 450
        set pline 0
        foreach l [split $cfg "\n"] {
            incr pline
            set l [string trim $l]
            if {[regexp {^\#} $l]} {
            } elseif {[regexp {^nick\s+(ignore|nopresence|prefer)\s+(\S.*)$} \
                    $l dummy kind globs]} {
                set cc($kind) {}
                foreach gl [split $globs " "] {
                    if {![string length $gl]} continue
                    string match $gl {}
                    lappend cc($kind) $gl
                }
            } elseif {[regexp {^times\s+(\d+)\s+(\d+)$} $l dummy r rnow]} {
                foreach cv {{} now} { set cc(time-recent$cv) [set r$cv] }
            } elseif {[regexp {^monitor\s+(\S+)\s+(\S.*)$} $l dummy m cl]} {
                set cc(chans) {}
                if {![string match $username:* $m]} {
                    error "monname must start with $username:"
                }
                foreach ch [split $cl " "] {
                    if {![string length $ch]} continue
                    check_nick $ch
                    if {![ischan $ch]} { error "invalid channel $ch" }
                    lappend cc(chans) [irctolower $ch]
                }
                upvar #0 monitor/$m mm
                foreach cv [array names cc] { set mm($cv) $cc($cv) }
                foreach cv {{} pref} { set mm(last-talk$cv) 0 }
            } elseif {[regexp \
 {^leds\s+([0-9A-Za-z][-:/0-9A-Za-z]+)\s+(\S+)\s+(\S+.*)$} \
                    $l dummy g m states]} {
                set d $username:$lno:$g
                set sl {}
                foreach sv [split $states " "] {
                    if {![string length $sv]} continue
                    if {![regexp \
 {^((pref)?talk(now)?|present|default)\=([0-9a-z][,/+0-9A-Za-z]*)$} \
                          $sv dummy lhs dummy dummy rhs]} {
                        error "invalid state spec"
                    }
                    lappend sl $lhs $rhs
                }
                upvar #0 deviceset/$d dd
                set dd(monname) $m
                set dd(states) $sl
                set dd(group) $g
                dset_start $d
            }
        }
    } emsg]} {
        reporterr "setup error $username:$pline:$emsg"
    }
}

proc_dset start {} {
    catch { unset dd(retry) }
    if {[catch {
        set fchan [open [list | \
                remoteleds 2>&1 --pipe $g \
                --passfile-only pwdb/p$username \
                |& cat \
                ]]
        fconfigure $fchan -blocking 0
        fileevent $fchan readable [list dset_rledout $d]
        set dd(fchan) $fchan
    } emsg]} {
        reporterr "remoteleds startup $d: $emsg"
        dset_trylater $d
    }
}

proc_dset rledout {} {
    global errchan retry_after
    while {[gets $dd(fchan) l] != -1} { reporterr "remoteleds on $d: $l" }
    if {[fblocked $dd(fchan)]} return
    catch { close $dd(fchan) }
    unset dd(fchan)
    reporterr "remoteleds on $d died"
    dset_trylater $d
}

proc_dset trylater {} {
    set dd(retry) [after $retry_after [list proc_dset start $d]]
}

proc config_change {} {
    global onchans chans_retry errchan
    foreach ch [array names onchans] {
        manyset $onchans($ch) status after
        if {"$status" == "shortly"} {
            catch { after cancel $after }
        }
        set onchans($ch) mustleave
    }
    set ch($errchan) forced
    sendout JOIN $errchan
    foreach m [list_objs monitor] {
        upvar #0 monitor/$m mm
        foreach ch $mm(chans) {
            sendout JOIN $ch
            chan_shortly $ch
        }
    }
    foreach ch [array names onchans] {
        if {"[lindex $onchans($ch) 0]" != "mustleave"} continue
        sendout PART $ch
        unset onchans($ch)
    }
    after $chans_retry config_change
}

proc chan_shortly {ch} {
    global chan_after
    upvar #0 onchans($ch) oc
    manyset $oc status after
    if {"$status" != "idle"} return
    set oc [list shortly [after $chan_after chan_sendnames $ch]]
}

proc chan_sendnames {ch} {
    upvar #0 onchans($ch) oc
    sendout NAMES $ch
    set oc idle
}

def_ucmd reload {} {
    set username [ta_word]
    ta_nomore
    reloaduser $username
    config_change
}

proc connected {
    foreach f [glob -nocomplain pwdb/p*] {
        regexp {^pwdb/p(.*)$} $f dummy username
        check_username $username
        reloaduser $username
    }
    config_change
}

# fixme
# 353
# JOIN PART
# KICK KILL QUIT