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