X-Git-Url: https://git.distorted.org.uk/~mdw/ircbot/blobdiff_plain/31eadeb5d4f9ad2482f1fcda1e3db21d09453b5e..0ba5cc805c8f3cc7f3b539f3fd5f933c7ca42e99:/bot.tcl diff --git a/bot.tcl b/bot.tcl index 315163f..06f0b7c 100755 --- a/bot.tcl +++ b/bot.tcl @@ -26,22 +26,47 @@ proc showintervalsecs {howlong abbrev} { return [showintervalsecs/[opt timeformat] $howlong $abbrev] } +proc formatsf {pfx value} { + foreach {min format} { 100 %.0f 10 %.1f 0 %.2f} { + set fval [format $format $value] + if {$fval < $min} continue + return [format "$fval${pfx}" $value] + } +} + +proc showintervalsecs/beat {howlong abbrev} { + # We split in two to avoid overflow problems. + if {$howlong < 86 } { + # mB's + set pfx mB + return [format "%.0fmB" [expr {round($howlong * 1.157)*10} ]] + } else { + if {$howlong < 86400 } { + # B's + set pfx B + set value [expr {$howlong / 86.4}] + } else { + # kB's + set pfx kB + set value [expr {$howlong / 86400.0}] + } + } + return [formatsf $pfx $value] +} + proc showintervalsecs/ks {howlong abbrev} { if {$howlong < 1000} { return "${howlong}s" } else { if {$howlong < 1000000} { - set pfx k + set pfx ks set scale 1000 } else { - set pfx M + set pfx Ms set scale 1000000 } set value [expr "$howlong.0 / $scale"] - foreach {min format} {100 %.0f 10 %.1f 1 %.2f} { - if {$value < $min} continue - return [format "$format${pfx}s" $value] - } + return [formatsf $pfx $value] } } @@ -95,10 +120,13 @@ proc parse_interval {specified min} { ks { set u 1000 } m { set u 60 } h { set u 3600 } + mb { set u 0.0864 } + b { set u 86.4 } + kb { set u 86400 } default { error "unknown unit of time $unit" } } if {$value > 86400*21/$u} { error "interval too large" } - set result [expr {$value*$u}] + set result [expr {round($value*$u)}] if {$result < $min} { error "interval too small (<${min}s)" } return $result } @@ -145,11 +173,34 @@ proc looking_whenwhere {when where} { return $str } +proc tell_getcstate {} { + # uses nl from caller's context + # imports telling (as the nick_telling) and u + # sets stt, telling_when + uplevel 1 { + upvar #0 nick_telling($nl) telling + upvar #0 nick_unique($nl) u + + if {[info exists telling]} { + manyset $telling u_last stt telling_when + if {![info exists u] || "$u_last" != "$u"} { + set stt undelivered + } + } else { + set stt undelivered + set telling_when 0 + } + } +} + proc tell_event {nl event} { # For `act' we *haven't* yet done the 750ms delay; we implement # that here. Also, here we turn `talk' into `talk' now and `act' # later. We also support the psuedo-event `none'. The del msg # and new msg events are handled by the command procedures, not here. + global calling_nick + if {[info exists calling_nick]} { set save $calling_nick } + set r DELAYED switch -exact $event { none { } talk { @@ -159,58 +210,64 @@ proc tell_event {nl event} { act { after 750 [list tell_event_core $nl $event] } - ident { + ident - msgsarrive { tell_event_core $nl $event } + tellme { + set r [tell_event_core $nl TELLME] + } default { error "tell_event $nl $event" } } + if {[info exists save]} { set calling_nick $save } + return $r } proc tell_event_core {nl event} { - # event is `talk', `act' or `ident' - # When user talks we actually get talk now and act later -FIXME - implement all cmds -FIXME - implement pass stuff set stt [list $u passed $now] -FIXME - implement tells_delete_msgs catch { unset stt } ? -FIXME - document the extra param to recordlastseen - set iml [msgdb_get $nl inbound] - if {![llength $iml]} return - - upvar #0 nick_telling($nl) telling - upvar #0 nick_unique($nl) u - - if {[info exists telling]} { - manyset $telling u_last stt telling_when - if {![info exists u] || "$u_last" != "$u"} { - unset telling; unset stt; unset telling_when - } + global tell_event_teventi errorInfo + set tell_event_teventi "*$event* $nl" + if {[catch { + tell_event_core1 $nl $event + } emsg]} { + log_intern "tell event error" "$emsg >$errorInfo<" + set emsg ERROR + } else { + log_intern "tell event" "done $tell_event_teventi $emsg" } + return $emsg +} - if {![info exists stt]} { - set stt norecord - set telling_when $now - } +proc tell_event_core1 {nl event} { + # event is `talk', `act', `ident', `msgsarrive' or `TELLME' + # When user talks we actually get talk now and act later + global calling_nick + set calling_nick $nl + set iml [msgsdb_get $nl inbound] + if {![llength $iml]} { return nomsgs } + set now [clock seconds] + tell_getcstate set ago [expr {$now - $telling_when}] # Now we have the components of a telling state # u - nick_unique (unset if not visible) - # stt - state: norecord, mentioned, passede + # stt - state: undelivered, mentioned, passede # ago - how long ago since we did anything # We compute an evstate to dispatch on as follows: # evstate is string of letters # current state - # n NORECORD (MESSAGES) + # u UNDELIVERED (MESSAGES) # m MENTIONED # p PASSED # event # t talk # a act # i ident + # m msgsarrive + # T tellme (user command) # security level and timing # ii Insecure # ss Secure and soon (before interval) @@ -231,21 +288,21 @@ FIXME - document the extra param to recordlastseen append evstate [string range $stt 0 0] append evstate [string range $event 0 0] - manyset [nickdb_get $n tellsec] sec secwhen + manyset [nickdb_get_sec_effective $nl] sec secwhen switch -exact $sec { insecure { append evstate ii } - secure { append evstate [expr {$ago<$secwhen ? "sl" : "ss"}] } + secure { append evstate [expr {$ago<$secwhen ? "ss" : "sl"}] } default { append evstate "#$sec#" } } upvar #0 nick_username($nl) nu - if {[info exists nu] && "$nu" == "[nickdb_get $nl username]"} { + if {[info exists nu] && "$nu" == "[nickdb_get_username $nl]"} { append evstate i } else { append evstate u } - manyset [nickdb_set $n tellrel] rel relint relwithin + manyset [nickdb_get $nl tellrel] rel relint relwithin switch -exact $rel { unreliable { append evstate uu } remind { append evstate [expr { @@ -255,50 +312,98 @@ FIXME - document the extra param to recordlastseen default { append evstate "#$rel#" } } + global tell_event_teventi + set tell_event_teventi "$evstate $ago $nl" switch -glob $evstate { pt???rv { # consider delivered: # (very recently passed, and the user talks) - tell_delete_msgs {} $nl - return + set ndel [tell_delete_msgs {} $nl] + sendprivmsg $nl \ + "I'm assuming you got the $ndel message(s) I just passed on." + return delivered + } + pm????? { + # oops, messages passed are now out of date + catch_restoreei { unset telling } + return reset } - nt????? - mt????? - + ?m????? { + # ignore new msgs if we haven't passed yet + return ignorenew + } + ut????? - mt????? - pt???uu - pt???rs - pt???rl - pt???p? { # ignore (any other `talk's) - act handles these - return + return ignoretalk } - ni????? - naii??? - nas?i?? - mi????? - pa????l { + ui????? - + uaii?uu - uaii??l - uas?iuu - uas?i?l - + mi????? - pa????l - + ?Tii??? - ?Ts?i?? { # pass and then stuff - - - return + if {[llength $iml] == 3} { + manyset $iml sender sentwhen msg + sendprivmsg $nl \ + "$sender asked me, [showinterval [expr {$now-$sentwhen}]],\ + to tell you: $msg" + } else { + sendprivmsg $nl \ + "I have [expr {[llength $iml]/3}] messages for you:" + while {[llength $iml] >= 3} { + manyset [lrange $iml 0 2] sender sentwhen msg + set iml [lrange $iml 3 end] + sendprivmsg $nl \ + " [showintervalsecs [expr {$now-$sentwhen}] 1] <$sender> $msg" + } + } + if {"$rel" == "unreliable"} { + tell_delete_msgs {} $nl + return toldunreliable + } + set stt passed + set re passed } - nas?u?? { - sendprivmsg $nl {You have messages (so identify yourself please).}] + uaslu?? { + sendprivmsg $nl {You have messages (so identify yourself please).} set stt mentioned + set re mentioned + } + ?Ts?u?? { + sendprivmsg $nl {You must identify yourself to see your messages.} + return ignoreuitm } masl??? { - sendprivmsg $nl {Don't forget about your messages.}] + sendprivmsg $nl {Don't forget about your messages.} + return remind } pi????? { - return + return ignorepi } - mass??? - pa????v - pa????s { + mass??? - pa????v - pa????s - + uaii??v - uaii??s - + uas?i?v - uas?i?s - + uassu?? { # too soon - return + return ignoresoon } * { error "tell_event_core nl=$nl evstate=$evstate ?" } } if {![info exists u]} { - catch { unset telling } + set telling [list {} undelivered $now] } else { set telling [list $u $stt $now] } + return $re } proc recordlastseen_n {n how here} { + # here is: + # 0 - nick was seen leaving (or changing to another nicks or some such) + # 1 - nick was seen doing something else + # 2 - nick was seen talking on channel global lastseen lookedfor set nl [irctolower $n] set now [clock seconds] @@ -396,8 +501,8 @@ proc chanmode_o1 {m g p chan} { } else { set chan_initialop([irctolower $chan]) $u sendprivmsg $n \ - "Thanks. You can use `channel manager ...' to register this channel." - if {![nickdb_exists $n] || ![string length [nickdb_get $n username]]} { + "Thanks. You can use `channel manager ...' to register this channel." + if {![string length [nickdb_get_username $n username]]} { sendprivmsg $n \ "(But to do that you must register your nick securely first.)" } @@ -746,14 +851,9 @@ def_somedb_id delete {} { set default_settings_nick { timeformat ks marktime off - tellsec insecure + tellsec {secure 600} tellrel {remind 3600 30} } -# also: -# inbound: concatenation of many sender time_t text -# outbound: concatenation of many recipient time_t count -# neither are sorted particularly; only one entry per recipient in -# output; both sender and recipient are cased set default_settings_chan { autojoin 1 @@ -770,6 +870,8 @@ set default_settings_msgs { } # inbound -> [ ] ... # outbound -> [ ] ... +# neither are sorted particularly; only one entry per recipient in +# output; both sender and recipient are cased def_somedb_id set {args} { upvar #0 default_settings_$nickchan def @@ -1102,8 +1204,7 @@ def_ucmd invite { } set invitees {} while {[ta_anymore]} { - set invitee [ta_word] - check_nick $invitee + set invitee [ta_nick] lappend invitees $invitee } foreach invitee $invitees { @@ -1164,18 +1265,164 @@ def_ucmd channel { channel/$subcmd } +proc nickdb_get_username {n} { + if {![nickdb_exists $n]} { return "" } + return [nickdb_get $n username] +} + +proc nickdb_get_sec_effective {n} { + set l [nickdb_get $n tellsec] + set u [nickdb_get_username $n] + if {"[lindex $l 0]" == "secure" && ![string length $u]} { set l insecure } + return $l +} + +proc tell_peernicks {text} { + global errorInfo errorCode + set text [irctolower [string trim $text]] + set senders [split $text " "] + foreach sender $senders { + if {[catch { check_nick $sender } emsg]} { + error "invalid nick `$sender': $emsg" $errorInfo $errorCode + } + } + return $senders +} + +proc msgsdb_set_maydelete {n key l otherkey} { + msgsdb_set $n $key $l + if {[llength $l]} return + if {[llength [msgsdb_get $n $otherkey]]} return + msgsdb_delete $n +} + +proc tell_delete_msgs {lsenders lrecip} { + set ninbound {} + set ndel 0 + foreach {s t m} [msgsdb_get $lrecip inbound] { + if {[llength $lsenders]} { + if {[lsearch -exact $lsenders [irctolower $s]] == -1} { + lappend ninbound $s $t $m + continue + } + } + set rsenders($s) 1 + incr ndel + } + msgsdb_set_maydelete $lrecip inbound $ninbound outbound + if {![llength $ninbound]} { + upvar #0 nick_telling($lrecip) telling + catch { unset telling } + } + foreach s [array names rsenders] { + set noutbound {} + foreach {r t c} [msgsdb_get $s outbound] { + if {"[irctolower $r]" == "$lrecip"} continue + lappend noutbound $r $t $c + } + msgsdb_set_maydelete $s outbound $noutbound inbound + } + return $ndel +} + +def_ucmd untell { + prefix_nick + check_notonchan + if {[nickdb_exists $n]} { nick_securitycheck 0 } + set recipients [tell_peernicks $text] + if {![llength $recipients]} { + usererror "You must say which recipients' messages from you to forget." + } + set ndel 0 + foreach recip $recipients { + incr ndel [tell_delete_msgs [irctolower $n] $recip] + } + ucmdr "Removed $ndel as yet undelivered message(s)." {} +} + +def_ucmd_alias delmsgs delmsg +def_ucmd delmsg { + global errorInfo errorCode + prefix_nick + set nl [irctolower $n] + check_notonchan + manyset [nickdb_get_sec_effective $n] sec secwhen + switch -exact $sec { + insecure { } + reject - mailto { + usererror \ + "There are no messages to delete\ + because your message disposition prevents them from being left." + } + secure { + nick_securitycheck 1 + } + default { + error "delmsg sec $sec" + } + } + if {![llength [msgsdb_get $n inbound]]} { + ucmdr "No incoming messages to delete." {} + } + tell_getcstate + if {![info exists u]} { + usererror \ + "I can't delete your messages unless I can see you on a channel with me.\ + Otherwise I might delete a message I hadn't told you about yet." + } + if {"$stt" != "passed"} { + set telling [list $u undelivered 0] + usererror \ + "There are message(s) you may not yet have seen;\ + I'll deliver them to you now.\ + If you actually want to delete them, just tell me `delmsg' again." + } + set senders [tell_peernicks $text] + set ndel [tell_delete_msgs [irctolower $senders] [irctolower $n]] + if {!$ndel} { + if {[llength $senders]} { + ucmdr "No relevant incoming messages to delete." {} + } + } + switch -exact [llength $senders] { + 0 { ucmdr {} {} "deletes your $ndel message(s)." } + 1 { ucmdr {} {} "deletes your $ndel message(s) from $senders." } + default { + ucmdr {} {} "deletes your $ndel message(s) from\ + [lreplace $senders end end] and/or [lindex $senders end]." + } + } +} + +def_ucmd tellme { + prefix_nick + ta_nomore + check_notonchan + manyset [nickdb_get $n tellsec] sec + switch -exact $sec { + reject { ucmdr "But, you asked me to reject messages for you !" {} } + mailto { ucmdr "But, you asked me to mail your messages to you !" {} } + } + switch -exact [tell_event [irctolower $n] tellme] { + ERROR - INVALID { ucmdr {} {is ill. Help!} } + nomsgs { ucmdr {You have no messages.} {} } + default { } + } +} + def_ucmd tell { global nick_case ownmailaddr ownfullname prefix_nick - set target [ta_word] + set target [ta_nick] if {![string length $text]} { error "tell them what?" } + if {[string length $text] > 400} { error "message too long" } set ltarget [irctolower $target] set ctarget $target if {[info exists nick_case($ltarget)]} { set ctarget $nick_case($ltarget) } - manyset [nickdb_get $target tellsec] sec mailtoint mailwhy + manyset [nickdb_get_sec_effective $target] sec mailtoint mailwhy manyset [nickdb_get $target tellrel] rel relint relwithin switch -exact $sec { insecure - secure { @@ -1216,6 +1463,7 @@ def_ucmd tell { } } append msg . + tell_event $ltarget msgsarrive ucmdr $msg {} } mailto { @@ -1236,7 +1484,7 @@ $n asked me[expr {[ischan $dest] ? " on $dest" : ""}] to tell you: "I've mailed $ctarget, which is what they prefer." \ {} } - refuse { + reject { usererror "Sorry, $ctarget does not want me to take messages." } default { @@ -1247,7 +1495,7 @@ $n asked me[expr {[ischan $dest] ? " on $dest" : ""}] to tell you: def_ucmd who { if {[ta_anymore]} { - set target [ta_word]; ta_nomore + set target [ta_nick]; ta_nomore set myself 1 } else { prefix_nick @@ -1325,6 +1573,7 @@ proc timeformat_desc {tf} { switch -exact $tf { ks { return "Times will be displayed in seconds or kiloseconds." } hms { return "Times will be displayed in hours, minutes, etc." } + beat { return "Times will be displayed in beats (1000B = 1d)." } default { error "invalid timeformat: $v" } } } @@ -1345,17 +1594,24 @@ proc def_setting {opt show_body set_body} { $set_body" } -proc tellme_sec_desc {v} { +proc tellme_sec_desc {v n} { manyset $v sec mailtoint switch -exact $sec { insecure { return "I'll tell you your messages whenever I see you." } secure { - return \ + if {[string length [nickdb_get_username $n]]} { + return \ "I'll keep the bodies of your messages private until you identify yourself, reminding you every [showintervalsecs $mailtoint 1]." + } else { + return \ + "I'll tell you your messages whenever I see you.\ + (Secure message delivery is enabled, but your nick is not registered\ + securely. See `help register'.)" + } } - refuse { + reject { return "I shan't accept messages for you." } mailto { @@ -1367,11 +1623,12 @@ proc tellme_sec_desc {v} { } } -proc tellme_rel_desc {v} { +proc tellme_rel_desc {v n} { manyset $v rel every within switch -exact $rel { unreliable { - return "As soon as I've told you, I'll forget the message - note that this means messages can get lost !" + return "As soon as I've told you message(s), I'll forget them\ + - note that this means messages can get lost !" } pester { set u {} @@ -1383,7 +1640,8 @@ proc tellme_rel_desc {v} { error "bad tellrel $rel" } } - return "I'll remind you every [showintervalsecs $every 1] until you say delmsg$u." + return "After delivering messages, I'll remind you every\ + [showintervalsecs $every 1] until you say delmsg$u." } def_setting timeformat { @@ -1437,57 +1695,82 @@ def_setting security { } } {} +proc tellme_setting_sec_simple {} { + uplevel 1 { + ta_nomore + set sr sec + set v $setting + } +} + +proc tellme_setting_neednomsgs {} { + uplevel 1 { + if {[llength [msgsdb_get $n inbound]]} { + usererror "You must delete the incoming messages you have, first." + } + } +} + def_setting tellme { set secv [nickdb_get $n tellsec] - set ms [tellme_sec_desc $secv] + set ms [tellme_sec_desc $secv $n] manyset $secv sec switch -exact $sec { insecure - secure { - set mr [tellme_rel_desc [nickdb_get $n tellrel]] + set mr [tellme_rel_desc [nickdb_get $n tellrel] $n] return "$ms $mr" } - refuse - mailto { + reject - mailto { return $ms } } } { set setting [string tolower [ta_word]] + set nl [irctolower $n] switch -exact $setting { - insecure - secure - refuse { + insecure { + tellme_setting_sec_simple + } + secure { + set every [ta_interval_optional 60 600] ta_nomore - if {"$setting" == "refuse" && [llength [msgsdb_get $n inbound]]} { - usererror "You must delete the messages you have, first." - } set sr sec - set v $setting + set v [list secure $every] + } + reject { + tellme_setting_neednomsgs + tellme_setting_sec_simple } mailto { - set u [nickdb_get $n username] - if {![string length $u]} { - usererror "Sorry, you must register secure to have your messages mailed (to prevent the use of this feature for spamming)." + tellme_setting_neednomsgs + + upvar #0 nick_username($nl) nu + if {!([info exists nu] && [string length $nu])} { + usererror \ + "Sorry, you must register securely to have your messages mailed\ + (to prevent the use of this feature for spamming). See `help register'." } set sr sec - set v [list mailto [ta_word] $u] + set v [list mailto [ta_word] $nu] } unreliable - pester - remind { manyset [nickdb_get $n tellsec] sec switch -exact $sec { - refuse - mailto { - error "can't change message delivery conditions when message disposition prevents messages from being left" + reject - mailto { + usererror \ + "Sorry, I shan't change when I'll consider a message delivered, because\ + you've asked me not to keep messages, or to mail them to you.\ + You should say `set tellme secure' or some such, first." } } set sr rel set v $setting if {"$setting" != "unreliable"} { - set every [parse_interval [ta_word] 300] + set every [ta_interval_optional 300 3600] lappend v $every } if {"$setting" == "remind"} { - if {[ta_anymore]} { - set within [parse_interval [ta_word] 5] - } else { - set within 30 - } + set within [ta_interval_optional 5 30] if {$within > $every} { error "remind interval must be at least time to respond" } @@ -1500,14 +1783,16 @@ def_setting tellme { } } nickdb_set $n tell$sr $v - ucmdr [tellme_${sr}_desc $v] {} + upvar #0 nick_telling($nl) telling + catch { unset telling } + ucmdr [tellme_${sr}_desc $v $n] {} } proc lnick_checktold {luser} { set ml [msgsdb_get $luser outbound] if {![llength $ml]} return set is1 [expr {[llength $ml]==3}] - set m1 "FYI, I haven't yet passed on your" + set m1 "FYI, I haven't yet delivered your" set ol {} set now [clock seconds] while {[llength $ml]} { @@ -1565,12 +1850,12 @@ def_ucmd set { } def_ucmd identpass { - set username [ta_word] - set passmd5 [md5sum "[ta_word]\n"] - ta_nomore prefix_nick check_notonchan set luser [irctolower $n] + set username [ta_word] + set passmd5 [md5sum "[ta_word]\n"] + ta_nomore upvar #0 nick_onchans($luser) onchans if {![info exists onchans] || ![llength $onchans]} { ucmdr "You must be on a channel with me to identify yourself." {} @@ -1580,13 +1865,31 @@ def_ucmd identpass { irc-identpass $n upvar #0 nick_username($luser) rec_username set rec_username $username + after 50 [list tell_event $luser ident] ucmdr "Pleased to see you, $username." {} - tell_event $luser ident +} + +def_ucmd kill { + global nick + prefix_nick + set target [ta_nick] + if {![nickdb_exists $target]} { error "$target is not a registered nick." } + set wantu [nickdb_get $target username] + if {![string length $wantu]} { error "$target is insecurely registred." } + upvar #0 nick_username([irctolower $n]) nu + if {![info exists nu]} { error "You must identify yourself first." } + if {"$wantu" != "$nu"} { + error "You are the wrong user, $nu - $target belongs to $wantu." + } + set reason "at request of user $nu" + if {[ta_anymore]} { append reason "; $text" } + sendout KILL $target $reason } def_ucmd summon { set target [ta_word] ta_nomore + # fixme would be nice if the rest of the text was passed on instead check_username $target prefix_nick @@ -1680,7 +1983,7 @@ proc lnick_marktime_start {luser why ms mentiontold} { set mt [nickdb_get $luser marktime] if {"$mt" == "off"} { lnick_marktime_cancel $luser - after $ms [list lnick_checktold $luser] + if {$mentiontold} { after $ms [list lnick_checktold $luser] } } else { lnick_marktime_doafter $luser $why $ms $mentiontold } @@ -1691,7 +1994,7 @@ proc lnick_marktime_now {luser why mentiontold} { global calling_nick set calling_nick $luser sendprivmsg $luser [lnick_pingstring $why $oc ""] - if {$mentiontold} { lnick_checktold $luser } + if {$mentiontold} { after 150 [list lnick_checktold $luser] } lnick_marktime_reset $luser } @@ -1741,7 +2044,7 @@ def_ucmd ping { } if {[llength $oc]} { lnick_marktime_reset $ln } } - lnick_checktold $ln + after 150 [list lnick_checktold $ln] ucmdr {} [lnick_pingstring "Pong!" $oc $text] } @@ -1758,6 +2061,10 @@ proc ensure_globalsecret {} { } proc connected {} { + global operuserpass + if {[info exists operuserpass]} { + eval sendout OPER $operuserpass + } foreach chan [chandb_list] { if {[chandb_get $chan autojoin]} { dojoin $chan } }