bugfixes

[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

defset errchan #$nick
defset retry_after 900000
defset chan_after 1500
defset chans_retry 3600000
defset debug_reset_after 86400000

defset debugusers {}

# variables
#
#   monitor/$monname(chans)           -> [list $chan1 $chan2 ...]
#   monitor/$monname(ignore)          -> [list $regexp ...]
#   monitor/$monname(prefer)          -> [list $regexp ...]
#   monitor/$monname(present-$chan)   -> [list $lnick ...]
#   monitor/$monname(last-talk)       -> $time_t
#   monitor/$monname(last-talkpref)   -> $time_t
#   monitor/$monname(time-recent)     -> $seconds
#   monitor/$monname(time-recentnow)  -> $seconds
#   monitor/$monname(talkchange)      -> [after ...]    or unset
#
#   deviceset/$username:$lno(monname)  -> $monname
#   deviceset/$username:$lno(group)    -> $led_group
#   deviceset/$username:$lno(username) -> $username
#   deviceset/$username:$lno(values)   -> $valuestring
#   deviceset/$username:$lno(states)   -> [list $state1 $value1 $state2 ...]
#   deviceset/$username:$lno(ochan)    -> [open remoteleds ... | r]  or unset
#   deviceset/$username:$lno(ichan)    -> fifo for remoteleds input  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 ldebug {facil m} {
    global debugusers
    # facil is
    #    m$monname
    #    d$deviceset
    #    c$lchan
    #    {}             for system stuff
    if {![llength $debugusers]} return
    if {[regexp {[mdu]([^:]+)\:} $facil dummy username] &&
        [lsearch -exact $debugusers $username]==-1} return

    regsub {^(.)} $facil {\1 } cc
    reporterr "DEBUG $cc $m"
}    

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 gotchanlist {ch nll} {
    global nick
    if {[lsearch -exact $mm(chans) $ch] == -1} return
    set l {}
    foreach nl $nll {
	if {![string compare $nl [irctolower $nick]]} continue
	if {[mon_nick_is $mm(nopresence) $nl]} continue
	lappend l $nl
    }
    ldebug m$m "$ch names: $l"
    set mm(present-$ch) $l
    mon_updateall $m
}

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 " default "
    foreach ch $mm(chans) {
	if {[llength $mm(present-$ch)]} { append s "present "; break }
    }
    set now [clock seconds]
    set valid_until [expr {$now + 86400}]
    set refresh_later 0
    catch { after cancel $mm(talkchange) }
    foreach p {{} pref} {
	foreach t {{} now} {
	    set vu [expr {$mm(last-talk$p) + $mm(time-recent$t)}]
	    if {$vu < $now} continue
	    append s "${p}talk${t} "
	    set refresh_later 1
	    if {$vu < $valid_until} { set valid_until $vu }
	}
    }
    regsub {^ default } $s { } ss
    set ds [string trim $ss]
    if {$refresh_later} {
	set interval [expr {$valid_until - $now + 2}]
	set ivms [expr {$interval*1000}]
	set mm(talkchange) [after $ivms [list mon_updateall $m]]
	ldebug m$m "until now+${interval}: $ds"
    } else {
	ldebug m$m "indefinitely: $ds"
    }
    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 {} {
    ldebug m$m "destroying"
    catch { after cancel $mm(talkchange) }
    catch { unset mm }
}

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

proc timed_log {m} {
    log "[clock seconds] $m"
}

proc_dset setbystate {s} {
    foreach {sq v} $dd(states) {
	if {![string match *$sq* $s]} continue
	set lv $v; break
    }
    if {![info exists dd(ichan)]} return
    if {![info exists lv]} {
	reporterr "no state for $d matching$s"
	return
    }
    ldebug d$d "matches $sq: $v"
    timed_log "->$d $lv"
    set dd(values) "$sq=$lv"
    puts $dd(ichan) $lv
}

proc_dset destroy {} {
    ldebug d$d "destroying"
    catch { after cancel $dd(retry) }
    catch {
	if {[info exists dd(ochan)]} { timed_log ">\$$d destroy" }
	close $dd(ochan)
	close $dd(ichan)
    }
    catch { unset dd }
}

proc modvar_save_copy {cv defv} {
    upvar 1 m m
    upvar 1 mm mm
    upvar 1 save/$m save
    if {[info exists save($cv)]} {
	set mm($cv) $save($cv)
    } else {
	set mm($cv) $defv
    }
}

