[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
source userv.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(username) -> $username
#   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 {p ischan params} {
    global errorInfo
    if {!$ischan} { return 0 }

    # on-channel message
    if {[catch {
        prefix_nick
        foreach m [list_objs monitor] {
            mon_speech $m [irctolower [lindex $params 0]] [irctolower $n]
        }
    } emsg]} {
        log "processing error: $emsg\n$errorInfo"
    }
    return 1;
}

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

proc msg_PRIVMSG {p c dest text} {
    global errchan
    prefix_nick
    execute_usercommand $p $c $n $errchan $dest $text
}

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

proc mon_nick_is {globlist ln} {
    foreach gl $globlist {
        if {[string match $gl $ln]} { return 1 }
    }
    return 0
}

proc_mon speech {chan ln} {
    if {[lsearch -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) $ln]} { set mm(last-talkpref) $now }
    mon_updateall $m
}

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

proc_mon updateall {} {
    set s [mon_calcstate $m]
    foreach d [list_objs deviceset] {
        upvar #0 deviceset/$d dd
        if {[string compare $m $dd(monname)]} continue
        dset_setbystate $d $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 timed_log {m} {
    log "[clock seconds] $m"
}

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

proc_dset destroy {} {
    catch { after cancel $dd(retry) }
    catch {
        if {[info exists dd(fchan)]} { timed_log ">\$$d destroy" }
        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]
    } emsg]} {
        regsub "\n" $emsg " // " emsg
        reporterr "error reloading $username: $emsg"
        return ""
    }
    foreach d [list_objs deviceset] {
        if {![string match $username:* $d]} continue
        dset_destroy $d
    }
    foreach m [list_objs monitor] {
        if {![string match $username* $m]} continue
        mon_destroy $m
    }
    if {![string length $cfg]} {
        file remove pwdb/$username
        return "no config from $username"
    } elseif {[catch {
        exec userv --timeout 3 $username irc-ledcontrol-passwords \
                < /dev/null > pwdb/p$username
    } emsg]} {
        reporterr "error reading passwords for $username: $emsg"
        return ""
    } elseif {[catch {
        foreach cv {ignore nopresence prefer} { set cc($cv) {} }
        set cc(time-recentnow) 120
        set cc(time-recent) 450
        set lno 0
        foreach l [split $cfg "\n"] {
            incr lno
            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:"
                }
                check_monname $m
                foreach ch [split $cl " "] {
                    if {![string length $ch]} continue
                    check_chan $ch
                    if {![ischan $ch]} { error "invalid channel $ch" }
                    lappend cc(chans) [irctolower $ch]
                    chan_shortly $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 }
                set mm(present) {}
            } 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 {}
                check_monname $m
                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
                set dd(username) $username
                dset_start $d
            }
        }
    } emsg]} {
        reporterr "setup error $username:$lno:$emsg"
        return ""
    } else {
        return "reloaded $username"
    }
}

proc check_monname {m} {
    if {[regexp {[^-_+:.#0-9a-zA-Z]} $m badchar]} {
        error "char $badchar not allowed in monnames"
    }
    if {![regexp {^[0-9a-zA-Z]} $m]} {
        error "monname must start with alphanum"
    }
}

proc_dset start {} {
    catch { unset dd(retry) }
    set username $dd(username)
    if {[catch {
        set cmdl [list remoteleds --pipe $dd(group) \
                       --passfile-only pwdb/p$username]
        timed_log "!-$d [join $cmdl " "]"
        set fchan [open |[concat $cmdl {|& cat}] r+]
        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
    while {[gets $dd(fchan) l] != -1} { reporterr "remoteleds on $d: $l" }
    if {[fblocked $dd(fchan)]} return
    catch {
        timed_log ">\$$d failure";
        close $dd(fchan)
    }
    unset dd(fchan)
    reporterr "remoteleds on $d died"
    dset_trylater $d
}

proc_dset trylater {} {
    global retry_after
    set dd(retry) [after $retry_after [list 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
    }
    sendout JOIN $errchan
    chan_shortly $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
    if {[info exists oc]} {
        manyset $oc status after
        if {"$status" == "shortly"} 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
    set m [reloaduser $username]
    config_change
    ucmdr {} $m
}

def_ucmd who {
    set r {}
    foreach m [list_objs monitor] {
        upvar #0 monitor/$m mm
        lappend r "monitoring $mm(chans) for $m"
    }
    foreach d [list_objs deviceset] {
        upvar #0 deviceset/$d dd
        regexp {^[^:]*\:[^:]*} $dd(group) dest
        lappend r "sending $dd(monname) to $dest"
    }
}

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

# fixme
# 353
# JOIN PART
# KICK KILL QUIT

if {[catch {
    loadhelp
    ensure_connecting
} emsg]} {
    fail "startup: $emsg"
}