-# 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] {
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;
}
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
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"} {
}
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) {
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"
+}
~ijackson / ircbot.git / blobdiff