proc reloaduser {username} {
    check_username $username
    ldebug u$username "reloading"
    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
	upvar #0 monitor/$m mm
	foreach cv [array names mm] { set save/${m}($cv) $mm($cv) }
    }
    if {![string length $cfg]} {
	file delete 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 {
	ldebug u$username "parsing"
	foreach cv {ignore nopresence prefer} { set cc($cv) {} }
	set cc(time-recentnow) 120
	set cc(time-recent) 450
	set lno 0
	set contin {}
	foreach l [split $cfg "\n"] {
	    incr lno
	    append contin [string trim $l]
	    if {[regsub {\\$} $contin { } contin]} continue
	    set l $contin
	    set contin {}
	    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} {
		    modvar_save_copy last-talk$cv 0
		}
		foreach cv [array names mm(chans)] {
		    modvar_save_copy present-$cv {}
		}
		ldebug m$m "created"
	    } 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 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(values) startup
		set dd(username) $username
		dset_start $d
		ldebug d$d "created"
	    } else {
		error "invalid directive or syntax"
	    }
	}
	if {[string length $contin]} {
	    error "continuation line at end of file"
	}
    } 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)
    ldebug d$d "starting"
    if {[catch {
	set cmdl [list remoteleds --pipe $dd(group) \
		       --human --passfile-only pwdb/p$username]
	timed_log "!-$d [join $cmdl " "]"
	lappend cmdl < pwdb/fifo |& cat
	catch { file delete pwdb/fifo }
	exec mkfifo -m 0600 pwdb/fifo
	set ichan [open pwdb/fifo r+]
	set ochan [open |$cmdl r]
	fconfigure $ichan -blocking 0 -buffering line
	fconfigure $ochan -blocking 0 -buffering line
	set dd(ichan) $ichan
	set dd(ochan) $ochan
	fileevent $ochan readable [list dset_rledout $d]
    } emsg]} {
	reporterr "remoteleds startup $d: $emsg"
	catch { close $ichan }
	catch { close $ochan }
	dset_trylater $d
    }
}

proc_dset rledout {} {
    global errchan
    while {[gets $dd(ochan) l] != -1} {
	reporterr "on $d: $dd(values): $l"
    }
    if {[fblocked $dd(ochan)]} return
    timed_log ">\$$d failure";
    catch { close $dd(ichan) }
    catch { close $dd(ochan) }
    unset dd(ichan)
    unset dd(ochan)
    reporterr "on $d died"
    dset_trylater $d
}

proc_dset trylater {} {
    global retry_after
    ldebug d$d "will try again later"
    set dd(retry) [after $retry_after [list dset_start $d]]
}

proc config_change {} {
    global onchans chans_retry errchan config_retry_after
    ldebug {} "rechecking configuration etc"
    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)
    }
    catch { after cancel $config_retry_after }
    set config_retry_after [after $chans_retry config_change]
}

proc allchans_shortly {} {
    global onchans
    foreach ch [array names onchans] { chan_shortly $ch }
}

proc chan_shortly {ch} {
    global chan_after
    set ch [irctolower $ch]
    upvar #0 onchans($ch) oc
    if {[info exists oc]} {
	manyset $oc status after
	if {"$status" == "shortly"} {
	    ldebug c$ch "queued check already pending"
	    return
	}
    }
    ldebug c$ch "queueing check"
    set oc [list shortly [after $chan_after chan_sendnames $ch]]
}

proc msg_353 {p c dest type chan nicklist} {
    set lchan [irctolower $chan]
    set nll [irctolower $nicklist]
    regsub -all {[=@*]} $nll {} nll
    ldebug c$lchan "all names: $nll"
    foreach m [list_objs monitor] {
	mon_gotchanlist $m $lchan $nll
    }
}

proc chan_sendnames {ch} {
    upvar #0 onchans($ch) oc
    ldebug c$ch "asking for namelist"
    sendout NAMES $ch
    set oc idle
}

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

proc debug_reset {} {
    global debugusers debug_cancelling
    unset debug_cancelling
    set debugusers {}
    reporterr "debug mode timed out"
}

def_ucmd debug {
    prefix_nick
    global debugusers debug_cancelling debug_reset_after
    if {![string length $text]} { error "must give list of usernames" }
    llength $text
    set debugusers $text
    catch { after cancel $debug_cancelling }
    set debug_cancelling [after $debug_reset_after debug_reset]
    reporterr "debug enabled by $n: $debugusers"
}

def_ucmd nodebug {
    prefix_nick
    ta_nomore
    global debugusers debug_cancelling
    set debugusers {}
    catch { after cancel $debug_cancelling }
    catch { unset debug_cancelling }
    reporterr "debug disabled by $n"
}

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"
    }
    ucmdr [join $r "\n"] {}
}

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

proc msg_JOIN {p c chan} { chan_shortly $chan }
proc msg_PART {p c chan} { chan_shortly $chan }
proc msg_KILL {p c user why} { allchans_shortly }
proc msg_QUIT {p c why} { allchans_shortly }
proc msg_NICK {p c newnick} { allchans_shortly }
proc msg_KICK {p c chans users comment} {
    if {[llength $chans] > 1} {
	allchans_shortly
    } else {
	chan_shortly [lindex $chans 0]
    }
}

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