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 {[md
]([^
:]+)\:} $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
149 set mm
(present-
$ch) $l
153 proc_mon speech
{chan ln
} {
154 if {[lsearch -exact $mm(chans
) $chan] == -1} return
155 if {[mon_nick_is
$mm(ignore
) $ln]} return
156 set now
[clock seconds
]
157 set mm
(last-talk
) $now
158 if {[mon_nick_is
$mm(prefer
) $ln]} { set mm
(last-talkpref
) $now }
162 proc_mon calcstate
{} {
164 foreach ch
$mm(chans
) {
165 if {[llength $mm(present-
$ch)]} { append s
"present "; break }
167 set now
[clock seconds
]
168 set valid_until
[expr {$now + 86400}]
170 catch { after cancel
$mm(talkchange
) }
171 foreach p
{{} pref
} {
173 set vu
[expr {$mm(last-talk
$p) + $mm(time-recent
$t)}]
174 if {$vu < $now} continue
175 append s
"${p}talk${t} "
177 if {$vu < $valid_until} { set valid_until
$vu }
180 regsub {^
default } $s { } ss
181 set ds
[string trim
$ss]
182 if {$refresh_later} {
183 set interval
[expr {$valid_until - $now + 2}]
184 set ivms
[expr {$interval*1000}]
185 set mm
(talkchange
) [after $ivms [list mon_updateall
$m]]
186 ldebug m
$m "until now+${interval}: $ds"
188 ldebug m
$m "indefinitely: $ds"
193 proc_mon updateall
{} {
194 set s
[mon_calcstate
$m]
195 foreach d
[list_objs deviceset
] {
196 upvar #0 deviceset/$d dd
197 if {[string compare
$m $dd(monname
)]} continue
198 dset_setbystate
$d $s
202 proc_mon
destroy {} {
203 ldebug m
$m "destroying"
204 catch { after cancel
$mm(talkchange
) }
208 proc proc_dset
{name argl body
} {
209 proc dset_
$name [concat d
$argl] "
210 upvar #0 deviceset/\$d dd
214 reporterr \"error on \$d: \$emsg\"
219 log
"[clock seconds] $m"
222 proc_dset setbystate
{s
} {
223 foreach {sq v
} $dd(states
) {
224 if {![string match
*$sq* $s]} continue
227 if {![info exists lv
]} {
228 reporterr
"no state for $d matching$s"
231 ldebug d
$d "matches $sq: $v"
233 set dd
(values
) "$sq=$lv"
237 proc_dset
destroy {} {
238 ldebug d
$d "destroying"
239 catch { after cancel
$dd(retry
) }
241 if {[info exists dd
(ochan
)]} { timed_log
">\$$d destroy" }
248 proc modvar_save_copy
{cv defv
} {
252 if {[info exists save
($cv)]} {
253 set mm
($cv) $save($cv)
259 proc reloaduser
{username
} {
260 check_username
$username
261 ldebug u
$username "reloading"
263 set cfg
[exec userv
--timeout 3 $username irc-ledcontrol-config
\
266 regsub "\n" $emsg " // " emsg
267 reporterr
"error reloading $username: $emsg"
270 foreach d
[list_objs deviceset
] {
271 if {![string match
$username:* $d]} continue
274 foreach m
[list_objs monitor
] {
275 if {![string match
$username* $m]} continue
276 upvar #0 monitor/$m mm
277 foreach cv
[array names mm
] { set save
/${m
}($cv) $mm($cv) }
279 if {![string length
$cfg]} {
280 file delete pwdb
/$username
281 return "no config from $username"
283 exec userv
--timeout 3 $username irc-ledcontrol-passwords
\
284 < /dev
/null
> pwdb
/p
$username
286 reporterr
"error reading passwords for $username: $emsg"
289 ldebug u
$username "parsing"
290 foreach cv
{ignore nopresence prefer
} { set cc
($cv) {} }
291 set cc
(time-recentnow
) 120
292 set cc
(time-recent
) 450
294 foreach l
[split $cfg "\n"] {
296 set l
[string trim
$l]
297 if {[regexp {^
\#} $l]} {
298 } elseif
{[regexp {^nick
\s
+(ignore|nopresence|prefer
)\s
+(\S.
*)$} \
299 $l dummy kind globs
]} {
301 foreach gl
[split $globs " "] {
302 if {![string length
$gl]} continue
304 lappend cc
($kind) $gl
306 } elseif
{[regexp {^times
\s
+(\d
+)\s
+(\d
+)$} $l dummy r rnow
]} {
307 foreach cv
{{} now
} { set cc
(time-recent
$cv) [set r
$cv] }
308 } elseif
{[regexp {^monitor
\s
+(\S
+)\s
+(\S.
*)$} $l dummy m cl
]} {
310 if {![string match
$username:* $m]} {
311 error "monname must start with $username:"
314 foreach ch
[split $cl " "] {
315 if {![string length
$ch]} continue
317 if {![ischan
$ch]} { error "invalid channel $ch" }
318 lappend cc
(chans
) [irctolower
$ch]
321 upvar #0 monitor/$m mm
322 foreach cv
[array names cc
] { set mm
($cv) $cc($cv) }
323 foreach cv
{{} pref
} {
324 modvar_save_copy last-talk
$cv 0
326 foreach cv
[array names mm
(chans
)] {
327 modvar_save_copy present-
$cv {}
331 {^leds
\s
+([0-9A-Za-z
][-:/0-9A-Za-z
]+)\s
+(\S
+)\s
+(\S
+.
*)$} \
332 $l dummy g m states
]} {
333 set d
$username:$lno:$g
336 foreach sv
[split $states " "] {
337 if {![string length
$sv]} continue
339 {^
((?
:pref
)?talk
(?
:now
)?|present|
default)\=([0-9a-z
][,/+0-9A-Za-z
]*)$} \
340 $sv dummy lhs rhs
]} {
341 error "invalid state spec"
345 upvar #0 deviceset/$d dd
349 set dd
(values
) startup
350 set dd
(username
) $username
356 reporterr
"setup error $username:$lno:$emsg"
359 return "reloaded $username"
363 proc check_monname
{m
} {
364 if {[regexp {[^
-_+:.
#0-9a-zA-Z]} $m badchar]} {
365 error "char $badchar not allowed in monnames"
367 if {![regexp {^
[0-9a-zA-Z
]} $m]} {
368 error "monname must start with alphanum"
373 catch { unset dd
(retry
) }
374 set username
$dd(username
)
375 ldebug d
$d "starting"
377 set cmdl
[list remoteleds
--pipe $dd(group
) \
378 --human --passfile-only pwdb
/p
$username]
379 timed_log
"!-$d [join $cmdl " "]"
380 lappend cmdl
< pwdb
/fifo |
& cat
381 catch { file delete pwdb
/fifo
}
382 exec mkfifo
-m 0600 pwdb
/fifo
383 set ichan
[open pwdb
/fifo r
+]
384 set ochan
[open |
$cmdl r
]
385 fconfigure $ichan -blocking 0 -buffering line
386 fconfigure $ochan -blocking 0 -buffering line
387 fileevent $ochan readable
[list dset_rledout
$d]
391 reporterr
"remoteleds startup $d: $emsg"
392 catch { close $ichan }
393 catch { close $ochan }
398 proc_dset rledout
{} {
400 while {[gets $dd(ochan
) l
] != -1} {
401 reporterr
"remoteleds on $d: $dd(values): $l"
403 if {[fblocked $dd(ochan
)]} return
404 timed_log
">\$$d failure";
405 catch { close $dd(ichan
) }
406 catch { close $dd(ochan
) }
409 reporterr
"remoteleds on $d died"
413 proc_dset trylater
{} {
415 ldebug d
$d "will try again later"
416 set dd
(retry
) [after $retry_after [list dset_start
$d]]
419 proc config_change
{} {
420 global onchans chans_retry errchan config_retry_after
421 ldebug
{} "rechecking configuration etc"
422 foreach ch
[array names onchans
] {
423 manyset
$onchans($ch) status
after
424 if {"$status" == "shortly"} {
425 catch { after cancel
$after }
427 set onchans
($ch) mustleave
429 sendout JOIN
$errchan
430 chan_shortly
$errchan
431 foreach m
[list_objs monitor
] {
432 upvar #0 monitor/$m mm
433 foreach ch
$mm(chans
) {
438 foreach ch
[array names onchans
] {
439 if {"[lindex $onchans($ch) 0]" != "mustleave"} continue
443 catch { after cancel
$config_retry_after }
444 set config_retry_after
[after $chans_retry config_change
]
447 proc allchans_shortly
{} {
448 global chan_after onchans shortly_alling
449 if {[info exists shortly_alling
]} {
450 ldebug
{} "global check already pending"
453 foreach ch
[array names onchans
] {
454 manyset
$onchans($ch) status
after
455 if {"$status" != "shortly"} continue
458 set shortly_alling
[after $chan_after allchans_sendnames
]
461 proc allchans_sendnames
{} {
462 global shortly_alling
464 ldebug
{} "asking for global namelist"
468 proc chan_shortly
{ch
} {
469 global chan_after shortly_alling
470 set ch
[irctolower
$ch]
471 if {[info exists shortly_alling
]} {
472 ldebug c
$ch "global check already pending"
475 upvar #0 onchans($ch) oc
476 if {[info exists oc
]} {
477 manyset
$oc status
after
478 if {"$status" == "shortly"} {
479 ldebug c
$ch "queued check already pending"
483 ldebug c
$ch "queueing check"
484 set oc
[list shortly
[after $chan_after chan_sendnames
$ch]]
487 proc msg_353
{p c dest type chan nicklist
} {
488 set lchan
[irctolower
$chan]
489 set nll
[irctolower
$nicklist]
490 regsub -all {[=@*]} $nll {} nll
491 ldebug c
$lchan "got names $nll"
492 foreach m
[list_objs monitor
] {
493 mon_gotchanlist
$m $lchan $nll
497 proc chan_sendnames
{ch
} {
498 upvar #0 onchans($ch) oc
499 ldebug c
$ch "asking for namelist"
505 set username
[ta_word
]
507 set m
[reloaduser
$username]
512 proc debug_reset
{} {
513 global debugusers debug_cancelling
514 unset debug_cancelling
516 reporterr
"debug mode timed out"
521 global debugusers debug_cancelling debug_reset_after
522 if {![string length
$text]} { error "must give list of usernames" }
525 catch { after cancel
$debug_cancelling }
526 set debug_cancelling
[after $debug_reset_after debug_reset
]
527 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"
541 foreach m
[list_objs monitor
] {
542 upvar #0 monitor/$m mm
543 lappend r
"monitoring $mm(chans) for $m"
545 foreach d
[list_objs deviceset
] {
546 upvar #0 deviceset/$d dd
547 regexp {^
[^
:]*\:[^
:]*} $dd(group
) dest
548 lappend r
"sending $dd(monname) to $dest"
550 ucmdr
[join $r "\n"] {}
554 ldebug
{} "connected"
555 foreach f
[glob -nocomplain pwdb
/p
*] {
556 regexp {^pwdb
/p
(.
*)$} $f dummy username
557 set m
[reloaduser
$username]
562 proc msg_JOIN
{p c chan
} { chan_shortly
$chan }
563 proc msg_PART
{p c chan
} { chan_shortly
$chan }
564 proc msg_KILL
{p c user why
} { allchans_shortly
}
565 proc msg_QUIT
{p c why
} { allchans_shortly
}
566 proc msg_KICK
{p c chans users comment
} {
567 if {[llength $chans] > 1} {
570 chan_shortly
[lindex $chans 0]
578 fail
"startup: $emsg"