X-Git-Url: https://git.distorted.org.uk/~mdw/ircbot/blobdiff_plain/83dd12243f89e23ca1ddf90da9a55964b3b963b2..904451e244dc5b97ade762863d3e890fae40a49d:/bot.tcl diff --git a/bot.tcl b/bot.tcl index 8d2083a..e5da846 100755 --- a/bot.tcl +++ b/bot.tcl @@ -1,11 +1,119 @@ -#!/usr/bin/tclsh8.2 +# Core bot code -set host chiark -set port 6667 -set nick Blight +proc defset {varname val} { + upvar #0 $varname var + if {![info exists var]} { set var $val } +} + +# must set host +defset port 6667 + +defset nick testbot +defset ownfullname "testing bot" +defset ownmailaddr test-irc-bot@example.com + +defset musthaveping_ms 10000 +defset out_maxburst 6 +defset out_interval 2100 +defset out_lag_lag 5000 +defset out_lag_very 25000 + +defset marktime_min 300 +defset marktime_join_startdelay 5000 + +proc manyset {list args} { + foreach val $list var $args { + upvar 1 $var my + set my $val + } +} -proc sendout {command args} { +proc try_except_finally {try except finally} { + global errorInfo errorCode + set er [catch { uplevel 1 $try } emsg] + if {$er} { + set ei $errorInfo + set ec $errorCode + if {[catch { uplevel 1 $except } emsg3]} { + append ei "\nALSO ERROR HANDLING ERROR:\n$emsg3" + } + } + set er2 [catch { uplevel 1 $finally } emsg2] + if {$er} { + if {$er2} { + append ei "\nALSO ERROR CLEANING UP:\n$emsg2" + } + return -code $er -errorinfo $ei -errorcode $ec $emsg + } elseif {$er2} { + return -code $er2 -errorinfo $errorInfo -errorcode $errorCode $emsg2 + } else { + return $emsg + } +} + +proc out__vars {} { + uplevel 1 { + global out_queue out_creditms out_creditat out_interval out_maxburst + global out_lag_lag out_lag_very +#set pr [lindex [info level 0] 0] +#puts $pr>[clock seconds]|$out_creditat|$out_creditms|[llength $out_queue]< + } +} + +proc out_lagged {} { + out__vars + if {[llength $out_queue]*$out_interval > $out_lag_very} { + return 2 + } elseif {[llength $out_queue]*$out_interval > $out_lag_lag} { + return 1 + } else { + return 0 + } +} + +proc out_restart {} { + out__vars + + set now [clock seconds] + incr out_creditms [expr {($now - $out_creditat) * 1000}] + set out_creditat $now + if {$out_creditms > $out_maxburst*$out_interval} { + set out_creditms [expr {$out_maxburst*$out_interval}] + } + out_runqueue $now +} + +proc out_runqueue {now} { global sock + out__vars + + while {[llength $out_queue] && $out_creditms >= $out_interval} { +#puts rq>$now|$out_creditat|$out_creditms|[llength $out_queue]< + manyset [lindex $out_queue 0] orgwhen msg + set out_queue [lrange $out_queue 1 end] + if {[llength $out_queue]} { + append orgwhen "+[expr {$now - $orgwhen}]" + append orgwhen "([llength $out_queue])" + } + puts "$orgwhen -> $msg" + puts $sock $msg + incr out_creditms -$out_interval + } + if {[llength $out_queue]} { + after $out_interval out_nextmessage + } +} + +proc out_nextmessage {} { + out__vars + set now [clock seconds] + incr out_creditms $out_interval + set out_creditat $now + out_runqueue $now +} + +proc sendout_priority {priority command args} { + global sock out_queue if {[llength $args]} { set la [lindex $args end] set args [lreplace $args end end] @@ -18,10 +126,20 @@ proc sendout {command args} { } set args [lreplace $args 0 -1 $command] set string [join $args { }] - puts "[clock seconds] -> $string" - puts $sock $string + set now [clock seconds] + set newe [list $now $string] + if {$priority} { + set out_queue [concat [list $newe] $out_queue] + } else { + lappend out_queue $newe + } + if {[llength $out_queue] == 1} { + out_restart + } } +proc sendout {command args} { eval sendout_priority [list 0 $command] $args } + proc log {data} { puts $data } @@ -46,13 +164,24 @@ proc bgerror {msg} { } proc onread {args} { - global sock + 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 + + set ei $errorInfo + set ec $errorCode + catch { unset calling_nick } + set errorInfo $ei + set errorCode $ec + if {[regexp -nocase {^:([^ ]+) (.*)} $line dummy prefix remain]} { set line $remain + if {[regexp {^([^!]+)!} $prefix dummy maybenick]} { + set calling_nick $maybenick + if {"[irctolower $maybenick]" == "[irctolower $nick]"} return + } } else { set prefix {} } @@ -74,11 +203,12 @@ proc onread {args} { } if {"$command" == "PRIVMSG" && [regexp {^[&#+!]} [lindex $params 0]] && - ![regexp {^!} [lindex $params 1]]} { + ![regexp {^![a-z][-a-z]*[a-z]( .*)?$} [lindex $params 1]]} { # on-channel message, ignore - catch { - recordlastseen_p $prefix "talking on [lindex $params 0]" 1 - } + set chan [lindex $params 0] + upvar #0 chan_lastactivity([irctolower $chan]) la + set la [clock seconds] + catch { recordlastseen_p $prefix "talking on $chan" 1 } return } log "[clock seconds] <- $org" @@ -92,13 +222,16 @@ proc onread {args} { } } -proc msendprivmsg {dest ll} { - foreach l $ll { sendout PRIVMSG $dest $l } +proc sendprivmsg {dest l} { + foreach v [split $l "\n"] { + sendout [expr {[ischan $dest] ? "PRIVMSG" : "NOTICE"}] $dest $v + } } - -proc msendprivmsg_delayed {delay dest ll} { - after $delay [list msendprivmsg $dest $ll] +proc sendaction_priority {priority dest what} { + sendout_priority $priority PRIVMSG $dest "\001ACTION $what\001" } +proc msendprivmsg {dest ll} { foreach l $ll { sendprivmsg $dest $l } } +proc msendprivmsg_delayed {delay dest ll} { after $delay [list msendprivmsg $dest $ll] } proc prefix_none {} { upvar 1 p p @@ -106,8 +239,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} { @@ -135,14 +270,18 @@ proc prefix_nick {} { upvar 1 n n if {![regexp {^([^!]+)!} $p dummy n]} { error "not from nick" } check_nick $n - if {"[irctolower $n]" == "[irctolower $nick]"} { error "from myself" } + if {"[irctolower $n]" == "[irctolower $nick]"} { + error "from myself" {} {} + } } -proc showinterval {howlong} { - if {$howlong <= 0} { - return {just now} - } elseif {$howlong < 1000} { - return "${howlong}s ago" +proc showintervalsecs {howlong} { + return [showintervalsecs/[opt timeformat] $howlong] +} + +proc showintervalsecs/ks {howlong} { + if {$howlong < 1000} { + return "${howlong}s" } else { if {$howlong < 1000000} { set pfx k @@ -154,11 +293,44 @@ proc showinterval {howlong} { set value [expr "$howlong.0 / $scale"] foreach {min format} {100 %.0f 10 %.1f 1 %.2f} { if {$value < $min} continue - return [format "$format${pfx}s ago" $value] + return [format "$format${pfx}s" $value] } } } +proc format_qty {qty unit} { + set o $qty + append o " " + append o $unit + if {$qty != 1} { append o s } + return $o +} + +proc showintervalsecs/hms {qty} { + set ul {second 60 minute 60 hour 24 day 7 week} + set remainv 0 + while {[llength $ul] > 1 && $qty >= [set uv [lindex $ul 1]]} { + set remainu [lindex $ul 0] + set remainv [expr {$qty % $uv}] + set qty [expr {($qty-$remainv)/$uv}] + set ul [lreplace $ul 0 1] + } + set o [format_qty $qty [lindex $ul 0]] + if {$remainv} { + append o " " + append o [format_qty $remainv $remainu] + } + return $o +} + +proc showinterval {howlong} { + if {$howlong <= 0} { + return {just now} + } else { + return "[showintervalsecs $howlong] ago" + } +} + proc showtime {when} { return [showinterval [expr {[clock seconds] - $when}]] } @@ -245,7 +417,31 @@ proc recordlastseen_n {n how here} { msendprivmsg_delayed 1000 $n $ml } } - + +proc note_topic {showoff whoby topic} { + set msg "FYI, $whoby has changed 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 + } + foreach spy $tryspies { + set see [chandb_get $spy topicsee] + 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 @@ -259,12 +455,26 @@ proc chanmode_arg {} { } proc chanmode_o1 {m g p chan} { - global nick + global nick chan_initialop prefix_nick set who [chanmode_arg] recordlastseen_n $n "being nice to $who" 1 if {"[irctolower $who]" == "[irctolower $nick]"} { - sendout PRIVMSG $n Thanks. + set nlower [irctolower $n] + upvar #0 nick_unique($nlower) u + if {[chandb_exists $chan]} { + sendprivmsg $n Thanks. + } elseif {![info exists u]} { + sendprivmsg $n {Op me while not on the channel, why don't you ?} + } 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]]} { + sendprivmsg $n \ + "(But to do that you must register your nick securely first.)" + } + } } } @@ -297,15 +507,182 @@ proc msg_MODE {p c dest modelist args} { } } +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 + upvar #0 chan_lastactivity($lchan) la + catch { unset la } +} + +proc doleave {lchan} { + sendout PART $lchan + leaving $lchan +} + +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]" != "[irctolower $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 + } + } else { + doleave $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 {"$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 + } + } +} + +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 ,] + set users [split $users ,] + if {[llength $chans] > 1} { + foreach chan $chans user $users { process_kickpart $chan $user } + } else { + foreach user $users { process_kickpart [lindex $chans 0] $user } + } +} + +proc msg_KILL {p c user why} { + nick_forget $user +} + +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) +# nick_markid($luser) -> + +# chan_nicks($lchan) -> [list ... $luser ...] +# chan_lastactivity($lchan) -> [clock seconds] + +proc lnick_forget {luser} { + global nick_arys chan_nicks + lnick_marktime_cancel $luser + foreach ary $nick_arys { + upvar #0 nick_${ary}($luser) av + catch { unset av } + } + foreach lch [array names chan_nicks] { + upvar #0 chan_nicks($lch) nlist + set nlist [grep tn {"$tn" != "$luser"} $nlist] + check_justme $lch + } +} + +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 $user]) $user +} + proc msg_NICK {p c newnick} { + global nick_arys nick_case prefix_nick recordlastseen_n $n "changing nicks to $newnick" 0 recordlastseen_n $newnick "changing nicks from $n" 1 + set luser [irctolower $n] + lnick_marktime_cancel $luser + set lusernew [irctolower $newnick] + foreach ary $nick_arys { + upvar #0 nick_${ary}($luser) old + upvar #0 nick_${ary}($lusernew) new + if {[info exists new]} { error "nick collision ?! $ary $n $newnick" } + if {[info exists old]} { set new $old; unset old } + } + upvar #0 nick_onchans($lusernew) oc + foreach ch $oc { + upvar #0 chan_nicks($ch) nlist + set nlist [grep tn {"$tn" != "$luser"} $nlist] + lappend nlist $lusernew + } + lnick_marktime_start $lusernew "Hi." 500 + nick_case $newnick } -proc msg_JOIN {p c chan} { recordlastseen_p $p "joining $chan" 1 } -proc msg_PART {p c chan} { recordlastseen_p $p "leaving $chan" 1 } -proc msg_QUIT {p c why} { recordlastseen_p $p "leaving ($why)" 0 } +proc nick_ishere {n} { + global nick_counter + upvar #0 nick_unique([irctolower $n]) u + if {![info exists u]} { set u [incr nick_counter].$n.[clock seconds] } + nick_case $n +} + +proc msg_JOIN {p c chan} { + prefix_nick + recordlastseen_n $n "joining $chan" 1 + set nl [irctolower $n] + set lchan [irctolower $chan] + upvar #0 nick_onchans($nl) oc + upvar #0 chan_nicks($lchan) nlist + if {![info exists oc]} { + global marktime_join_startdelay + lnick_marktime_start $nl "Welcome." $marktime_join_startdelay + } + lappend oc $lchan + lappend nlist $nl + nick_ishere $n +} +proc msg_PART {p c chan} { + prefix_nick + recordlastseen_n $n "leaving $chan" 1 + process_kickpart $chan $n +} +proc msg_QUIT {p c why} { + prefix_nick + recordlastseen_n $n "leaving ($why)" 0 + nick_forget $n +} proc msg_PRIVMSG {p c dest text} { prefix_nick @@ -316,6 +693,7 @@ proc msg_PRIVMSG {p c dest text} { recordlastseen_n $n "talking to me" 1 set output $n } + nick_case $n if {[catch { regsub {^! *} $text {} text @@ -326,14 +704,77 @@ proc msg_PRIVMSG {p c dest text} { } $procname $p $dest } rv]} { - sendout PRIVMSG $n "error: $rv" + sendprivmsg $n "error: $rv" } else { - foreach {td val} [list $n [lindex $rv 0] $output [lindex $rv 1]] { + manyset $rv priv_msgs pub_msgs priv_acts pub_acts + foreach {td val} [list $n $priv_acts $output $pub_acts] { foreach l [split $val "\n"] { - sendout PRIVMSG $td $l + sendaction_priority 0 $td $l } } + foreach {td val} [list $n $priv_msgs $output $pub_msgs] { + foreach l [split $val "\n"] { + sendprivmsg $td $l + } + } + } +} + +proc msg_INVITE {p c n chan} { + after 1000 [list dojoin [irctolower $chan]] +} + +proc grep {var predicate list} { + set o {} + upvar 1 $var v + foreach v $list { + if {[uplevel 1 [list expr $predicate]]} { lappend o $v } + } + return $o +} + +proc msg_353 {p c dest type chan nicklist} { + global names_chans nick_onchans + 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 + 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]} { lnick_forget $n } } + unset names_chans +} + +proc ta_anymore {} { + upvar 1 text text + return [expr {!![string length $text]}] } proc ta_nomore {} { @@ -360,25 +801,746 @@ proc def_ucmd {cmdname body} { proc ucmd/$cmdname {p dest} " upvar 1 text text\n$body" } -proc ucmdr {priv pub} { - return -code return [list $priv $pub] +proc ucmdr {priv pub args} { + return -code return [concat [list $priv $pub] $args] } - + +proc loadhelp {} { + global help_topics errorInfo + + catch { unset help_topics } + set f [open helpinfos r] + try_except_finally { + set lno 0 + while {[gets $f l] >= 0} { + incr lno + if {[regexp {^#.*} $l]} { + } elseif {[regexp {^ *$} $l]} { + if {[info exists topic]} { + set help_topics($topic) [join $lines "\n"] + unset topic + unset lines + } + } 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]} { + 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 + } +} + def_ucmd help { + upvar 1 n n + + set topic [irctolower [string trim $text]] + if {[string length $topic]} { + set ontopic " on `$topic'" + } else { + set ontopic "" + } + if {[set lag [out_lagged]]} { + if {[ischan $dest]} { set replyto $dest } else { set replyto $n } + if {$lag > 1} { + sendaction_priority 1 $replyto \ + "is very lagged. Please ask for help$ontopic again later." + ucmdr {} {} + } else { + sendaction_priority 1 $replyto \ + "is lagged. Your help$ontopic will arrive shortly ..." + } + } + + upvar #0 help_topics($topic) info + if {![info exists info]} { ucmdr "No help on $topic, sorry." {} } + ucmdr $info {} +} + +def_ucmd ? { + global help_topics + ucmdr $help_topics() {} +} + +proc check_username {target} { + if { + [string length $target] > 8 || + [regexp {[^-0-9a-z]} $target] || + ![regexp {^[a-z]} $target] + } { error "invalid username" } +} + +proc somedb__head {} { + uplevel 1 { + set idl [irctolower $id] + upvar #0 ${nickchan}db($idl) ndbe + binary scan $idl H* idh + set idfn $fprefix$idh + if {![info exists iddbe] && [file exists $idfn]} { + set f [open $idfn r] + try_except_finally { set newval [read $f] } {} { close $f } + if {[llength $newval] % 2} { error "invalid length" } + set iddbe $newval + } + } +} + +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; $body" + } +} + +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_id delete {} { + catch { unset iddbe } + file delete $idfn +} + +set default_settings_nick {timeformat ks marktime off} +set default_settings_chan { + autojoin 1 + mode * + userinvite pub + topicset {} + topicsee {} + topictell {} +} + +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 } + set newval {} + foreach {key value} [array get a] { lappend newval $key $value } + set f [open $idfn.new w] + try_except_finally { + puts $f $newval + close $f + file rename -force $idfn.new $idfn + } { + } { + catch { close $f } + } + set iddbe $newval +} + +def_somedb_id get {key} { + upvar #0 default_settings_$nickchan def + if {[info exists iddbe]} { + set l [concat $iddbe $def] + } else { + set l $def + } + foreach {tkey value} $l { + if {"$tkey" == "$key"} { return $value } + } + error "unset setting $key" +} + +proc opt {key} { + global calling_nick + if {[info exists calling_nick]} { set n $calling_nick } { set n {} } + return [nickdb_get $n $key] +} + +proc check_notonchan {} { + upvar 1 dest dest + if {[ischan $dest]} { error "that command must be sent privately" } +} + +proc nick_securitycheck {strict} { + upvar 1 n n + if {![nickdb_exists $n]} { error "you are unknown to me, use `register'." } + set wantu [nickdb_get $n username] + if {![string length $wantu]} { + if {$strict} { + error "that feature is only available to secure users, sorry." + } else { + return + } + } + set luser [irctolower $n] + upvar #0 nick_username($luser) nu + if {![info exists nu]} { + error "nick $n is secure, you must identify yourself first." + } + if {"$wantu" != "$nu"} { + error "you are the wrong user - the nick $n belongs to $wantu, not $nu" + } +} + +proc channel_securitycheck {channel n} { + # You must also call `nick_securitycheck 1' + set mgrs [chandb_get $channel managers] + if {[lsearch -exact [irctolower $mgrs] [irctolower $n]] < 0} { + error "you are not a manager of $channel" + } +} + +proc def_chancmd {name body} { + proc channel/$name {} \ + " upvar 1 target chan; upvar 1 n n; upvar 1 text text; $body" +} + +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 { + _= { } + _+ - _- { + uplevel 1 $findnow + foreach item $exchg { set array($item) 1 } + } + default { + error "list change opcode must be one of + - =" + } + } + foreach exchg [split $text " "] { + if {![string length $exchg]} continue + uplevel 1 $procvalue + if {"$opcode" != "-"} { + 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 ta_listop_ev [list [irctolower $n]] + } + } { + check_nick $ta_listop_ev + set ta_listop_ev [irctolower $ta_listop_ev] + } + 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." {} + } +} + +def_chancmd autojoin { + set yesno [ta_word] + switch -exact [string tolower $yesno] { + no { set nv 0 } + yes { set nv 1 } + 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] " "] + 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." + } + } + append l "\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." + } + ucmdr {} $l + } else { + ucmdr {} "The channel $chan is not managed." + } +} + +proc channelmgr_monoop {} { + upvar 1 dest dest + upvar 1 text text + upvar 1 n n + upvar 1 p p + upvar 1 target target + global chan_nicks + + prefix_nick + + if {[ischan $dest]} { set target $dest } + if {[ta_anymore]} { set target [ta_word] } ta_nomore - ucmdr \ -{Commands currently understood: -help get this list of commands -seen ask after someone (I'll tell them you asked)} {} + if {![info exists target]} { + error "you must specify, or invoke me on, the relevant channel" + } + if {![info exists chan_nicks([irctolower $target])]} { + error "I am not on $target." + } + if {![ischan $target]} { error "not a valid channel" } + + if {![chandb_exists $target]} { error "$target is not a managed channel." } + nick_securitycheck 1 + channel_securitycheck $target $n } -proc manyset {list args} { - foreach val $list var $args { - upvar 1 $var my - set my $val +def_ucmd op { + channelmgr_monoop + sendout MODE $target +o $n +} + +def_ucmd leave { + channelmgr_monoop + doleave $target +} + +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]} { + set subcmd show + } else { + set subcmd [ta_word] + } + if {[ischan $subcmd]} { + set target $subcmd + if {![ta_anymore]} { + set subcmd show + } else { + set subcmd [ta_word] + } + } + if {![info exists target]} { error "privately, you must specify a channel" } + set procname channel/$subcmd + if {"$subcmd" != "show"} { + if {[catch { info body $procname }]} { error "unknown channel setting $subcmd" } + prefix_nick + nick_securitycheck 1 + if {[chandb_exists $target]} { + channel_securitycheck $target $n + } else { + upvar #0 chan_initialop([irctolower $target]) io + 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" } + } + } + channel/$subcmd +} + +def_ucmd who { + if {[ta_anymore]} { + set target [ta_word]; ta_nomore + set myself 1 + } else { + prefix_nick + set target $n + set myself [expr {"$target" != "$n"}] + } + set ltarget [irctolower $target] + upvar #0 nick_case($ltarget) ctarget + set nshow $target + 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 $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 ctarget] || ![info exists oc]} { + if {$myself} { + append ol "\nI can't see $nshow on anywhere." + } else { + append ol "\nYou aren't on any channels with me." + } + } elseif {![info exists nu]} { + append ol "\n$nshow has not identified themselves." + } elseif {![info exists username]} { + append ol "\n$nshow has identified themselves as the user $nu." + } elseif {"$nu" != "$username"} { + append ol "\nHowever, $nshow is being used by the user $nu." + } else { + append ol "\n$nshow has identified themselves to me." + } + ucmdr {} $ol +} + +def_ucmd register { + prefix_nick + 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($luser) nu + if {![info exists nu]} { + ucmdr {} \ + "You must identify yourself before using `register'. See `help identify', or use `register insecure'." + } + nickdb_set $n username $nu + ucmdr {} {} "makes a note of your username." {} + } + delete { + nickdb_delete $n + ucmdr {} {} "forgets your nickname." {} + } + insecure { + nickdb_set $n username {} + if {$old} { + ucmdr {} "Security is now disabled for your nickname !" + } else { + ucmdr {} "This is fine, but bear in mind that people will be able to mess with your settings. Channel management features need a secure registration." "makes an insecure registration for your nick." + } + } } } +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." } + default { error "invalid timeformat: $v" } + } +} + +proc def_setting {opt show_body set_body} { + proc set_show/$opt {} " + upvar 1 n n + set opt $opt + $show_body" + if {![string length $set_body]} return + proc set_set/$opt {} " + upvar 1 n n + upvar 1 text text + set opt $opt + $set_body" +} + +def_setting timeformat { + set tf [nickdb_get $n timeformat] + return "$tf: [timeformat_desc $tf]" +} { + set tf [string tolower [ta_word]] + ta_nomore + set desc [timeformat_desc $tf] + nickdb_set $n timeformat $tf + ucmdr {} $desc +} + +proc marktime_desc {mt} { + if {"$mt" == "off"} { + return "I will not send you periodic messages." + } elseif {"$mt" == "once"} { + return "I will send you one informational message when I see you." + } else { + return "I'll send you a message every [showintervalsecs $mt]." + } +} + +def_setting marktime { + set mt [nickdb_get $n marktime] + set p $mt + if {[string match {[0-9]*} $mt]} { append p s } + append p ": " + append p [marktime_desc $mt] + return $p +} { + global marktime_min + set mt [string tolower [ta_word]] + ta_nomore + + if {"$mt" == "off" || "$mt" == "once"} { + } elseif {[regexp {^([0-9]+)([a-z]+)$} $mt dummy value unit]} { + switch -exact $unit { + s { set u 1 } + ks { set u 1000 } + m { set u 60 } + h { set u 3600 } + default { error "unknown unit of time $unit" } + } + if {$value > 86400*21/$u} { error "marktime interval too large" } + set mt [expr {$value*$u}] + if {$mt < $marktime_min} { error "marktime interval too small" } + } else { + error "invalid syntax for marktime" + } + nickdb_set $n marktime $mt + lnick_marktime_start [irctolower $n] "So:" 500 + ucmdr {} [marktime_desc $mt] +} + +def_setting security { + set s [nickdb_get $n username] + if {[string length $s]} { + return "Your nick, $n, is controlled by the user $s." + } else { + return "Your nick, $n, is not secure." + } +} {} + +def_ucmd set { + prefix_nick + check_notonchan + if {![nickdb_exists $n]} { + ucmdr {} "You are unknown to me and so have no settings. (Use `register'.)" + } + if {![ta_anymore]} { + set ol {} + foreach proc [lsort [info procs]] { + if {![regexp {^set_show/(.*)$} $proc dummy opt]} continue + lappend ol [format "%-10s %s" $opt [set_show/$opt]] + } + ucmdr {} [join $ol "\n"] + } else { + set opt [ta_word] + if {[catch { info body set_show/$opt }]} { + error "no setting $opt" + } + if {![ta_anymore]} { + ucmdr {} "$opt [set_show/$opt]" + } else { + nick_securitycheck 0 + if {[catch { info body set_set/$opt }]} { + error "setting $opt cannot be set with `set'" + } + set_set/$opt + } + } +} + +def_ucmd identpass { + set username [ta_word] + set passmd5 [md5sum "[ta_word]\n"] + ta_nomore + prefix_nick + check_notonchan + 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($luser) rec_username + set rec_username $username + ucmdr "Pleased to see you, $username." {} +} + +def_ucmd summon { + set target [ta_word] + ta_nomore + check_username $target + prefix_nick + + upvar #0 lastsummon($target) ls + set now [clock seconds] + if {[info exists ls]} { + set interval [expr {$now - $ls}] + if {$interval < 30} { + ucmdr {} \ + "Please be patient; $target was summoned only [showinterval $interval]." + } + } + regsub {^[^!]*!} $p {} path + if {[catch { + exec userv --timeout 3 $target irc-summon $n $path \ + [expr {[ischan $dest] ? "$dest" : ""}] \ + < /dev/null + } rv]} { + regsub -all "\n" $rv { / } rv + error $rv + } + if {[regexp {^problem (.*)} $rv dummy problem]} { + ucmdr {} "The user `$target' $problem." + } elseif {[regexp {^ok ([^ ]+) ([0-9]+)$} $rv dummy tty idlesince]} { + set idletime [expr {$now - $idlesince}] + set ls $now + ucmdr {} {} {} "invites $target ($tty[expr { + $idletime > 10 ? ", idle for [showintervalsecs $idletime]" : "" + }]) to [expr { + [ischan $dest] ? "join us here" : "talk to you" + }]." + } else { + error "unexpected response from userv service: $rv" + } +} + +proc md5sum {value} { exec md5sum << $value } + def_ucmd seen { global lastseen nick prefix_nick @@ -411,17 +1573,144 @@ def_ucmd seen { ucmdr {} $rstr } -if {![info exists sock]} { - set sock [socket $host $port] +proc lnick_marktime_cancel {luser} { + upvar #0 nick_markid($luser) mi + if {![info exists mi]} return + catch { after cancel $mi } + catch { unset mi } +} + +proc lnick_marktime_doafter {luser why ms} { + lnick_marktime_cancel $luser + upvar #0 nick_markid($luser) mi + set mi [after $ms [list lnick_marktime_now $luser $why]] +} + +proc lnick_marktime_reset {luser} { + set mt [nickdb_get $luser marktime] + if {"$mt" == "off" || "$mt" == "once"} return + lnick_marktime_doafter $luser "Time passes." [expr {$mt*1000}] +} + +proc lnick_marktime_start {luser why ms} { + set mt [nickdb_get $luser marktime] + if {"$mt" == "off"} { + lnick_marktime_cancel $luser + } else { + lnick_marktime_doafter $luser $why $ms + } +} + +proc lnick_marktime_now {luser why} { + upvar #0 nick_onchans($luser) oc + sendprivmsg $luser [lnick_pingstring $why $oc ""] + lnick_marktime_reset $luser +} + +proc lnick_pingstring {why oc apstring} { + global nick_onchans + catch { exec uptime } uptime + set nnicks [llength [array names nick_onchans]] + if {[regexp \ + {^ *([0-9:apm]+) +up.*, +(\d+) users, +load average: +([0-9., ]+) *$} \ + $uptime dummy time users load]} { + regsub , $load {} load + set uptime "$time $nnicks/$users $load" + } else { + append uptime ", $nnicks nicks" + } + if {[llength $oc]} { + set best_la 0 + set activity quiet + foreach ch $oc { + upvar #0 chan_lastactivity($ch) la + if {![info exists la]} continue + if {$la <= $best_la} continue + set activity "$ch [showintervalsecs [expr {[clock seconds]-$la}]]" + set best_la $la + } + } else { + set activity unseen + } + set str $why + append str " " $uptime " " $activity + if {[string length $apstring]} { append str " " $apstring } + return $str +} + +def_ucmd ping { + if {[ischan $dest]} { + set oc [irctolower $dest] + } else { + global nick_onchans + prefix_nick + set ln [irctolower $n] + if {[info exists nick_onchans($ln)]} { + set oc $nick_onchans($ln) + } else { + set oc {} + } + if {[llength $oc]} { lnick_marktime_reset $ln } + } + ucmdr {} [lnick_pingstring "Pong!" $oc $text] +} + +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 socketargs + global musthaveping_ms musthaveping_after + + if {[info exists sock]} return + set sock [eval socket $socketargs [list $host $port]] fconfigure $sock -buffering line - #fconfigure $sock -translation binary fconfigure $sock -translation crlf - sendout USER guest 0 * "chiark testing bot" + sendout USER blight 0 * $ownfullname sendout NICK $nick fileevent $sock readable onread + + set musthaveping_after [after $musthaveping_ms \ + {fail "no ping within timeout"}] +} + +proc connected {} { + global musthaveping_after + + after cancel $musthaveping_after + unset musthaveping_after + + foreach chan [chandb_list] { + if {[chandb_get $chan autojoin]} { dojoin $chan } + } } -#if {![regexp {tclsh} $argv0]} { -# vwait terminate -#} +ensure_globalsecret +ensure_outqueue +loadhelp +ensure_connecting