X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ijackson/git?a=blobdiff_plain;f=ledmodule.tcl;h=b4a20fd858b890e3eddc1073c7733fe8cc517ec6;hb=HEAD;hp=90bc013fa62a447f4b6758a79d513177403a364c;hpb=30eceb6293c9f0bbb905e21925d91b203f07047b;p=ircbot.git

diff --git a/ledmodule.tcl b/ledmodule.tcl
index 90bc013..b4a20fd 100644
--- a/ledmodule.tcl
+++ b/ledmodule.tcl
@@ -1,65 +1,62 @@
-# 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
+# see ledbot.html
+# $Id$
 
 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)         -> [list $lnick ...]
+#   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(states)  -> [list $state1 $value1 $state2 ...]
-#   deviceset/$username:$lno(fchan)   -> [open remoteleds ... |]  or unset
-#   deviceset/$username:$lno(retry)   -> [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] {
@@ -69,16 +66,18 @@ proc list_objs {vp} {
     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
-    }
+proc privmsg_unlogged {p ischan params} {
+    global errorInfo
+    if {!$ischan} { return 0 }
 
-    foreach m [list_objs monitor] {
-	mon_speech $m [irctolower [lindex $params 0]] [irctolower $n]
+    # 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;
 }
@@ -88,136 +87,240 @@ proc reporterr {m} {
     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
+	if {[mon_nick_is $mm(ignore) $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 {[search -exact $mm(chans) $chan] == -1} return
+    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)]} { set mm(last-talkpref) $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 s " default "
+    foreach ch $mm(chans) {
+	if {[llength $mm(present-$ch)]} { append s "present "; break }
+    }
     set now [clock seconds]
-    for p {{} pref} {
+    set valid_until [expr {$now + 86400}]
+    set refresh_later 0
+    catch { after cancel $mm(talkchange) }
+    foreach p {{} pref} {
 	foreach t {{} now} {
-	    set since [expr {$now - $mm(time-recent$t)}]
-	    if {[expr {$mm(last-talk$pref) < $since}]} continue
+	    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]
-    for d [list_objs deviceset] {
+    foreach d [list_objs deviceset] {
 	upvar #0 deviceset/$d dd
 	if {[string compare $m $dd(monname)]} continue
-	dset_setbystate $s
+	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 {
+    set returncode \[catch {
         $body
-    } emsg]} {
+    } emsg\]
+    global errorInfo errorCode
+    if {\$returncode==1} {
 	reporterr \"error on \$d: \$emsg\"
+    } elseif {\$returncode==2} {
+	return \$emsg
+    } else {
+	return -code \$returncode -errorinfo \$errorInfo -errorcode \$errorCode
     }"
 }
 
+proc timed_log {m} {
+    log "[clock seconds] $m"
+}
+
 proc_dset setbystate {s} {
-    set lv {}
-    foreach {sq v} {
+    foreach {sq v} $dd(states) {
 	if {![string match *$sq* $s]} continue
 	set lv $v; break
     }
-    puts $dd(fchan) $lv
+    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 {} {
+proc_dset destroy {} {
+    ldebug d$d "destroying"
     catch { after cancel $dd(retry) }
-    catch { close $dd(fchan) }
+    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]
-	set pw [exec userv --timeout 3 $username irc-ledcontrol-passwords \
-		< /dev/null > pwdb/p$username]
     } emsg]} {
+	regsub "\n" $emsg " // " emsg
 	reporterr "error reloading $username: $emsg"
+	return ""
     }
-    for d [list_objs deviceset] {
+    foreach d [list_objs deviceset] {
 	if {![string match $username:* $d]} continue
 	dset_destroy $d
     }
-    for m [list_objs monitor] {
+    foreach m [list_objs monitor] {
 	if {![string match $username* $m]} continue
-	mon_destroy $m
+	upvar #0 monitor/$m mm
+	foreach cv [array names mm] { set save/${m}($cv) $mm($cv) }
     }
     if {![string length $cfg]} {
-	file remove pwdb/$username
+	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 pline 0
+	set lno 0
+	set contin {}
 	foreach l [split $cfg "\n"] {
-	    incr pline
-	    set l [string trim $l]
+	    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]} {
+	    } elseif {![regexp {\S} $l]} {
+	    } elseif {[regexp {^nick\s+(ignore|nopresence|prefer)\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]} {
+	    } elseif {[regexp {^times\s+(\d+)\s+(\d+)$} $l dummy rnow r]} {
 		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_nick $ch
+		    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 }
+		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+.*)$} \
+ {^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]} {
+ {^((?:pref)?talk(?:now)?|present|default)\=([0-9a-z][,/+0-9A-Za-z]*)$} \
+                          $sv dummy lhs rhs]} {
 		        error "invalid state spec"
 		    }
 		    lappend sl $lhs $rhs
@@ -226,47 +329,84 @@ proc reloaduser {username} {
 		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:$pline:$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 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
+	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 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"
+    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 {} {
-    set dd(retry) [after $retry_after [list proc_dset start $d]]
+    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
+    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"} {
@@ -274,8 +414,8 @@ proc config_change {} {
 	}
 	set onchans($ch) mustleave
     }
-    set ch($errchan) forced
     sendout JOIN $errchan
+    chan_shortly $errchan
     foreach m [list_objs monitor] {
 	upvar #0 monitor/$m mm
 	foreach ch $mm(chans) {
@@ -288,40 +428,154 @@ proc config_change {} {
 	sendout PART $ch
 	unset onchans($ch)
     }
-    after $chans_retry config_change
+    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
-    manyset $oc status after
-    if {"$status" != "idle"} return
+    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 {} {
+def_ucmd reload {
     set username [ta_word]
     ta_nomore
-    reloaduser $username
+    set m [reloaduser $username]
     config_change
+    ucmdr {} $m
 }
 
-proc connected {
+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"
+}
+
+proc_dset visibledest {} {
+    regsub {\:[^:]*/} $d/ { } p
+    regsub {^([^:]+)\:\d+\:} $p {\1, } p
+    regsub { $} $p {} p
+    return $p
+}
+
+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
+	set m $dd(monname)
+	upvar #0 monitor/$m mm
+	if {![info exists mm(chans)]} continue
+	lappend r "sending $m to [dset_visibledest $d]"
+    }
+    ucmdr [join $r "\n"] {}
+}
+
+proc connected {} {
+    ldebug {} "connected"
     foreach f [glob -nocomplain pwdb/p*] {
 	regexp {^pwdb/p(.*)$} $f dummy username
-	check_username $username
-	reloaduser $username
+	set m [reloaduser $username]
     }
     config_change
 }
 
-# fixme
-# 353
-# JOIN PART
-# KICK KILL QUIT
+proc warn_pref {n} {
+    set nl [irctolower $n]
+    set l {}
+    foreach d [list_objs deviceset] {
+	upvar #0 deviceset/$d dd
+	set m $dd(monname)
+	upvar #0 monitor/$m mm
+	if {![info exists mm(prefer)]} continue
+	if {![mon_nick_is $mm(prefer) $nl]} continue
+	foreach ch $mm(chans) { set wch($ch) 1 }
+	lappend l [dset_visibledest $d]
+    }
+    if {[llength $l]} {
+	sendprivmsg $nl "LEDs are watching you on [\
+		join [lsort [array names wch]] ","]: [join $l " "]"
+    }
+}
+
+proc msg_JOIN {p c chan} {
+    prefix_nick
+    set nl [irctolower $n]
+    chan_shortly $chan
+    warn_pref $n
+}
+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; warn_pref $newnick }
+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"
+}