1 # maintains local list of users to userv-slurp config from
2 # each user provides list of
10 # nicks ignore presence
12 # time for `a while ago'
13 # time for `very-recently'
15 # nick ignore|nopresence|prefer <glob-pattern> [...]
16 # times <very-recently> <a-while-ago> (default 120 450)
17 # (affect subsequent `monitor' directives)
18 # monitor <monname> <#chan>[,<#chan>...]
19 # <monname> must start with <username>:
21 # a deviceset specifies
26 # leds <led-group> <monname> <state>=<value>
27 # where state is one of
28 # [pref]talk[now] any non-ignored (with `pref', only any preferred)
29 # nick(s) spoke at least somewhat recently
30 # (with `now', only if they spoke very recently)
31 # present at least some non-nopresence nicks present
32 # default always matches
33 # where the first matching state wins; if none, no LEDs are set
43 defset retry_after 900000
44 defset chan_after 1500
45 defset chans_retry 3600000
46 defset debug_reset_after 86400000
52 # monitor/$monname(chans) -> [list $chan1 $chan2 ...]
53 # monitor/$monname(ignore) -> [list $regexp ...]
54 # monitor/$monname(prefer) -> [list $regexp ...]
55 # monitor/$monname(present-$chan) -> [list $lnick ...]
56 # monitor/$monname(last-talk) -> $time_t
57 # monitor/$monname(last-talkpref) -> $time_t
58 # monitor/$monname(time-recent) -> $seconds
59 # monitor/$monname(time-recentnow) -> $seconds
60 # monitor/$monname(talkchange) -> [after ...] or unset
62 # deviceset/$username:$lno(monname) -> $monname
63 # deviceset/$username:$lno(group) -> $led_group
64 # deviceset/$username:$lno(username) -> $username
65 # deviceset/$username:$lno(values) -> $valuestring
66 # deviceset/$username:$lno(states) -> [list $state1 $value1 $state2 ...]
67 # deviceset/$username:$lno(ochan) -> [open remoteleds ... | r] or unset
68 # deviceset/$username:$lno(ichan) -> fifo for remoteleds input or unset
69 # deviceset/$username:$lno(retry) -> [after ... ] or unset
71 # onchans($chan) [list mustleave] # in config_chane
72 # onchans($chan) [list idle]
73 # onchans($chan) [list forced] # for errchan
74 # onchans($chan) [list shortly [after ...]] # do a NAMES
76 proc ldebug {facil m} {
83 if {![llength $debugusers]} return
84 if {[regexp {[mdu]([^:]+)\:} $facil dummy username] &&
85 [lsearch -exact $debugusers $username]==-1} return
87 regsub {^(.)} $facil {\1 } cc
88 reporterr "DEBUG $cc $m"
93 foreach v [info globals] {
94 if {![regsub ^$vp/ $v {} v]} continue
100 proc privmsg_unlogged {p ischan params} {
102 if {!$ischan} { return 0 }
107 foreach m [list_objs monitor] {
108 mon_speech $m [irctolower [lindex $params 0]] [irctolower $n]
111 log "processing error: $emsg\n$errorInfo"
118 sendprivmsg $errchan $m
121 proc msg_PRIVMSG {p c dest text} {
124 execute_usercommand $p $c $n $errchan $dest $text
127 proc proc_mon {name argl body} {
128 proc mon_$name [concat m $argl] "
129 upvar #0 monitor/\$m mm
133 proc mon_nick_is {globlist ln} {
134 foreach gl $globlist {
135 if {[string match $gl $ln]} { return 1 }
140 proc_mon gotchanlist {ch nll} {
142 if {[lsearch -exact $mm(chans) $ch] == -1} return
145 if {![string compare $nl [irctolower $nick]]} continue
146 if {[mon_nick_is $mm(nopresence) $nl]} continue
147 if {[mon_nick_is $mm(ignore) $nl]} continue
150 ldebug m$m "$ch names: $l"
151 set mm(present-$ch) $l
155 proc_mon speech {chan ln} {
156 if {[lsearch -exact $mm(chans) $chan] == -1} return
157 if {[mon_nick_is $mm(ignore) $ln]} return
158 set now [clock seconds]
159 set mm(last-talk) $now
160 if {[mon_nick_is $mm(prefer) $ln]} { set mm(last-talkpref) $now }
164 proc_mon calcstate {} {
166 foreach ch $mm(chans) {
167 if {[llength $mm(present-$ch)]} { append s "present "; break }
169 set now [clock seconds]
170 set valid_until [expr {$now + 86400}]
172 catch { after cancel $mm(talkchange) }
173 foreach p {{} pref} {
175 set vu [expr {$mm(last-talk$p) + $mm(time-recent$t)}]
176 if {$vu < $now} continue
177 append s "${p}talk${t} "
179 if {$vu < $valid_until} { set valid_until $vu }
182 regsub {^ default } $s { } ss
183 set ds [string trim $ss]
184 if {$refresh_later} {
185 set interval [expr {$valid_until - $now + 2}]
186 set ivms [expr {$interval*1000}]
187 set mm(talkchange) [after $ivms [list mon_updateall $m]]
188 ldebug m$m "until now+${interval}: $ds"
190 ldebug m$m "indefinitely: $ds"
195 proc_mon updateall {} {
196 set s [mon_calcstate $m]
197 foreach d [list_objs deviceset] {
198 upvar #0 deviceset/$d dd
199 if {[string compare $m $dd(monname)]} continue
200 dset_setbystate $d $s
204 proc_mon destroy {} {
205 ldebug m$m "destroying"
206 catch { after cancel $mm(talkchange) }
210 proc proc_dset {name argl body} {
211 proc dset_$name [concat d $argl] "
212 upvar #0 deviceset/\$d dd
213 set returncode \[catch {
216 global errorInfo errorCode
217 if {\$returncode==1} {
218 reporterr \"error on \$d: \$emsg\"
219 } elseif {\$returncode==2} {
222 return -code \$returncode -errorinfo \$errorInfo -errorcode \$errorCode
227 log "[clock seconds] $m"
230 proc_dset setbystate {s} {
231 foreach {sq v} $dd(states) {
232 if {![string match *$sq* $s]} continue
235 if {![info exists dd(ichan)]} return
236 if {![info exists lv]} {
237 reporterr "no state for $d matching$s"
240 ldebug d$d "matches $sq: $v"
242 set dd(values) "$sq=$lv"
246 proc_dset destroy {} {
247 ldebug d$d "destroying"
248 catch { after cancel $dd(retry) }
250 if {[info exists dd(ochan)]} { timed_log ">\$$d destroy" }
257 proc modvar_save_copy {cv defv} {
261 if {[info exists save($cv)]} {
262 set mm($cv) $save($cv)
268 proc reloaduser {username} {
269 check_username $username
270 ldebug u$username "reloading"
272 set cfg [exec userv --timeout 3 $username irc-ledcontrol-config \
275 regsub "\n" $emsg " // " emsg
276 reporterr "error reloading $username: $emsg"
279 foreach d [list_objs deviceset] {
280 if {![string match $username:* $d]} continue
283 foreach m [list_objs monitor] {
284 if {![string match $username* $m]} continue
285 upvar #0 monitor/$m mm
286 foreach cv [array names mm] { set save/${m}($cv) $mm($cv) }
288 if {![string length $cfg]} {
289 file delete pwdb/$username
290 return "no config from $username"
292 exec userv --timeout 3 $username irc-ledcontrol-passwords \
293 < /dev/null > pwdb/p$username
295 reporterr "error reading passwords for $username: $emsg"
298 ldebug u$username "parsing"
299 foreach cv {ignore nopresence prefer} { set cc($cv) {} }
300 set cc(time-recentnow) 120
301 set cc(time-recent) 450
304 foreach l [split $cfg "\n"] {
306 append contin [string trim $l]
307 if {[regsub {\\$} $contin { } contin]} continue
310 if {[regexp {^\#} $l]} {
311 } elseif {![regexp {\S} $l]} {
312 } elseif {[regexp {^nick\s+(ignore|nopresence|prefer)\s+(.*)$} \
313 "$l " dummy kind globs]} {
315 foreach gl [split $globs " "] {
316 if {![string length $gl]} continue
318 lappend cc($kind) $gl
320 } elseif {[regexp {^times\s+(\d+)\s+(\d+)$} $l dummy r rnow]} {
321 foreach cv {{} now} { set cc(time-recent$cv) [set r$cv] }
322 } elseif {[regexp {^monitor\s+(\S+)\s+(\S.*)$} $l dummy m cl]} {
324 if {![string match $username:* $m]} {
325 error "monname must start with $username:"
328 foreach ch [split $cl " "] {
329 if {![string length $ch]} continue
331 if {![ischan $ch]} { error "invalid channel $ch" }
332 lappend cc(chans) [irctolower $ch]
335 upvar #0 monitor/$m mm
336 foreach cv [array names cc] { set mm($cv) $cc($cv) }
337 foreach cv {{} pref} {
338 modvar_save_copy last-talk$cv 0
340 foreach cv [array names mm(chans)] {
341 modvar_save_copy present-$cv {}
345 {^leds\s+([0-9A-Za-z][-.:/0-9A-Za-z]+)\s+(\S+)\s+(\S+.*)$} \
346 $l dummy g m states]} {
347 set d $username:$lno:$g
350 foreach sv [split $states " "] {
351 if {![string length $sv]} continue
353 {^((?:pref)?talk(?:now)?|present|default)\=([0-9a-z][,/+0-9A-Za-z]*)$} \
354 $sv dummy lhs rhs]} {
355 error "invalid state spec"
359 upvar #0 deviceset/$d dd
363 set dd(values) startup
364 set dd(username) $username
368 error "invalid directive or syntax"
371 if {[string length $contin]} {
372 error "continuation line at end of file"
375 reporterr "setup error $username:$lno:$emsg"
378 return "reloaded $username"
382 proc check_monname {m} {
383 if {[regexp {[^-_+:.#0-9a-zA-Z]} $m badchar]} {
384 error "char $badchar not allowed in monnames"
386 if {![regexp {^[0-9a-zA-Z]} $m]} {
387 error "monname must start with alphanum"
392 catch { unset dd(retry) }
393 set username $dd(username)
394 ldebug d$d "starting"
396 set cmdl [list remoteleds --pipe $dd(group) \
397 --human --passfile-only pwdb/p$username]
398 timed_log "!-$d [join $cmdl " "]"
399 lappend cmdl < pwdb/fifo |& cat
400 catch { file delete pwdb/fifo }
401 exec mkfifo -m 0600 pwdb/fifo
402 set ichan [open pwdb/fifo r+]
403 set ochan [open |$cmdl r]
404 fconfigure $ichan -blocking 0 -buffering line
405 fconfigure $ochan -blocking 0 -buffering line
408 fileevent $ochan readable [list dset_rledout $d]
410 reporterr "remoteleds startup $d: $emsg"
411 catch { close $ichan }
412 catch { close $ochan }
417 proc_dset rledout {} {
419 while {[gets $dd(ochan) l] != -1} {
420 reporterr "on $d: $dd(values): $l"
422 if {[fblocked $dd(ochan)]} return
423 timed_log ">\$$d failure";
424 catch { close $dd(ichan) }
425 catch { close $dd(ochan) }
428 reporterr "on $d died"
432 proc_dset trylater {} {
434 ldebug d$d "will try again later"
435 set dd(retry) [after $retry_after [list dset_start $d]]
438 proc config_change {} {
439 global onchans chans_retry errchan config_retry_after
440 ldebug {} "rechecking configuration etc"
441 foreach ch [array names onchans] {
442 manyset $onchans($ch) status after
443 if {"$status" == "shortly"} {
444 catch { after cancel $after }
446 set onchans($ch) mustleave
448 sendout JOIN $errchan
449 chan_shortly $errchan
450 foreach m [list_objs monitor] {
451 upvar #0 monitor/$m mm
452 foreach ch $mm(chans) {
457 foreach ch [array names onchans] {
458 if {"[lindex $onchans($ch) 0]" != "mustleave"} continue
462 catch { after cancel $config_retry_after }
463 set config_retry_after [after $chans_retry config_change]
466 proc allchans_shortly {} {
468 foreach ch [array names onchans] { chan_shortly $ch }
471 proc chan_shortly {ch} {
473 set ch [irctolower $ch]
474 upvar #0 onchans($ch) oc
475 if {[info exists oc]} {
476 manyset $oc status after
477 if {"$status" == "shortly"} {
478 ldebug c$ch "queued check already pending"
482 ldebug c$ch "queueing check"
483 set oc [list shortly [after $chan_after chan_sendnames $ch]]
486 proc msg_353 {p c dest type chan nicklist} {
487 set lchan [irctolower $chan]
488 set nll [irctolower $nicklist]
489 regsub -all {[=@*]} $nll {} nll
490 ldebug c$lchan "all names: $nll"
491 foreach m [list_objs monitor] {
492 mon_gotchanlist $m $lchan $nll
496 proc chan_sendnames {ch} {
497 upvar #0 onchans($ch) oc
498 ldebug c$ch "asking for namelist"
504 set username [ta_word]
506 set m [reloaduser $username]
511 proc debug_reset {} {
512 global debugusers debug_cancelling
513 unset debug_cancelling
515 reporterr "debug mode timed out"
520 global debugusers debug_cancelling debug_reset_after
521 if {![string length $text]} { error "must give list of usernames" }
524 catch { after cancel $debug_cancelling }
525 set debug_cancelling [after $debug_reset_after debug_reset]
526 reporterr "debug enabled by $n: $debugusers"
532 global debugusers debug_cancelling
534 catch { after cancel $debug_cancelling }
535 catch { unset debug_cancelling }
536 reporterr "debug disabled by $n"
539 proc_dset visibledest {} {
540 regsub {\:[^:]*/} $d/ { } p
541 regsub {^([^:]+)\:\d+\:} $p {\1, } p
548 foreach m [list_objs monitor] {
549 upvar #0 monitor/$m mm
550 lappend r "monitoring $mm(chans) for $m"
552 foreach d [list_objs deviceset] {
553 upvar #0 deviceset/$d dd
555 upvar #0 monitor/$m mm
556 if {![info exists mm(chans)]} continue
557 lappend r "sending $m to [dset_visibledest $d]"
559 ucmdr [join $r "\n"] {}
563 ldebug {} "connected"
564 foreach f [glob -nocomplain pwdb/p*] {
565 regexp {^pwdb/p(.*)$} $f dummy username
566 set m [reloaduser $username]
572 set nl [irctolower $n]
574 foreach d [list_objs deviceset] {
575 upvar #0 deviceset/$d dd
577 upvar #0 monitor/$m mm
578 if {![info exists mm(prefer)]} continue
579 if {![mon_nick_is $mm(prefer) $nl]} continue
580 foreach ch $mm(chans) { set wch($ch) 1 }
581 lappend l [dset_visibledest $d]
584 sendprivmsg $nl "LEDs are watching on [\
585 join [lsort [array names wch]] ","]: [join $l " "]"
589 proc msg_JOIN {p c chan} {
591 set nl [irctolower $n]
595 proc msg_PART {p c chan} { chan_shortly $chan }
596 proc msg_KILL {p c user why} { allchans_shortly }
597 proc msg_QUIT {p c why} { allchans_shortly }
598 proc msg_NICK {p c newnick} { allchans_shortly; warn_pref $newnick }
599 proc msg_KICK {p c chans users comment} {
600 if {[llength $chans] > 1} {
603 chan_shortly [lindex $chans 0]
611 fail "startup: $emsg"