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 # variables
  43 #
  44 #   monitor/$monname(chans)           -> [list $chan1 $chan2 ...]
  45 #   monitor/$monname(ignore)          -> [list $regexp ...]
  46 #   monitor/$monname(prefer)          -> [list $regexp ...]
  47 #   monitor/$monname(present)         -> [list $lnick ...]
  48 #   monitor/$monname(last-talk)       -> $time_t
  49 #   monitor/$monname(last-talkpref)   -> $time_t
  50 #   monitor/$monname(time-recent)     -> $seconds
  51 #   monitor/$monname(time-recentnow)  -> $seconds
  52 #
  53 #   deviceset/$username:$lno(monname)  -> $monname
  54 #   deviceset/$username:$lno(group)    -> $led_group
  55 #   deviceset/$username:$lno(username) -> $username
  56 #   deviceset/$username:$lno(states)   -> [list $state1 $value1 $state2 ...]
  57 #   deviceset/$username:$lno(fchan)    -> [open remoteleds ... |]  or unset
  58 #   deviceset/$username:$lno(retry)    -> [after ... ]             or unset
  59 #
  60 #   onchans($chan)        [list mustleave]                 # in config_chane
  61 #   onchans($chan)        [list idle]
  62 #   onchans($chan)        [list forced]                    # for errchan
  63 #   onchans($chan)        [list shortly [after ...]]       # do a NAMES
  64
  65 proc list_objs {vp} {
  66     set l {}
  67     foreach v [info globals] {
  68         if {![regsub ^$vp/ $v {} v]} continue
  69         lappend l $v
  70     }
  71     return $l
  72 }
  73
  74 proc privmsg_unlogged {p ischan params} {
  75     global errorInfo
  76     if {!$ischan} { return 0 }
  77
  78     # on-channel message
  79     if {[catch {
  80         prefix_nick
  81         foreach m [list_objs monitor] {
  82             mon_speech $m [irctolower [lindex $params 0]] [irctolower $n]
  83         }
  84     } emsg]} {
  85         log "processing error: $emsg\n$errorInfo"
  86     }
  87     return 1;
  88 }
  89
  90 proc reporterr {m} {
  91     global errchan
  92     sendprivmsg $errchan $m
  93 }
  94
  95 proc msg_PRIVMSG {p c dest text} {
  96     global errchan
  97     prefix_nick
  98     execute_usercommand $p $c $n $errchan $dest $text
  99 }
 100
 101 proc proc_mon {name argl body} {
 102     proc mon_$name [concat m $argl] "
 103     upvar #0 monitor/\$m mm
 104     $body"
 105 }
 106
 107 proc mon_nick_is {globlist ln} {
 108     foreach gl $globlist {
 109         if {[string match $gl $ln]} { return 1 }
 110     }
 111     return 0
 112 }
 113
 114 proc_mon speech {chan ln} {
 115     if {[lsearch -exact $mm(chans) $chan] == -1} return
 116     if {[mon_nick_is $mm(ignore) $ln]} return
 117     set now [clock seconds]
 118     set mm(last-talk) $now
 119     if {[mon_nick_is $mm(prefer) $ln]} { set mm(last-talkpref) $now }
 120     mon_updateall $m
 121 }
 122
 123 proc_mon calcstate {} {
 124     set s " "
 125     if {[llength $mm(present)]} { append s "present " }
 126     set now [clock seconds]
 127     foreach p {{} pref} {
 128         foreach t {{} now} {
 129             set since [expr {$now - $mm(time-recent$t)}]
 130             if {[expr {$mm(last-talk$p) < $since}]} continue
 131             append s "${p}talk${t} "
 132         }
 133     }
 134     return $s
 135 }
 136
 137 proc_mon updateall {} {
 138     set s [mon_calcstate $m]
 139     foreach d [list_objs deviceset] {
 140         upvar #0 deviceset/$d dd
 141         if {[string compare $m $dd(monname)]} continue
 142         dset_setbystate $d $s
 143     }
 144 }
 145
 146 proc_mon destroy {} {
 147     catch { unset mm }
 148 }
 149
 150 proc proc_dset {name argl body} {
 151     proc dset_$name [concat d $argl] "
 152     upvar #0 deviceset/\$d dd
 153     if {\[catch {
 154         $body
 155     } emsg\]} {
 156         reporterr \"error on \$d: \$emsg\"
 157     }"
 158 }
 159
 160 proc timed_log {m} {
 161     log "[clock seconds] $m"
 162 }
 163
 164 proc_dset setbystate {s} {
 165     set lv {}
 166     foreach {sq v} $s {
 167         if {![string match *$sq* $s]} continue
 168         set lv $v; break
 169     }
 170     timed_log "->$d $lv"
 171     puts $dd(fchan) $lv
 172 }
 173
 174 proc_dset destroy {} {
 175     catch { after cancel $dd(retry) }
 176     catch {
 177         if {[info exists dd(fchan)]} { timed_log ">\$$d destroy" }
 178         close $dd(fchan)
 179     }
 180     catch { unset dd }
 181 }
 182
 183 proc reloaduser {username} {
 184     check_username $username
 185     if {[catch {
 186         set cfg [exec userv --timeout 3 $username irc-ledcontrol-config \
 187                 < /dev/null]
 188     } emsg]} {
 189         regsub "\n" $emsg " // " emsg
 190         reporterr "error reloading $username: $emsg"
 191         return ""
 192     }
 193     foreach d [list_objs deviceset] {
 194         if {![string match $username:* $d]} continue
 195         dset_destroy $d
 196     }
 197     foreach m [list_objs monitor] {
 198         if {![string match $username* $m]} continue
 199         mon_destroy $m
 200     }
 201     if {![string length $cfg]} {
 202         file remove pwdb/$username
 203         return "no config from $username"
 204     } elseif {[catch {
 205         exec userv --timeout 3 $username irc-ledcontrol-passwords \
 206                 < /dev/null > pwdb/p$username
 207     } emsg]} {
 208         reporterr "error reading passwords for $username: $emsg"
 209         return ""
 210     } elseif {[catch {
 211         foreach cv {ignore nopresence prefer} { set cc($cv) {} }
 212         set cc(time-recentnow) 120
 213         set cc(time-recent) 450
 214         set lno 0
 215         foreach l [split $cfg "\n"] {
 216             incr lno
 217             set l [string trim $l]
 218             if {[regexp {^\#} $l]} {
 219             } elseif {[regexp {^nick\s+(ignore|nopresence|prefer)\s+(\S.*)$} \
 220                     $l dummy kind globs]} {
 221                 set cc($kind) {}
 222                 foreach gl [split $globs " "] {
 223                     if {![string length $gl]} continue
 224                     string match $gl {}
 225                     lappend cc($kind) $gl
 226                 }
 227             } elseif {[regexp {^times\s+(\d+)\s+(\d+)$} $l dummy r rnow]} {
 228                 foreach cv {{} now} { set cc(time-recent$cv) [set r$cv] }
 229             } elseif {[regexp {^monitor\s+(\S+)\s+(\S.*)$} $l dummy m cl]} {
 230                 set cc(chans) {}
 231                 if {![string match $username:* $m]} {
 232                     error "monname must start with $username:"
 233                 }
 234                 check_monname $m
 235                 foreach ch [split $cl " "] {
 236                     if {![string length $ch]} continue
 237                     check_chan $ch
 238                     if {![ischan $ch]} { error "invalid channel $ch" }
 239                     lappend cc(chans) [irctolower $ch]
 240                     chan_shortly $ch
 241                 }
 242                 upvar #0 monitor/$m mm
 243                 foreach cv [array names cc] { set mm($cv) $cc($cv) }
 244                 foreach cv {{} pref} { set mm(last-talk$cv) 0 }
 245                 set mm(present) {}
 246             } elseif {[regexp \
 247  {^leds\s+([0-9A-Za-z][-:/0-9A-Za-z]+)\s+(\S+)\s+(\S+.*)$} \
 248                     $l dummy g m states]} {
 249                 set d $username:$lno:$g
 250                 set sl {}
 251                 check_monname $m
 252                 foreach sv [split $states " "] {
 253                     if {![string length $sv]} continue
 254                     if {![regexp \
 255  {^((pref)?talk(now)?|present|default)\=([0-9a-z][,/+0-9A-Za-z]*)$} \
 256                           $sv dummy lhs dummy dummy rhs]} {
 257                         error "invalid state spec"
 258                     }
 259                     lappend sl $lhs $rhs
 260                 }
 261                 upvar #0 deviceset/$d dd
 262                 set dd(monname) $m
 263                 set dd(states) $sl
 264                 set dd(group) $g
 265                 set dd(username) $username
 266                 dset_start $d
 267             }
 268         }
 269     } emsg]} {
 270         reporterr "setup error $username:$lno:$emsg"
 271         return ""
 272     } else {
 273         return "reloaded $username"
 274     }
 275 }
 276
 277 proc check_monname {m} {
 278     if {[regexp {[^-_+:.#0-9a-zA-Z]} $m badchar]} {
 279         error "char $badchar not allowed in monnames"
 280     }
 281     if {![regexp {^[0-9a-zA-Z]} $m]} {
 282         error "monname must start with alphanum"
 283     }
 284 }
 285
 286 proc_dset start {} {
 287     catch { unset dd(retry) }
 288     set username $dd(username)
 289     if {[catch {
 290         set cmdl [list remoteleds --pipe $dd(group) \
 291                        --passfile-only pwdb/p$username]
 292         timed_log "!-$d [join $cmdl " "]"
 293         set fchan [open |[concat $cmdl {|& cat}] r+]
 294         fconfigure $fchan -blocking 0
 295         fileevent $fchan readable [list dset_rledout $d]
 296         set dd(fchan) $fchan
 297     } emsg]} {
 298         reporterr "remoteleds startup $d: $emsg"
 299         dset_trylater $d
 300     }
 301 }
 302
 303 proc_dset rledout {} {
 304     global errchan
 305     while {[gets $dd(fchan) l] != -1} { reporterr "remoteleds on $d: $l" }
 306     if {[fblocked $dd(fchan)]} return
 307     catch {
 308         timed_log ">\$$d failure";
 309         close $dd(fchan)
 310     }
 311     unset dd(fchan)
 312     reporterr "remoteleds on $d died"
 313     dset_trylater $d
 314 }
 315
 316 proc_dset trylater {} {
 317     global retry_after
 318     set dd(retry) [after $retry_after [list dset_start $d]]
 319 }
 320
 321 proc config_change {} {
 322     global onchans chans_retry errchan
 323     foreach ch [array names onchans] {
 324         manyset $onchans($ch) status after
 325         if {"$status" == "shortly"} {
 326             catch { after cancel $after }
 327         }
 328         set onchans($ch) mustleave
 329     }
 330     sendout JOIN $errchan
 331     chan_shortly $errchan
 332     foreach m [list_objs monitor] {
 333         upvar #0 monitor/$m mm
 334         foreach ch $mm(chans) {
 335             sendout JOIN $ch
 336             chan_shortly $ch
 337         }
 338     }
 339     foreach ch [array names onchans] {
 340         if {"[lindex $onchans($ch) 0]" != "mustleave"} continue
 341         sendout PART $ch
 342         unset onchans($ch)
 343     }
 344     after $chans_retry config_change
 345 }
 346
 347 proc chan_shortly {ch} {
 348     global chan_after
 349     upvar #0 onchans($ch) oc
 350     if {[info exists oc]} {
 351         manyset $oc status after
 352         if {"$status" == "shortly"} return
 353     }
 354     set oc [list shortly [after $chan_after chan_sendnames $ch]]
 355 }
 356
 357 proc chan_sendnames {ch} {
 358     upvar #0 onchans($ch) oc
 359     sendout NAMES $ch
 360     set oc idle
 361 }
 362
 363 def_ucmd reload {
 364     set username [ta_word]
 365     ta_nomore
 366     set m [reloaduser $username]
 367     config_change
 368     ucmdr {} $m
 369 }
 370
 371 def_ucmd who {
 372     set r {}
 373     foreach m [list_objs monitor] {
 374         upvar #0 monitor/$m mm
 375         lappend r "monitoring $mm(chans) for $m"
 376     }
 377     foreach d [list_objs deviceset] {
 378         upvar #0 deviceset/$d dd
 379         regexp {^[^:]*\:[^:]*} $dd(group) dest
 380         lappend r "sending $dd(monname) to $dest"
 381     }
 382 }
 383
 384 proc connected {} {
 385     foreach f [glob -nocomplain pwdb/p*] {
 386         regexp {^pwdb/p(.*)$} $f dummy username
 387         set m [reloaduser $username]
 388     }
 389     config_change
 390 }
 391
 392 # fixme
 393 # 353
 394 # JOIN PART
 395 # KICK KILL QUIT
 396
 397 if {[catch {
 398     loadhelp
 399     ensure_connecting
 400 } emsg]} {
 401     fail "startup: $emsg"
 402 }