ledmodule.tcl

   1 # maintains local list of users to userv-slurp config from
   2 # each user provides list of
   3 #    monitors
   4 #    devicesets
   5 #
   6 # a monitor specifies
   7 #    name
   8 #    IRC channel(s)
   9 #    nicks ignore totally
  10 #    nicks ignore presence
  11 #    nicks prefer speech
  12 #    time for `a while ago'
  13 #    time for `very-recently'
  14 # syntax
  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>:
  20 #
  21 # a deviceset specifies
  22 #    monitor
  23 #    led-group
  24 #    led states
  25 # syntax
  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
  34
  35 set helpfile ledhelp
  36
  37 source irccore.tcl
  38 source parsecmd.tcl
  39 source stdhelp.tcl
  40 source userv.tcl
  41
  42 defset errchan #$nick
  43 defset retry_after 900000
  44 defset chan_after 1500
  45 defset chans_retry 3600000
  46 defset debug_reset_after 86400000
  47
  48 defset debugusers {}
  49
  50 # variables
  51 #
  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
  61 #
  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
  70 #
  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
  75
  76 proc ldebug {facil m} {
  77     global debugusers
  78     # facil is
  79     #    m$monname
  80     #    d$deviceset
  81     #    c$lchan
  82     #    {}             for system stuff
  83     if {![llength $debugusers]} return
  84     if {[regexp {[mdu]([^:]+)\:} $facil dummy username] &&
  85         [lsearch -exact $debugusers $username]==-1} return
  86
  87     regsub {^(.)} $facil {\1 } cc
  88     reporterr "DEBUG $cc $m"
  89 }
  90
  91 proc list_objs {vp} {
  92     set l {}
  93     foreach v [info globals] {
  94         if {![regsub ^$vp/ $v {} v]} continue
  95         lappend l $v
  96     }
  97     return $l
  98 }
  99
 100 proc privmsg_unlogged {p ischan params} {
 101     global errorInfo
 102     if {!$ischan} { return 0 }
 103
 104     # on-channel message
 105     if {[catch {
 106         prefix_nick
 107         foreach m [list_objs monitor] {
 108             mon_speech $m [irctolower [lindex $params 0]] [irctolower $n]
 109         }
 110     } emsg]} {
 111         log "processing error: $emsg\n$errorInfo"
 112     }
 113     return 1;
 114 }
 115
 116 proc reporterr {m} {
 117     global errchan
 118     sendprivmsg $errchan $m
 119 }
 120
 121 proc msg_PRIVMSG {p c dest text} {
 122     global errchan
 123     prefix_nick
 124     execute_usercommand $p $c $n $errchan $dest $text
 125 }
 126
 127 proc proc_mon {name argl body} {
 128     proc mon_$name [concat m $argl] "
 129     upvar #0 monitor/\$m mm
 130     $body"
 131 }
 132
 133 proc mon_nick_is {globlist ln} {
 134     foreach gl $globlist {
 135         if {[string match $gl $ln]} { return 1 }
 136     }
 137     return 0
 138 }
 139
 140 proc_mon gotchanlist {ch nll} {
 141     global nick
 142     if {[lsearch -exact $mm(chans) $ch] == -1} return
 143     set l {}
 144     foreach nl $nll {
 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
 148         lappend l $nl
 149     }
 150     ldebug m$m "$ch names: $l"
 151     set mm(present-$ch) $l
 152     mon_updateall $m
 153 }
 154
 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 }
 161     mon_updateall $m
 162 }
 163
 164 proc_mon calcstate {} {
 165     set s " default "
 166     foreach ch $mm(chans) {
 167         if {[llength $mm(present-$ch)]} { append s "present "; break }
 168     }
 169     set now [clock seconds]
 170     set valid_until [expr {$now + 86400}]
 171     set refresh_later 0
 172     catch { after cancel $mm(talkchange) }
 173     foreach p {{} pref} {
 174         foreach t {{} now} {
 175             set vu [expr {$mm(last-talk$p) + $mm(time-recent$t)}]
 176             if {$vu < $now} continue
 177             append s "${p}talk${t} "
 178             set refresh_later 1
 179             if {$vu < $valid_until} { set valid_until $vu }
 180         }
 181     }
 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"
 189     } else {
 190         ldebug m$m "indefinitely: $ds"
 191     }
 192     return $s
 193 }
 194
 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
 201     }
 202 }
 203
 204 proc_mon destroy {} {
 205     ldebug m$m "destroying"
 206     catch { after cancel $mm(talkchange) }
 207     catch { unset mm }
 208 }
 209
 210 proc proc_dset {name argl body} {
 211     proc dset_$name [concat d $argl] "
 212     upvar #0 deviceset/\$d dd
 213     set returncode \[catch {
 214         $body
 215     } emsg\]
 216     global errorInfo errorCode
 217     if {\$returncode==1} {
 218         reporterr \"error on \$d: \$emsg\"
 219     } elseif {\$returncode==2} {
 220         return \$emsg
 221     } else {
 222         return -code \$returncode -errorinfo \$errorInfo -errorcode \$errorCode
 223     }"
 224 }
 225
 226 proc timed_log {m} {
 227     log "[clock seconds] $m"
 228 }
 229
 230 proc_dset setbystate {s} {
 231     foreach {sq v} $dd(states) {
 232         if {![string match *$sq* $s]} continue
 233         set lv $v; break
 234     }
 235     if {![info exists dd(ichan)]} return
 236     if {![info exists lv]} {
 237         reporterr "no state for $d matching$s"
 238         return
 239     }
 240     ldebug d$d "matches $sq: $v"
 241     timed_log "->$d $lv"
 242     set dd(values) "$sq=$lv"
 243     puts $dd(ichan) $lv
 244 }
 245
 246 proc_dset destroy {} {
 247     ldebug d$d "destroying"
 248     catch { after cancel $dd(retry) }
 249     catch {
 250         if {[info exists dd(ochan)]} { timed_log ">\$$d destroy" }
 251         close $dd(ochan)
 252         close $dd(ichan)
 253     }
 254     catch { unset dd }
 255 }
 256
 257 proc modvar_save_copy {cv defv} {
 258     upvar 1 m m
 259     upvar 1 mm mm
 260     upvar 1 save/$m save
 261     if {[info exists save($cv)]} {
 262         set mm($cv) $save($cv)
 263     } else {
 264         set mm($cv) $defv
 265     }
 266 }
 267
 268 proc reloaduser {username} {
 269     check_username $username
 270     ldebug u$username "reloading"
 271     if {[catch {
 272         set cfg [exec userv --timeout 3 $username irc-ledcontrol-config \
 273                 < /dev/null]
 274     } emsg]} {
 275         regsub "\n" $emsg " // " emsg
 276         reporterr "error reloading $username: $emsg"
 277         return ""
 278     }
 279     foreach d [list_objs deviceset] {
 280         if {![string match $username:* $d]} continue
 281         dset_destroy $d
 282     }
 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) }
 287     }
 288     if {![string length $cfg]} {
 289         file delete pwdb/$username
 290         return "no config from $username"
 291     } elseif {[catch {
 292         exec userv --timeout 3 $username irc-ledcontrol-passwords \
 293                 < /dev/null > pwdb/p$username
 294     } emsg]} {
 295         reporterr "error reading passwords for $username: $emsg"
 296         return ""
 297     } elseif {[catch {
 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
 302         set lno 0
 303         set contin {}
 304         foreach l [split $cfg "\n"] {
 305             incr lno
 306             append contin [string trim $l]
 307             if {[regsub {\\$} $contin { } contin]} continue
 308             set l $contin
 309             set contin {}
 310             if {[regexp {^\#} $l]} {
 311             } elseif {![regexp {\S} $l]} {
 312             } elseif {[regexp {^nick\s+(ignore|nopresence|prefer)\s+(.*)$} \
 313                     "$l " dummy kind globs]} {
 314                 set cc($kind) {}
 315                 foreach gl [split $globs " "] {
 316                     if {![string length $gl]} continue
 317                     string match $gl {}
 318                     lappend cc($kind) $gl
 319                 }
 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]} {
 323                 set cc(chans) {}
 324                 if {![string match $username:* $m]} {
 325                     error "monname must start with $username:"
 326                 }
 327                 check_monname $m
 328                 foreach ch [split $cl " "] {
 329                     if {![string length $ch]} continue
 330                     check_chan $ch
 331                     if {![ischan $ch]} { error "invalid channel $ch" }
 332                     lappend cc(chans) [irctolower $ch]
 333                     chan_shortly $ch
 334                 }
 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
 339                 }
 340                 foreach cv [array names mm(chans)] {
 341                     modvar_save_copy present-$cv {}
 342                 }
 343                 ldebug m$m "created"
 344             } elseif {[regexp \
 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
 348                 set sl {}
 349                 check_monname $m
 350                 foreach sv [split $states " "] {
 351                     if {![string length $sv]} continue
 352                     if {![regexp \
 353  {^((?:pref)?talk(?:now)?|present|default)\=([0-9a-z][,/+0-9A-Za-z]*)$} \
 354                           $sv dummy lhs rhs]} {
 355                         error "invalid state spec"
 356                     }
 357                     lappend sl $lhs $rhs
 358                 }
 359                 upvar #0 deviceset/$d dd
 360                 set dd(monname) $m
 361                 set dd(states) $sl
 362                 set dd(group) $g
 363                 set dd(values) startup
 364                 set dd(username) $username
 365                 dset_start $d
 366                 ldebug d$d "created"
 367             } else {
 368                 error "invalid directive or syntax"
 369             }
 370         }
 371         if {[string length $contin]} {
 372             error "continuation line at end of file"
 373         }
 374     } emsg]} {
 375         reporterr "setup error $username:$lno:$emsg"
 376         return ""
 377     } else {
 378         return "reloaded $username"
 379     }
 380 }
 381
 382 proc check_monname {m} {
 383     if {[regexp {[^-_+:.#0-9a-zA-Z]} $m badchar]} {
 384         error "char $badchar not allowed in monnames"
 385     }
 386     if {![regexp {^[0-9a-zA-Z]} $m]} {
 387         error "monname must start with alphanum"
 388     }
 389 }
 390
 391 proc_dset start {} {
 392     catch { unset dd(retry) }
 393     set username $dd(username)
 394     ldebug d$d "starting"
 395     if {[catch {
 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
 406         set dd(ichan) $ichan
 407         set dd(ochan) $ochan
 408         fileevent $ochan readable [list dset_rledout $d]
 409     } emsg]} {
 410         reporterr "remoteleds startup $d: $emsg"
 411         catch { close $ichan }
 412         catch { close $ochan }
 413         dset_trylater $d
 414     }
 415 }
 416
 417 proc_dset rledout {} {
 418     global errchan
 419     while {[gets $dd(ochan) l] != -1} {
 420         reporterr "on $d: $dd(values): $l"
 421     }
 422     if {[fblocked $dd(ochan)]} return
 423     timed_log ">\$$d failure";
 424     catch { close $dd(ichan) }
 425     catch { close $dd(ochan) }
 426     unset dd(ichan)
 427     unset dd(ochan)
 428     reporterr "on $d died"
 429     dset_trylater $d
 430 }
 431
 432 proc_dset trylater {} {
 433     global retry_after
 434     ldebug d$d "will try again later"
 435     set dd(retry) [after $retry_after [list dset_start $d]]
 436 }
 437
 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 }
 445         }
 446         set onchans($ch) mustleave
 447     }
 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) {
 453             sendout JOIN $ch
 454             chan_shortly $ch
 455         }
 456     }
 457     foreach ch [array names onchans] {
 458         if {"[lindex $onchans($ch) 0]" != "mustleave"} continue
 459         sendout PART $ch
 460         unset onchans($ch)
 461     }
 462     catch { after cancel $config_retry_after }
 463     set config_retry_after [after $chans_retry config_change]
 464 }
 465
 466 proc allchans_shortly {} {
 467     global onchans
 468     foreach ch [array names onchans] { chan_shortly $ch }
 469 }
 470
 471 proc chan_shortly {ch} {
 472     global chan_after
 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"
 479             return
 480         }
 481     }
 482     ldebug c$ch "queueing check"
 483     set oc [list shortly [after $chan_after chan_sendnames $ch]]
 484 }
 485
 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
 493     }
 494 }
 495
 496 proc chan_sendnames {ch} {
 497     upvar #0 onchans($ch) oc
 498     ldebug c$ch "asking for namelist"
 499     sendout NAMES $ch
 500     set oc idle
 501 }
 502
 503 def_ucmd reload {
 504     set username [ta_word]
 505     ta_nomore
 506     set m [reloaduser $username]
 507     config_change
 508     ucmdr {} $m
 509 }
 510
 511 proc debug_reset {} {
 512     global debugusers debug_cancelling
 513     unset debug_cancelling
 514     set debugusers {}
 515     reporterr "debug mode timed out"
 516 }
 517
 518 def_ucmd debug {
 519     prefix_nick
 520     global debugusers debug_cancelling debug_reset_after
 521     if {![string length $text]} { error "must give list of usernames" }
 522     llength $text
 523     set debugusers $text
 524     catch { after cancel $debug_cancelling }
 525     set debug_cancelling [after $debug_reset_after debug_reset]
 526     reporterr "debug enabled by $n: $debugusers"
 527 }
 528
 529 def_ucmd nodebug {
 530     prefix_nick
 531     ta_nomore
 532     global debugusers debug_cancelling
 533     set debugusers {}
 534     catch { after cancel $debug_cancelling }
 535     catch { unset debug_cancelling }
 536     reporterr "debug disabled by $n"
 537 }
 538
 539 proc_dset visibledest {} {
 540     regsub {\:[^:]*/} $d/ { } p
 541     regsub {^([^:]+)\:\d+\:} $p {\1, } p
 542     regsub { $} $p {} p
 543     return $p
 544 }
 545
 546 def_ucmd who {
 547     set r {}
 548     foreach m [list_objs monitor] {
 549         upvar #0 monitor/$m mm
 550         lappend r "monitoring $mm(chans) for $m"
 551     }
 552     foreach d [list_objs deviceset] {
 553         upvar #0 deviceset/$d dd
 554         set m $dd(monname)
 555         upvar #0 monitor/$m mm
 556         if {![info exists mm(chans)]} continue
 557         lappend r "sending $m to [dset_visibledest $d]"
 558     }
 559     ucmdr [join $r "\n"] {}
 560 }
 561
 562 proc connected {} {
 563     ldebug {} "connected"
 564     foreach f [glob -nocomplain pwdb/p*] {
 565         regexp {^pwdb/p(.*)$} $f dummy username
 566         set m [reloaduser $username]
 567     }
 568     config_change
 569 }
 570
 571 proc warn_pref {n} {
 572     set nl [irctolower $n]
 573     set l {}
 574     foreach d [list_objs deviceset] {
 575         upvar #0 deviceset/$d dd
 576         set m $dd(monname)
 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]
 582     }
 583     if {[llength $l]} {
 584         sendprivmsg $nl "LEDs are watching on [\
 585                 join [lsort [array names wch]] ","]: [join $l " "]"
 586     }
 587 }
 588
 589 proc msg_JOIN {p c chan} {
 590     prefix_nick
 591     set nl [irctolower $n]
 592     chan_shortly $chan
 593     warn_pref $n
 594 }
 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} {
 601         allchans_shortly
 602     } else {
 603         chan_shortly [lindex $chans 0]
 604     }
 605 }
 606
 607 if {[catch {
 608     loadhelp
 609     ensure_connecting
 610 } emsg]} {
 611     fail "startup: $emsg"
 612 }