ledmodule.tcl

   1 # see ledbot.html
   2 # $Id$
   3
   4 set helpfile ledhelp
   5
   6 source irccore.tcl
   7 source parsecmd.tcl
   8 source stdhelp.tcl
   9 source userv.tcl
  10
  11 defset errchan #$nick
  12 defset retry_after 900000
  13 defset chan_after 1500
  14 defset chans_retry 3600000
  15 defset debug_reset_after 86400000
  16
  17 defset debugusers {}
  18
  19 # variables
  20 #
  21 #   monitor/$monname(chans)           -> [list $chan1 $chan2 ...]
  22 #   monitor/$monname(ignore)          -> [list $regexp ...]
  23 #   monitor/$monname(prefer)          -> [list $regexp ...]
  24 #   monitor/$monname(present-$chan)   -> [list $lnick ...]
  25 #   monitor/$monname(last-talk)       -> $time_t
  26 #   monitor/$monname(last-talkpref)   -> $time_t
  27 #   monitor/$monname(time-recent)     -> $seconds
  28 #   monitor/$monname(time-recentnow)  -> $seconds
  29 #   monitor/$monname(talkchange)      -> [after ...]    or unset
  30 #
  31 #   deviceset/$username:$lno(monname)  -> $monname
  32 #   deviceset/$username:$lno(group)    -> $led_group
  33 #   deviceset/$username:$lno(username) -> $username
  34 #   deviceset/$username:$lno(values)   -> $valuestring
  35 #   deviceset/$username:$lno(states)   -> [list $state1 $value1 $state2 ...]
  36 #   deviceset/$username:$lno(ochan)    -> [open remoteleds ... | r]  or unset
  37 #   deviceset/$username:$lno(ichan)    -> fifo for remoteleds input  or unset
  38 #   deviceset/$username:$lno(retry)    -> [after ... ]             or unset
  39 #
  40 #   onchans($chan)        [list mustleave]                 # in config_chane
  41 #   onchans($chan)        [list idle]
  42 #   onchans($chan)        [list forced]                    # for errchan
  43 #   onchans($chan)        [list shortly [after ...]]       # do a NAMES
  44
  45 proc ldebug {facil m} {
  46     global debugusers
  47     # facil is
  48     #    m$monname
  49     #    d$deviceset
  50     #    c$lchan
  51     #    {}             for system stuff
  52     if {![llength $debugusers]} return
  53     if {[regexp {[mdu]([^:]+)\:} $facil dummy username] &&
  54         [lsearch -exact $debugusers $username]==-1} return
  55
  56     regsub {^(.)} $facil {\1 } cc
  57     reporterr "DEBUG $cc $m"
  58 }
  59
  60 proc list_objs {vp} {
  61     set l {}
  62     foreach v [info globals] {
  63         if {![regsub ^$vp/ $v {} v]} continue
  64         lappend l $v
  65     }
  66     return $l
  67 }
  68
  69 proc privmsg_unlogged {p ischan params} {
  70     global errorInfo
  71     if {!$ischan} { return 0 }
  72
  73     # on-channel message
  74     if {[catch {
  75         prefix_nick
  76         foreach m [list_objs monitor] {
  77             mon_speech $m [irctolower [lindex $params 0]] [irctolower $n]
  78         }
  79     } emsg]} {
  80         log "processing error: $emsg\n$errorInfo"
  81     }
  82     return 1;
  83 }
  84
  85 proc reporterr {m} {
  86     global errchan
  87     sendprivmsg $errchan $m
  88 }
  89
  90 proc msg_PRIVMSG {p c dest text} {
  91     global errchan
  92     prefix_nick
  93     execute_usercommand $p $c $n $errchan $dest $text
  94 }
  95
  96 proc proc_mon {name argl body} {
  97     proc mon_$name [concat m $argl] "
  98     upvar #0 monitor/\$m mm
  99     $body"
 100 }
 101
 102 proc mon_nick_is {globlist ln} {
 103     foreach gl $globlist {
 104         if {[string match $gl $ln]} { return 1 }
 105     }
 106     return 0
 107 }
 108
 109 proc_mon gotchanlist {ch nll} {
 110     global nick
 111     if {[lsearch -exact $mm(chans) $ch] == -1} return
 112     set l {}
 113     foreach nl $nll {
 114         if {![string compare $nl [irctolower $nick]]} continue
 115         if {[mon_nick_is $mm(nopresence) $nl]} continue
 116         if {[mon_nick_is $mm(ignore) $nl]} continue
 117         lappend l $nl
 118     }
 119     ldebug m$m "$ch names: $l"
 120     set mm(present-$ch) $l
 121     mon_updateall $m
 122 }
 123
 124 proc_mon speech {chan ln} {
 125     if {[lsearch -exact $mm(chans) $chan] == -1} return
 126     if {[mon_nick_is $mm(ignore) $ln]} return
 127     set now [clock seconds]
 128     set mm(last-talk) $now
 129     if {[mon_nick_is $mm(prefer) $ln]} { set mm(last-talkpref) $now }
 130     mon_updateall $m
 131 }
 132
 133 proc_mon calcstate {} {
 134     set s " default "
 135     foreach ch $mm(chans) {
 136         if {[llength $mm(present-$ch)]} { append s "present "; break }
 137     }
 138     set now [clock seconds]
 139     set valid_until [expr {$now + 86400}]
 140     set refresh_later 0
 141     catch { after cancel $mm(talkchange) }
 142     foreach p {{} pref} {
 143         foreach t {{} now} {
 144             set vu [expr {$mm(last-talk$p) + $mm(time-recent$t)}]
 145             if {$vu < $now} continue
 146             append s "${p}talk${t} "
 147             set refresh_later 1
 148             if {$vu < $valid_until} { set valid_until $vu }
 149         }
 150     }
 151     regsub {^ default } $s { } ss
 152     set ds [string trim $ss]
 153     if {$refresh_later} {
 154         set interval [expr {$valid_until - $now + 2}]
 155         set ivms [expr {$interval*1000}]
 156         set mm(talkchange) [after $ivms [list mon_updateall $m]]
 157         ldebug m$m "until now+${interval}: $ds"
 158     } else {
 159         ldebug m$m "indefinitely: $ds"
 160     }
 161     return $s
 162 }
 163
 164 proc_mon updateall {} {
 165     set s [mon_calcstate $m]
 166     foreach d [list_objs deviceset] {
 167         upvar #0 deviceset/$d dd
 168         if {[string compare $m $dd(monname)]} continue
 169         dset_setbystate $d $s
 170     }
 171 }
 172
 173 proc_mon destroy {} {
 174     ldebug m$m "destroying"
 175     catch { after cancel $mm(talkchange) }
 176     catch { unset mm }
 177 }
 178
 179 proc proc_dset {name argl body} {
 180     proc dset_$name [concat d $argl] "
 181     upvar #0 deviceset/\$d dd
 182     set returncode \[catch {
 183         $body
 184     } emsg\]
 185     global errorInfo errorCode
 186     if {\$returncode==1} {
 187         reporterr \"error on \$d: \$emsg\"
 188     } elseif {\$returncode==2} {
 189         return \$emsg
 190     } else {
 191         return -code \$returncode -errorinfo \$errorInfo -errorcode \$errorCode
 192     }"
 193 }
 194
 195 proc timed_log {m} {
 196     log "[clock seconds] $m"
 197 }
 198
 199 proc_dset setbystate {s} {
 200     foreach {sq v} $dd(states) {
 201         if {![string match *$sq* $s]} continue
 202         set lv $v; break
 203     }
 204     if {![info exists dd(ichan)]} return
 205     if {![info exists lv]} {
 206         reporterr "no state for $d matching$s"
 207         return
 208     }
 209     ldebug d$d "matches $sq: $v"
 210     timed_log "->$d $lv"
 211     set dd(values) "$sq=$lv"
 212     puts $dd(ichan) $lv
 213 }
 214
 215 proc_dset destroy {} {
 216     ldebug d$d "destroying"
 217     catch { after cancel $dd(retry) }
 218     catch {
 219         if {[info exists dd(ochan)]} { timed_log ">\$$d destroy" }
 220         close $dd(ochan)
 221         close $dd(ichan)
 222     }
 223     catch { unset dd }
 224 }
 225
 226 proc modvar_save_copy {cv defv} {
 227     upvar 1 m m
 228     upvar 1 mm mm
 229     upvar 1 save/$m save
 230     if {[info exists save($cv)]} {
 231         set mm($cv) $save($cv)
 232     } else {
 233         set mm($cv) $defv
 234     }
 235 }
 236
 237 proc reloaduser {username} {
 238     check_username $username
 239     ldebug u$username "reloading"
 240     if {[catch {
 241         set cfg [exec userv --timeout 3 $username irc-ledcontrol-config \
 242                 < /dev/null]
 243     } emsg]} {
 244         regsub "\n" $emsg " // " emsg
 245         reporterr "error reloading $username: $emsg"
 246         return ""
 247     }
 248     foreach d [list_objs deviceset] {
 249         if {![string match $username:* $d]} continue
 250         dset_destroy $d
 251     }
 252     foreach m [list_objs monitor] {
 253         if {![string match $username* $m]} continue
 254         upvar #0 monitor/$m mm
 255         foreach cv [array names mm] { set save/${m}($cv) $mm($cv) }
 256     }
 257     if {![string length $cfg]} {
 258         file delete pwdb/$username
 259         return "no config from $username"
 260     } elseif {[catch {
 261         exec userv --timeout 3 $username irc-ledcontrol-passwords \
 262                 < /dev/null > pwdb/p$username
 263     } emsg]} {
 264         reporterr "error reading passwords for $username: $emsg"
 265         return ""
 266     } elseif {[catch {
 267         ldebug u$username "parsing"
 268         foreach cv {ignore nopresence prefer} { set cc($cv) {} }
 269         set cc(time-recentnow) 120
 270         set cc(time-recent) 450
 271         set lno 0
 272         set contin {}
 273         foreach l [split $cfg "\n"] {
 274             incr lno
 275             append contin [string trim $l]
 276             if {[regsub {\\$} $contin { } contin]} continue
 277             set l $contin
 278             set contin {}
 279             if {[regexp {^\#} $l]} {
 280             } elseif {![regexp {\S} $l]} {
 281             } elseif {[regexp {^nick\s+(ignore|nopresence|prefer)\s+(.*)$} \
 282                     "$l " dummy kind globs]} {
 283                 set cc($kind) {}
 284                 foreach gl [split $globs " "] {
 285                     if {![string length $gl]} continue
 286                     string match $gl {}
 287                     lappend cc($kind) $gl
 288                 }
 289             } elseif {[regexp {^times\s+(\d+)\s+(\d+)$} $l dummy rnow r]} {
 290                 foreach cv {{} now} { set cc(time-recent$cv) [set r$cv] }
 291             } elseif {[regexp {^monitor\s+(\S+)\s+(\S.*)$} $l dummy m cl]} {
 292                 set cc(chans) {}
 293                 if {![string match $username:* $m]} {
 294                     error "monname must start with $username:"
 295                 }
 296                 check_monname $m
 297                 foreach ch [split $cl " "] {
 298                     if {![string length $ch]} continue
 299                     check_chan $ch
 300                     if {![ischan $ch]} { error "invalid channel $ch" }
 301                     lappend cc(chans) [irctolower $ch]
 302                     chan_shortly $ch
 303                 }
 304                 upvar #0 monitor/$m mm
 305                 foreach cv [array names cc] { set mm($cv) $cc($cv) }
 306                 foreach cv {{} pref} {
 307                     modvar_save_copy last-talk$cv 0
 308                 }
 309                 foreach cv [array names mm(chans)] {
 310                     modvar_save_copy present-$cv {}
 311                 }
 312                 ldebug m$m "created"
 313             } elseif {[regexp \
 314  {^leds\s+([0-9A-Za-z][-.:/0-9A-Za-z]+)\s+(\S+)\s+(\S+.*)$} \
 315                     $l dummy g m states]} {
 316                 set d $username:$lno:$g
 317                 set sl {}
 318                 check_monname $m
 319                 foreach sv [split $states " "] {
 320                     if {![string length $sv]} continue
 321                     if {![regexp \
 322  {^((?:pref)?talk(?:now)?|present|default)\=([0-9a-z][,/+0-9A-Za-z]*)$} \
 323                           $sv dummy lhs rhs]} {
 324                         error "invalid state spec"
 325                     }
 326                     lappend sl $lhs $rhs
 327                 }
 328                 upvar #0 deviceset/$d dd
 329                 set dd(monname) $m
 330                 set dd(states) $sl
 331                 set dd(group) $g
 332                 set dd(values) startup
 333                 set dd(username) $username
 334                 dset_start $d
 335                 ldebug d$d "created"
 336             } else {
 337                 error "invalid directive or syntax"
 338             }
 339         }
 340         if {[string length $contin]} {
 341             error "continuation line at end of file"
 342         }
 343     } emsg]} {
 344         reporterr "setup error $username:$lno:$emsg"
 345         return ""
 346     } else {
 347         return "reloaded $username"
 348     }
 349 }
 350
 351 proc check_monname {m} {
 352     if {[regexp {[^-_+:.#0-9a-zA-Z]} $m badchar]} {
 353         error "char $badchar not allowed in monnames"
 354     }
 355     if {![regexp {^[0-9a-zA-Z]} $m]} {
 356         error "monname must start with alphanum"
 357     }
 358 }
 359
 360 proc_dset start {} {
 361     catch { unset dd(retry) }
 362     set username $dd(username)
 363     ldebug d$d "starting"
 364     if {[catch {
 365         set cmdl [list remoteleds --pipe $dd(group) \
 366                        --human --passfile-only pwdb/p$username]
 367         timed_log "!-$d [join $cmdl " "]"
 368         lappend cmdl < pwdb/fifo |& cat
 369         catch { file delete pwdb/fifo }
 370         exec mkfifo -m 0600 pwdb/fifo
 371         set ichan [open pwdb/fifo r+]
 372         set ochan [open |$cmdl r]
 373         fconfigure $ichan -blocking 0 -buffering line
 374         fconfigure $ochan -blocking 0 -buffering line
 375         set dd(ichan) $ichan
 376         set dd(ochan) $ochan
 377         fileevent $ochan readable [list dset_rledout $d]
 378     } emsg]} {
 379         reporterr "remoteleds startup $d: $emsg"
 380         catch { close $ichan }
 381         catch { close $ochan }
 382         dset_trylater $d
 383     }
 384 }
 385
 386 proc_dset rledout {} {
 387     global errchan
 388     while {[gets $dd(ochan) l] != -1} {
 389         reporterr "on $d: $dd(values): $l"
 390     }
 391     if {[fblocked $dd(ochan)]} return
 392     timed_log ">\$$d failure";
 393     catch { close $dd(ichan) }
 394     catch { close $dd(ochan) }
 395     unset dd(ichan)
 396     unset dd(ochan)
 397     reporterr "on $d died"
 398     dset_trylater $d
 399 }
 400
 401 proc_dset trylater {} {
 402     global retry_after
 403     ldebug d$d "will try again later"
 404     set dd(retry) [after $retry_after [list dset_start $d]]
 405 }
 406
 407 proc config_change {} {
 408     global onchans chans_retry errchan config_retry_after
 409     ldebug {} "rechecking configuration etc"
 410     foreach ch [array names onchans] {
 411         manyset $onchans($ch) status after
 412         if {"$status" == "shortly"} {
 413             catch { after cancel $after }
 414         }
 415         set onchans($ch) mustleave
 416     }
 417     sendout JOIN $errchan
 418     chan_shortly $errchan
 419     foreach m [list_objs monitor] {
 420         upvar #0 monitor/$m mm
 421         foreach ch $mm(chans) {
 422             sendout JOIN $ch
 423             chan_shortly $ch
 424         }
 425     }
 426     foreach ch [array names onchans] {
 427         if {"[lindex $onchans($ch) 0]" != "mustleave"} continue
 428         sendout PART $ch
 429         unset onchans($ch)
 430     }
 431     catch { after cancel $config_retry_after }
 432     set config_retry_after [after $chans_retry config_change]
 433 }
 434
 435 proc allchans_shortly {} {
 436     global onchans
 437     foreach ch [array names onchans] { chan_shortly $ch }
 438 }
 439
 440 proc chan_shortly {ch} {
 441     global chan_after
 442     set ch [irctolower $ch]
 443     upvar #0 onchans($ch) oc
 444     if {[info exists oc]} {
 445         manyset $oc status after
 446         if {"$status" == "shortly"} {
 447             ldebug c$ch "queued check already pending"
 448             return
 449         }
 450     }
 451     ldebug c$ch "queueing check"
 452     set oc [list shortly [after $chan_after chan_sendnames $ch]]
 453 }
 454
 455 proc msg_353 {p c dest type chan nicklist} {
 456     set lchan [irctolower $chan]
 457     set nll [irctolower $nicklist]
 458     regsub -all {[=@*]} $nll {} nll
 459     ldebug c$lchan "all names: $nll"
 460     foreach m [list_objs monitor] {
 461         mon_gotchanlist $m $lchan $nll
 462     }
 463 }
 464
 465 proc chan_sendnames {ch} {
 466     upvar #0 onchans($ch) oc
 467     ldebug c$ch "asking for namelist"
 468     sendout NAMES $ch
 469     set oc idle
 470 }
 471
 472 def_ucmd reload {
 473     set username [ta_word]
 474     ta_nomore
 475     set m [reloaduser $username]
 476     config_change
 477     ucmdr {} $m
 478 }
 479
 480 proc debug_reset {} {
 481     global debugusers debug_cancelling
 482     unset debug_cancelling
 483     set debugusers {}
 484     reporterr "debug mode timed out"
 485 }
 486
 487 def_ucmd debug {
 488     prefix_nick
 489     global debugusers debug_cancelling debug_reset_after
 490     if {![string length $text]} { error "must give list of usernames" }
 491     llength $text
 492     set debugusers $text
 493     catch { after cancel $debug_cancelling }
 494     set debug_cancelling [after $debug_reset_after debug_reset]
 495     reporterr "debug enabled by $n: $debugusers"
 496 }
 497
 498 def_ucmd nodebug {
 499     prefix_nick
 500     ta_nomore
 501     global debugusers debug_cancelling
 502     set debugusers {}
 503     catch { after cancel $debug_cancelling }
 504     catch { unset debug_cancelling }
 505     reporterr "debug disabled by $n"
 506 }
 507
 508 proc_dset visibledest {} {
 509     regsub {\:[^:]*/} $d/ { } p
 510     regsub {^([^:]+)\:\d+\:} $p {\1, } p
 511     regsub { $} $p {} p
 512     return $p
 513 }
 514
 515 def_ucmd who {
 516     set r {}
 517     foreach m [list_objs monitor] {
 518         upvar #0 monitor/$m mm
 519         lappend r "monitoring $mm(chans) for $m"
 520     }
 521     foreach d [list_objs deviceset] {
 522         upvar #0 deviceset/$d dd
 523         set m $dd(monname)
 524         upvar #0 monitor/$m mm
 525         if {![info exists mm(chans)]} continue
 526         lappend r "sending $m to [dset_visibledest $d]"
 527     }
 528     ucmdr [join $r "\n"] {}
 529 }
 530
 531 proc connected {} {
 532     ldebug {} "connected"
 533     foreach f [glob -nocomplain pwdb/p*] {
 534         regexp {^pwdb/p(.*)$} $f dummy username
 535         set m [reloaduser $username]
 536     }
 537     config_change
 538 }
 539
 540 proc warn_pref {n} {
 541     set nl [irctolower $n]
 542     set l {}
 543     foreach d [list_objs deviceset] {
 544         upvar #0 deviceset/$d dd
 545         set m $dd(monname)
 546         upvar #0 monitor/$m mm
 547         if {![info exists mm(prefer)]} continue
 548         if {![mon_nick_is $mm(prefer) $nl]} continue
 549         foreach ch $mm(chans) { set wch($ch) 1 }
 550         lappend l [dset_visibledest $d]
 551     }
 552     if {[llength $l]} {
 553         sendprivmsg $nl "LEDs are watching you on [\
 554                 join [lsort [array names wch]] ","]: [join $l " "]"
 555     }
 556 }
 557
 558 proc msg_JOIN {p c chan} {
 559     prefix_nick
 560     set nl [irctolower $n]
 561     chan_shortly $chan
 562     warn_pref $n
 563 }
 564 proc msg_PART {p c chan} { chan_shortly $chan }
 565 proc msg_KILL {p c user why} { allchans_shortly }
 566 proc msg_QUIT {p c why} { allchans_shortly }
 567 proc msg_NICK {p c newnick} { allchans_shortly; warn_pref $newnick }
 568 proc msg_KICK {p c chans users comment} {
 569     if {[llength $chans] > 1} {
 570         allchans_shortly
 571     } else {
 572         chan_shortly [lindex $chans 0]
 573     }
 574 }
 575
 576 if {[catch {
 577     loadhelp
 578     ensure_connecting
 579 } emsg]} {
 580     fail "startup: $emsg"
 581 }