X-Git-Url: https://git.distorted.org.uk/~mdw/ircbot/blobdiff_plain/0a9992353943f00755d4ec5d3d9a7b3f40f0afad..281b5f05b709342999c50f6483528569169b8051:/bot.tcl diff --git a/bot.tcl b/bot.tcl index 240e70b..0b12a54 100755 --- a/bot.tcl +++ b/bot.tcl @@ -1,32 +1,22 @@ -#!/usr/bin/tclsh8.2 +# Core bot code -set host chiark -set port 6667 -if {![info exists nick]} { set nick Blight } -if {![info exists ownfullname]} { set ownfullname "here to Help" } -set ownmailaddr blight@chiark.greenend.org.uk +proc defset {varname val} { + upvar #0 $varname var + if {![info exists var]} { set var $val } +} -set out_maxburst 6 -set out_interval 2100 -set out_lag_lag 5000 -set out_lag_very 25000 +# must set host +defset port 6667 -if {![info exists out_queue]} { - set out_creditms [expr {$out_maxburst*$out_interval}] - set out_creditat [clock seconds] - set out_queue {} - set out_lag_reported 0 - set out_lag_reportwhen $out_creditat -} +defset nick testbot +defset ownfullname "testing bot" +defset ownmailaddr test-irc-bot@example.com -if {![info exists globalsecret]} { - set gsfile [open /dev/urandom r] - fconfigure $gsfile -translation binary - set globalsecret [read $gsfile 32] - binary scan $globalsecret H* globalsecret - close $gsfile - unset gsfile -} +defset musthaveping_ms 10000 +defset out_maxburst 6 +defset out_interval 2100 +defset out_lag_lag 5000 +defset out_lag_very 25000 proc manyset {list args} { foreach val $list var $args { @@ -173,7 +163,7 @@ proc bgerror {msg} { proc onread {args} { global sock nick calling_nick errorInfo errorCode - if {[gets $sock line] == -1} { set terminate 1; return } + if {[gets $sock line] == -1} { fail "EOF/error on input" } regsub -all "\[^ -\176\240-\376\]" $line ? line set org $line @@ -245,8 +235,10 @@ proc prefix_none {} { } proc msg_PING {p c s1} { + global musthaveping_after prefix_none sendout PONG $s1 + if {[info exists musthaveping_after]} connected } proc check_nick {n} { @@ -421,7 +413,37 @@ proc recordlastseen_n {n how here} { msendprivmsg_delayed 1000 $n $ml } } - + +proc note_topic {showoff whoby topic} { + if {[string length $whoby]} { + set msg "FYI, $whoby has changed the topic on $showoff" + } else { + set msg "FYI, I have reset the topic on $showoff" + } + if {[string length $topic] < 160} { + append msg " to $topic" + } else { + append msg " but it is too long to reproduce here !" + } + set showoff [irctolower $showoff] + set tell [chandb_get $showoff topictell] + if {[lsearch -exact $tell *] >= 0} { + set tryspies [chandb_list] + } else { + set tryspies $tell + } +puts "NT>showoff $showoff|whoby $whoby|topic $topic|tell $tell|tryspies $tryspies|msg $msg<" + foreach spy $tryspies { + set see [chandb_get $spy topicsee] +puts "NT>spy $spy|see $see<" + if {[lsearch -exact $see $showoff] >= 0 || \ + ([lsearch -exact $see *] >= 0 && \ + [lsearch -exact $tell $spy] >= 0)} { + sendprivmsg $spy $msg + } + } +} + proc recordlastseen_p {p how here} { prefix_nick recordlastseen_n $n $how $here @@ -440,8 +462,8 @@ proc chanmode_o1 {m g p chan} { set who [chanmode_arg] recordlastseen_n $n "being nice to $who" 1 if {"[irctolower $who]" == "[irctolower $nick]"} { - set nl [irctolower $n] - upvar #0 nick_unique($n) u + set nlower [irctolower $n] + upvar #0 nick_unique($nlower) u if {[chandb_exists $chan]} { sendprivmsg $n Thanks. } elseif {![info exists u]} { @@ -487,27 +509,70 @@ proc msg_MODE {p c dest modelist args} { } } -proc channel_noone_seen {chan} { - global nick_onchans - foreach n [array names nick_onchans] { - upvar #0 nick_onchans($n) oc - set oc [grep tc {"$tc" != "$chan"} $oc] +proc leaving {lchan} { + foreach luser [array names nick_onchans] { + upvar #0 nick_onchans($luser) oc + set oc [grep tc {"$tc" != "$lchan"} $oc] + } + upvar #0 chan_nicks($lchan) nlist + unset nlist +} + +proc dojoin {lchan} { + global chan_nicks + sendout JOIN $lchan + set chan_nicks($lchan) {} +} + +proc check_justme {lchan} { + global nick + upvar #0 chan_nicks($lchan) nlist + if {[llength $nlist] != 1} return + if {"[lindex $nlist 0]" != "$nick"} return + if {[chandb_exists $lchan]} { + set mode [chandb_get $lchan mode] + if {"$mode" != "*"} { + sendout MODE $lchan $mode + } + set topic [chandb_get $lchan topicset] + if {[string length $topic]} { + sendout TOPIC $lchan $topic + note_topic $lchan {} $topic + } + } else { + sendout PART $lchan + leaving $lchan } } proc process_kickpart {chan user} { global nick check_nick $user + set luser [irctolower $user] + set lchan [irctolower $chan] if {![ischan $chan]} { error "not a channel" } - if {"[irctolower $user]" == "[irctolower $nick]"} { - channel_noone_seen $chan + if {"$luser" == "[irctolower $nick]"} { + leaving $lchan + } else { + upvar #0 nick_onchans($luser) oc + upvar #0 chan_nicks($lchan) nlist + set oc [grep tc {"$tc" != "$lchan"} $oc] + set nlist [grep tn {"$tn" != "$luser"} $nlist] + nick_case $user + if {![llength $oc]} { + nick_forget $luser + } else { + check_justme $lchan + } } - upvar #0 nick_onchans($user) oc - set lc [irctolower $chan] - set oc [grep tc {"$tc" != "$lc"} $oc] - if {![llength $oc]} { nick_forget $user } - nick_case $user -} +} + +proc msg_TOPIC {p c dest topic} { + prefix_nick + if {![ischan $dest]} return + recordlastseen_n $n "changing the topic on $dest" 1 + note_topic [irctolower $dest] $n $topic +} proc msg_KICK {p c chans users comment} { set chans [split $chans ,] @@ -525,19 +590,35 @@ proc msg_KILL {p c user why} { set nick_counter 0 set nick_arys {onchans username unique} +# nick_onchans($luser) -> [list ... $lchan ...] +# nick_username($luser) -> +# nick_unique($luser) -> +# nick_case($luser) -> $user (valid even if no longer visible) + +# chan_nicks($lchan) -> [list ... $luser ...] -proc nick_forget {n} { - global nick_arys +proc lnick_forget {luser} { + global nick_arys chan_nicks foreach ary $nick_arys { - upvar #0 nick_${ary}($n) av + upvar #0 nick_${ary}($luser) av catch { unset av } } - nick_case $n + foreach lch [array names chan_nicks] { + upvar #0 chan_nicks($lch) nlist + set nlist [grep tn {"$tn" != "$luser"} $nlist] + check_justme $lch + } } -proc nick_case {n} { +proc nick_forget {user} { + global nick_arys chan_nicks + lnick_forget [irctolower $user] + nick_case $user +} + +proc nick_case {user} { global nick_case - set nick_case([irctolower $n]) $n + set nick_case([irctolower $user]) $user } proc msg_NICK {p c newnick} { @@ -551,12 +632,20 @@ proc msg_NICK {p c newnick} { if {[info exists new]} { error "nick collision ?! $ary $n $newnick" } if {[info exists old]} { set new $old; unset old } } + upvar #0 nick_onchans($new) + set luser [irctolower $n] + set lusernew [irctolower $newnick] + foreach ch $oc { + upvar #0 chan_nicks($ch) nlist + set nlist [grep tn {"$tn" != "$luser"} $nlist] + lappend nlist $lusernew + } nick_case $newnick } proc nick_ishere {n} { global nick_counter - upvar #0 nick_unique($n) u + upvar #0 nick_unique([irctolower $n]) u if {![info exists u]} { set u [incr nick_counter].$n.[clock seconds] } nick_case $n } @@ -564,7 +653,7 @@ proc nick_ishere {n} { proc msg_JOIN {p c chan} { prefix_nick recordlastseen_n $n "joining $chan" 1 - upvar #0 nick_onchans($n) oc + upvar #0 nick_onchans([irctolower $n]) oc lappend oc [irctolower $chan] nick_ishere $n } @@ -616,7 +705,7 @@ proc msg_PRIVMSG {p c dest text} { } proc msg_INVITE {p c n chan} { - after 1000 [list sendout JOIN $chan] + after 1000 [list dojoin [irctolower $chan]] } proc grep {var predicate list} { @@ -630,28 +719,39 @@ proc grep {var predicate list} { proc msg_353 {p c dest type chan nicklist} { global names_chans nick_onchans - if {![info exists names_chans]} { set names_chans {} } - set chan [irctolower $chan] - lappend names_chans $chan - channel_noone_seen $chan - foreach n [split $nicklist { }] { - regsub {^[@+]} $n {} n - if {![string length $n]} continue - check_nick $n - upvar #0 nick_onchans($n) oc - lappend oc $chan - nick_ishere $n + set lchan [irctolower $chan] + upvar #0 chan_nicks($lchan) nlist + lappend names_chans $lchan + if {![info exists nlist]} { + # We don't think we're on this channel, so ignore it ! + # Unfortunately, because we don't get a reply to PART, + # we have to remember ourselves whether we're on a channel, + # and ignore stuff if we're not, to avoid races. Feh. + return + } + set nlist_new {} + foreach user [split $nicklist { }] { + regsub {^[@+]} $user {} user + if {![string length $user]} continue + check_nick $user + set luser [irctolower $user] + upvar #0 nick_onchans($luser) oc + lappend oc $lchan + lappend nlist_new $luser + nick_ishere $user } + set nlist $nlist_new } proc msg_366 {p c args} { global names_chans nick_onchans - if {[llength names_chans] > 1} { - foreach n [array names nick_onchans] { - upvar #0 nick_onchans($n) oc + set lchan [irctolower $c] + foreach luser [array names nick_onchans] { + upvar #0 nick_onchans($luser) oc + if {[llength names_chans] > 1} { set oc [grep tc {[lsearch -exact $tc $names_chans] >= 0} $oc] - if {![llength $oc]} { nick_forget $n } } + if {![llength $oc]} { lnick_forget $n } } unset names_chans } @@ -690,7 +790,7 @@ proc ucmdr {priv pub args} { } proc loadhelp {} { - global help_topics + global help_topics errorInfo catch { unset help_topics } set f [open helpinfos r] @@ -705,21 +805,27 @@ proc loadhelp {} { unset topic unset lines } - } elseif {[regexp {^!([-+._0-9a-z]*)$} $l dummy newtopic]} { + } elseif {[regexp {^\:\:} $l]} { + } elseif {[regexp {^\:([-+._0-9a-z]*)$} $l dummy newtopic]} { if {[info exists topic]} { error "help $newtopic while in $topic" } set topic $newtopic set lines {} - } elseif {[regexp {^[^!#]} $l]} { + } elseif {[regexp {^[^:#]} $l]} { set topic + regsub -all {([^\\])\!\$?} _$l {\1} l + regsub -all {\\(.)} $l {\1} l + regsub {^_} $l {} l lappend lines [string trimright $l] } else { error "eh ? $lno: $l" } } if {[info exists topic]} { error "unfinished topic $topic" } - } {} { + } { + set errorInfo "in helpinfos line $lno\n$errorInfo" + } { close $f } } @@ -773,23 +879,44 @@ proc somedb__head {} { proc def_somedb {name arglist body} { foreach {nickchan fprefix} {nick users/n chan chans/c} { proc ${nickchan}db_$name $arglist \ - "set nickchan $nickchan; set fprefix $fprefix; somedb__head; $body" + "set nickchan $nickchan; set fprefix $fprefix; $body" } } -def_somedb exists {id} { +def_somedb list {} { + set list {} + foreach path [glob -nocomplain -path $fprefix *] { + binary scan $path "A[string length $fprefix]A*" afprefix thinghex + if {"$afprefix" != "$fprefix"} { error "wrong prefix $path $afprefix" } + lappend list [binary format H* $thinghex] + } + return $list +} + +proc def_somedb_id {name arglist body} { + def_somedb $name [concat id $arglist] "somedb__head; $body" +} + +def_somedb_id exists {} { return [info exists iddbe] } -def_somedb delete {id} { +def_somedb_id delete {} { catch { unset iddbe } file delete $idfn } set default_settings_nick {timeformat ks} -set default_settings_chan {autojoin 1} +set default_settings_chan { + autojoin 1 + mode * + userinvite pub + topicset {} + topicsee {} + topictell {} +} -def_somedb set {id args} { +def_somedb_id set {args} { upvar #0 default_settings_$nickchan def if {![info exists iddbe]} { set iddbe $def } foreach {key value} [concat $iddbe $args] { set a($key) $value } @@ -807,10 +934,10 @@ def_somedb set {id args} { set iddbe $newval } -def_somedb get {id key} { +def_somedb_id get {key} { upvar #0 default_settings_$nickchan def if {[info exists iddbe]} { - set l $iddbe + set l [concat $iddbe $def] } else { set l $def } @@ -842,7 +969,8 @@ proc nick_securitycheck {strict} { return } } - upvar #0 nick_username($n) nu + set luser [irctolower $n] + upvar #0 nick_username($luser) nu if {![info exists nu]} { error "nick $n is secure, you must identify yourself first." } @@ -864,34 +992,52 @@ proc def_chancmd {name body} { " upvar 1 target chan; upvar 1 n n; upvar 1 text text; $body" } -def_chancmd manager { +proc ta_listop {findnow procvalue} { + # findnow and procvalue are code fragments which will be executed + # in the caller's level. findnow should set ta_listop_ev to + # the current list, and procvalue should treat ta_listop_ev as + # a proposed value in the list and check and possibly modify + # (canonicalise?) it. After ta_listop, ta_listop_ev will + # be the new value of the list. + upvar 1 ta_listop_ev exchg + upvar 1 text text set opcode [ta_word] switch -exact _$opcode { - _= { set ml {} } + _= { } _+ - _- { - if {[chandb_exists $chan]} { - set ml [chandb_get $chan managers] - } else { - set ml [list [irctolower $n]] - } + uplevel 1 $findnow + foreach item $exchg { set array($item) 1 } } default { - error "`channel manager' opcode must be one of + - =" + error "list change opcode must be one of + - =" } } - foreach nn [split $text " "] { - if {![string length $nn]} continue - check_nick $nn - set nn [irctolower $nn] + foreach exchg [split $text " "] { + if {![string length $exchg]} continue + uplevel 1 $procvalue if {"$opcode" != "-"} { - lappend ml $nn + set array($exchg) 1 + } else { + catch { unset array($exchg) } + } + } + set exchg [lsort [array names array]] +} + +def_chancmd manager { + ta_listop { + if {[chandb_exists $chan]} { + set ta_listop_ev [chandb_get $chan managers] } else { - set ml [grep nq {"$nq" != "$nn"} $ml] + set ta_listop_ev [list [irctolower $n]] } + } { + check_nick $ta_listop_ev + set ta_listop_ev [irctolower $ta_listop_ev] } - if {[llength $ml]} { - chandb_set $chan managers $ml - ucmdr "Managers of $chan: $ml" {} + if {[llength $ta_listop_ev]} { + chandb_set $chan managers $ta_listop_ev + ucmdr "Managers of $chan: $ta_listop_ev" {} } else { chandb_delete $chan ucmdr {} {} "forgets about managing $chan." {} @@ -906,14 +1052,97 @@ def_chancmd autojoin { default { error "channel autojoin must be `yes' or `no' } } chandb_set $chan autojoin $nv + ucmdr [expr {$nv ? "I will join #chan when I'm restarted " : \ + "I won't join #chan when I'm restarted "}] {} +} + +def_chancmd userinvite { + set nv [string tolower [ta_word]] + switch -exact $nv { + pub { set txt "!invite will work for $chan, but it won't work by /msg" } + here { set txt "!invite and /msg invite will work, but only for users who are already on $chan." } + all { set txt "Any user will be able to invite themselves or anyone else to $chan." } + none { set txt "I will not invite anyone to $chan." } + default { + error "channel userinvite must be `pub', `here', `all' or `none' + } + } + chandb_set $chan userinvite $nv + ucmdr $txt {} +} + +def_chancmd topic { + set what [ta_word] + switch -exact $what { + leave { + ta_nomore + chandb_set $chan topicset {} + ucmdr "I won't ever change the topic of $chan." {} + } + set { + set t [string trim $text] + if {![string length $t]} { + error "you must specific the topic to set" + } + chandb_set $chan topicset $t + ucmdr "Whenever I'm alone on #chan, I'll set the topic to $t." {} + } + see - tell { + ta_listop { + set ta_listop_ev [chandb_get $chan topic$what] + } { + if {"$ta_listop_ev" != "*"} { + if {![ischan $ta_listop_ev]} { + error "bad channel \`$ta_listop_ev' in topic $what" + } + set ta_listop_ev [irctolower $ta_listop_ev] + } + } + chandb_set $chan topic$what $ta_listop_ev + ucmdr "Topic $what list for $chan: $ta_listop_ev" {} + } + default { + error "unknown channel topic subcommand - see help channel" + } + } +} + +def_chancmd mode { + set mode [ta_word] + if {"$mode" != "*" && ![regexp {^(([-+][imnpst]+)+)$} $mode mode]} { + error {channel mode must be * or match ([-+][imnpst]+)+} + } + chandb_set $chan mode $mode + if {"$mode" == "*"} { + ucmdr "I won't ever change the mode of $chan." {} + } else { + ucmdr "Whenever I'm alone on $chan, I'll set the mode to $mode." {} + } } def_chancmd show { if {[chandb_exists $chan]} { set l "Settings for $chan: autojoin " append l [lindex {no yes} [chandb_get $chan autojoin]] + append l ", mode " [chandb_get $chan mode] + append l ", userinvite " [chandb_get $chan userinvite] "." append l "\nManagers: " - append l [join [chandb_get $chan managers] " "] + append l [join [chandb_get $chan managers] " "] "\n" + set t [chandb_get $chan topicset] + if {[string length $t]} { + append l "Topic to set: $t" + } else { + append l "I will not change the topic." + } + foreach {ts sep} {see "\n" tell " "} { + set t [chandb_get $chan topic$ts] + append l $sep + if {[llength $t]} { + append l "Topic $ts list: $t." + } else { + append l "Topic $ts list is empty." + } + } ucmdr {} $l } else { ucmdr {} "The channel $chan is not managed." @@ -933,6 +1162,57 @@ def_ucmd op { sendout MODE $target +o $n } +def_ucmd invite { + global chan_nicks + + if {[ischan $dest]} { + set target $dest + set onchan 1 + } else { + set target [ta_word] + set onchan 0 + } + set ltarget [irctolower $target] + if {![ischan $target]} { error "$target is not a channel." } + if {![info exists chan_nicks($ltarget)]} { error "I am not on $target." } + set ui [chandb_get $ltarget userinvite] + if {"$ui" == "pub" && !$onchan} { + error "Invitations to $target must be made with !invite." + } + if {"$ui" != "all"} { + prefix_nick + if {[lsearch -exact $chan_nicks($ltarget) [irctolower $n]] < 0} { + error "Invitations to $target may only be made by a user on the channel." + } + } + if {"$ui" == "none"} { + error "Sorry, I've not been authorised to invite people to $target." + } + if {![ta_anymore]} { + error "You have to say who to invite." + } + set invitees {} + while {[ta_anymore]} { + set invitee [ta_word] + check_nick $invitee + lappend invitees $invitee + } + foreach invitee $invitees { + sendout INVITE $invitee $ltarget + } + set who [lindex $invitees 0] + switch -exact llength $invitees { + 0 { error "zero invitees" } + 1 { } + 2 { append who " and [lindex $invitees 1]" } + * { + set who [join [lreplace $invitees end end] ", "] + append who " and [lindex $invitees [llength $invitees]]" + } + } + ucmdr {} "invites $who to $target." +} + def_ucmd channel { if {[ischan $dest]} { set target $dest } if {![ta_anymore]} { @@ -958,7 +1238,7 @@ def_ucmd channel { channel_securitycheck $target $n } else { upvar #0 chan_initialop([irctolower $target]) io - upvar #0 nick_unique($n) u + upvar #0 nick_unique([irctolower $n]) u if {![info exists io]} { error "$target is not a managed channel" } if {"$io" != "$u"} { error "you are not the interim manager of $target" } if {"$subcmd" != "manager"} { error "use `channel manager' first" } @@ -976,21 +1256,22 @@ def_ucmd who { set target $n set myself [expr {"$target" != "$n"}] } - upvar #0 nick_case([irctolower $target]) nc + set ltarget [irctolower $target] + upvar #0 nick_case($ltarget) ctarget set nshow $target - if {[info exists nc]} { - upvar #0 nick_onchans($nc) oc - upvar #0 nick_username($nc) nu - if {[info exists oc]} { set nshow $nc } + if {[info exists ctarget]} { + upvar #0 nick_onchans($ltarget) oc + upvar #0 nick_username($ltarget) nu + if {[info exists oc]} { set nshow $ctarget } } - if {![nickdb_exists $target]} { + if {![nickdb_exists $ltarget]} { set ol "$nshow is not a registered nick." } elseif {[string length [set username [nickdb_get $target username]]]} { set ol "The nick $nshow belongs to the user $username." } else { set ol "The nick $nshow is registered (but not to a username)." } - if {![info exists nc] || ![info exists oc]} { + if {![info exists ctarget] || ![info exists oc]} { if {$myself} { append ol "\nI can't see $nshow on anywhere." } else { @@ -1013,9 +1294,10 @@ def_ucmd register { check_notonchan set old [nickdb_exists $n] if {$old} { nick_securitycheck 0 } + set luser [irctolower $n] switch -exact [string tolower [string trim $text]] { {} { - upvar #0 nick_username($n) nu + upvar #0 nick_username($luser) nu if {![info exists nu]} { ucmdr {} \ "You must identify yourself before using `register'. See `help identify', or use `register insecure'." @@ -1115,14 +1397,15 @@ def_ucmd identpass { ta_nomore prefix_nick check_notonchan - upvar #0 nick_onchans($n) onchans + set luser [irctolower $n] + upvar #0 nick_onchans($luser) onchans if {![info exists onchans] || ![llength $onchans]} { ucmdr "You must be on a channel with me to identify yourself." {} } check_username $username exec userv --timeout 3 $username << "$passmd5\n" > /dev/null \ irc-identpass $n - upvar #0 nick_username($n) rec_username + upvar #0 nick_username($luser) rec_username set rec_username $username ucmdr "Pleased to see you, $username." {} } @@ -1200,19 +1483,62 @@ def_ucmd seen { ucmdr {} $rstr } -if {![info exists sock]} { +proc ensure_globalsecret {} { + global globalsecret + + if {[info exists globalsecret]} return + set gsfile [open /dev/urandom r] + fconfigure $gsfile -translation binary + set globalsecret [read $gsfile 32] + binary scan $globalsecret H* globalsecret + close $gsfile + unset gsfile +} + +proc ensure_outqueue {} { + out__vars + if {[info exists out_queue]} return + set out_creditms 0 + set out_creditat [clock seconds] + set out_queue {} + set out_lag_reported 0 + set out_lag_reportwhen $out_creditat +} + +proc fail {msg} { + logerror "failing: $msg" + exit 1 +} + +proc ensure_connecting {} { + global sock ownfullname host port nick + global musthaveping_ms musthaveping_after + + if {[info exists sock]} return set sock [socket $host $port] fconfigure $sock -buffering line - #fconfigure $sock -translation binary fconfigure $sock -translation crlf sendout USER blight 0 * $ownfullname sendout NICK $nick fileevent $sock readable onread + + set musthaveping_after [after $musthaveping_ms \ + {fail "no ping within timeout"}] } -loadhelp +proc connected {} { + global musthaveping_after + + after cancel $musthaveping_after + unset musthaveping_after -#if {![regexp {tclsh} $argv0]} { -# vwait terminate -#} + foreach chan [chandb_list] { + if {[chandb_get $chan autojoin]} { dojoin $chan } + } +} + +ensure_globalsecret +ensure_outqueue +loadhelp +ensure_connecting