X-Git-Url: https://git.distorted.org.uk/~mdw/ircbot/blobdiff_plain/574abac6430df672a6ad566fffcce7422933c68a..65aff3a3a7ac86da7aca85a10ab0193c935e6f61:/bot.tcl

diff --git a/bot.tcl b/bot.tcl
index da2a472..ab788e2 100755
--- a/bot.tcl
+++ b/bot.tcl
@@ -1,36 +1,25 @@
-# Core bot code
+# Actual IRC bot code
+
+set helpfile helpinfos
 
 source irccore.tcl
+source parsecmd.tcl
+source stdhelp.tcl
+
+defset marktime_min 300
+defset marktime_join_startdelay 5000
 
-proc unlogged_content_msg {prefix params} {
-    if {![regexp {^[&#+!]} [lindex $params 0]] ||
+proc privmsg_unlogged {prefix ischan params} {
+    if {!$ischan ||
         [regexp {^![a-z][-a-z]*[a-z]( .*)?$} [lindex $params 1]]} {
-	return 1
+	return 0
     }
     # on-channel message, ignore
     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
-}
-
-proc usererror {emsg} { error $emsg {} {BLIGHT USER} }
-
-proc prefix_none {} {
-    upvar 1 p p
-    if {[string length $p]} { error "prefix specified" }
-}
-
-proc prefix_nick {} {
-    global nick
-    upvar 1 p p
-    upvar 1 n n
-    if {![regexp {^([^!]+)!} $p dummy n]} { error "not from nick" }
-    check_nick $n
-    if {"[irctolower $n]" == "[irctolower $nick]"} {
-	error "from myself" {} {}
-    }
+    catch_logged { recordlastseen_p $prefix "talking on $chan" 1 }
+    return 1
 }
 
 proc showintervalsecs {howlong abbrev} {
@@ -97,6 +86,23 @@ proc showtime {when} {
     return [showinterval [expr {[clock seconds] - $when}]]
 }
 
+proc parse_interval {specified min} {
+    if {![regexp {^([0-9]+)([a-z]+)$} $specified dummy value unit]} {
+	error "invalid syntax for interval"
+    }
+    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 "interval too large" }
+    set result [expr {$value*$u}]
+    if {$result < $min} { error "interval too small (<${min}s)" }
+    return $result
+}
+
 proc def_msgproc {name argl body} {
     proc msg_$name "varbase $argl" "\
     upvar #0 msg/\$varbase/dest d\n\
@@ -390,9 +396,10 @@ proc nick_case {user} {
 }
 
 proc msg_NICK {p c newnick} {
-    global nick_arys nick_case
+    global nick_arys nick_case calling_nick
     prefix_nick
     recordlastseen_n $n "changing nicks to $newnick" 0
+    set calling_nick $newnick
     recordlastseen_n $newnick "changing nicks from $n" 1
     set luser [irctolower $n]
     lnick_marktime_cancel $luser
@@ -409,7 +416,7 @@ proc msg_NICK {p c newnick} {
 	set nlist [grep tn {"$tn" != "$luser"} $nlist]
 	lappend nlist $lusernew
     }
-    lnick_marktime_start $lusernew "Hi." 500
+    lnick_marktime_start $lusernew "Hi." 500 1
     nick_case $newnick
 }
 
@@ -429,15 +436,20 @@ proc msg_JOIN {p c chan} {
     upvar #0 chan_nicks($lchan) nlist
     if {![info exists oc]} {
 	global marktime_join_startdelay
-	lnick_marktime_start $nl "Welcome." $marktime_join_startdelay
+	lnick_marktime_start $nl "Welcome." $marktime_join_startdelay 1
     }
     lappend oc $lchan
     lappend nlist $nl
     nick_ishere $n
 }
-proc msg_PART {p c chan} {
+proc msg_PART {p c chan args} {
     prefix_nick
-    recordlastseen_n $n "leaving $chan" 1
+    set msg "leaving $chan"
+    if {[llength $args]} {
+	set why [lindex $args 0]
+	if {"[irctolower $why]" != "[irctolower $n]"} {	append msg " ($why)" }
+    }
+    recordlastseen_n $n $msg 1
     process_kickpart $chan $n
 }
 proc msg_QUIT {p c why} {
@@ -459,30 +471,7 @@ proc msg_PRIVMSG {p c dest text} {
     }
     nick_case $n
 
-    if {[catch {
-	regsub {^! *} $text {} text
-	set ucmd [ta_word]
-	set procname ucmd/[string tolower $ucmd]
-	if {[catch { info body $procname }]} {
-	    usererror "Unknown command; try help for help."
-	}
-	$procname $p $dest
-    } rv]} {
-	if {"$errorCode" != "BLIGHT USER"} { set rv "error: $rv" }
-	sendprivmsg $n $rv
-    } else {
-	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"] {
-		sendaction_priority 0 $td $l
-	    }
-	}
-	foreach {td val} [list $n $priv_msgs $output $pub_msgs] {
-	    foreach l [split $val "\n"] {
-		sendprivmsg $td $l
-	    }
-	}
-    }
+    execute_usercommand $p $c $n $output $dest $text
 }
 
 proc msg_INVITE {p c n chan} {
@@ -537,111 +526,6 @@ proc msg_366 {p c args} {
     unset names_chans
 }
 
-proc ta_anymore {} {
-    upvar 1 text text
-    return [expr {!![string length $text]}]
-}
-
-proc ta_nomore {} {
-    upvar 1 text text
-    if {[string length $text]} { error "too many parameters" }
-}
-
-proc ta_word {} {
-    upvar 1 text text
-    if {![regexp {^([^ 	]+) *(.*)} $text dummy firstword text]} {
-	error "too few parameters"
-    }
-    return $firstword
-}
-
-proc ta_nick {} {
-    upvar 1 text text
-    set v [ta_word]
-    check_nick $v
-    return $v
-}
-
-proc def_ucmd {cmdname body} {
-    proc ucmd/$cmdname {p dest} "    upvar 1 text text\n$body"
-}
-
-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 ||
@@ -666,7 +550,11 @@ proc somedb__head {} {
 }
 
 proc def_somedb {name arglist body} {
-    foreach {nickchan fprefix} {nick users/n chan chans/c} {
+    foreach {nickchan fprefix} {
+	nick users/n
+	chan chans/c
+	msgs users/m
+    } {
 	proc ${nickchan}db_$name $arglist \
             "set nickchan $nickchan; set fprefix $fprefix; $body"
     }
@@ -695,7 +583,13 @@ def_somedb_id delete {} {
     file delete $idfn
 }
 
-set default_settings_nick {timeformat ks  marktime off}
+set default_settings_nick {
+    timeformat ks
+    marktime off
+    tellsec insecure
+    tellrel {remind 3600 30}
+}
+
 set default_settings_chan {
     autojoin 1
     mode *
@@ -705,6 +599,13 @@ set default_settings_chan {
     topictell {}
 }
 
+set default_settings_msgs {
+    inbound {}
+    outbound {}
+}
+# inbound -> [<nick> <time_t> <message>] ...
+# outbound -> [<nick> <time_t(earliest)> <count>] ...
+
 def_somedb_id set {args} {
     upvar #0 default_settings_$nickchan def
     if {![info exists iddbe]} { set iddbe $def }
@@ -1098,6 +999,87 @@ def_ucmd channel {
     channel/$subcmd
 }
 
+def_ucmd tell {
+    global nick_case ownmailaddr ownfullname
+    
+    prefix_nick
+    set target [ta_word]
+    if {![string length $text]} { error "tell them what?" }
+
+    set ltarget [irctolower $target]
+    set ctarget $target
+    if {[info exists nick_case($ltarget)]} { set ctarget $nick_case($ltarget) }
+
+    manyset [nickdb_get $target tellsec] sec mailto mailwhy
+    manyset [nickdb_get $target tellrel] rel relint relwithin
+    switch -exact $sec {
+	insecure - secure {
+	    set now [clock seconds]
+	    set inbound [msgsdb_get $ltarget inbound]
+	    lappend inbound $n $now $text
+	    msgsdb_set $ltarget inbound $inbound
+
+	    set outbound [msgsdb_get $n outbound]
+	    set noutbound {}
+	    set found 0
+	    foreach {recip time count} $outbound {
+		if {"[irctolower $recip]" == "$ltarget"} {
+		    incr count
+		    set recip $ctarget
+		    set found 1
+		}
+		lappend noutbound $recip $time $count
+	    }
+	    if {!$found} {
+		lappend noutbound $ctarget $now 1
+	    }
+	    msgsdb_set $n outbound $noutbound
+	    set msg "OK, I'll tell $ctarget"
+	    if {$found} { append msg " that too" }
+	    append msg ", "
+	    if {"$sec" != "secure"} {
+		switch -exact $rel {
+		    unreliable { append msg "neither reliably nor securely" }
+		    remind { append msg "pretty reliably, but not securely" }
+		    pester { append msg "reliably but not securely" }
+		}
+	    } else {
+		switch -exact $rel {
+		    unreliable { append msg "securely but not reliably" }
+		    remind { append msg "securely and pretty reliably" }
+		    pester { append msg "reliably and securely" }
+		}
+	    }
+	    append msg .
+	    ucmdr $msg {}
+	}
+	mailto {
+	    set fmtmsg [exec fmt << " $text"]
+	    exec /usr/sbin/sendmail -odb -oi -t -oee -f $mailwhy \
+		    > /dev/null << \
+ "From: $ownmailaddr ($ownfullname)
+To: $mailto
+Subject: IRC tell from $n
+
+$n asked me[expr {[ischan $dest] ? " on $dest" : ""}] to tell you:
+[exec fmt << " $text"]
+
+(This message was for your nick $ctarget; your account $mailwhy
+ arranged for it to be forwarded to $mailto.)
+"
+            ucmdr \
+ "I've mailed $ctarget at $mailto, which is what they prefer." \
+                {}
+	}
+	refuse {
+	    usererror "Sorry, $ctarget does not want me to take messages."
+	}
+	default {
+	    error "bad tellsec $sec"
+	}
+    }
+}
+
 def_ucmd who {
     if {[ta_anymore]} {
 	set target [ta_word]; ta_nomore
@@ -1168,6 +1150,9 @@ def_ucmd register {
 		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."
 	    }
 	}
+	default {
+	    error "you mean register / register delete / register insecure"
+	}
     }
 }
 
@@ -1179,7 +1164,10 @@ proc timeformat_desc {tf} {
     }
 }
 
+set settings {}
 proc def_setting {opt show_body set_body} {
+    global settings
+    lappend settings $opt
     proc set_show/$opt {} "
         upvar 1 n n
         set opt $opt
@@ -1192,6 +1180,47 @@ proc def_setting {opt show_body set_body} {
         $set_body"
 }
 
+proc tellme_sec_desc {v} {
+    manyset $v sec mailto
+    switch -exact $sec {
+	insecure {
+	    return "I'll tell you your messages whenever I see you."
+	}
+	secure {
+	    return \
+ "I'll keep the bodies of your messages private until you identify yourself."
+	}
+	refuse {
+	    return "I shan't accept messages for you."
+	}
+	mailto {
+	    return "I'll forward your messages by email to $mailto."
+	}
+	default {
+	    error "bad tellsec $sec"
+	}
+    }
+}
+
+proc tellme_rel_desc {v} {
+    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 !"
+	}
+	pester {
+	    set u {}
+	}
+	remind {
+	    set u ", or talk on channel within [showintervalsecs $within 1] of me having told you"
+	}
+	default {
+	    error "bad tellrel $rel"
+	}
+    }
+    return "I'll remind you every [showintervalsecs $every 1] until you say delmsg$u."
+}
+
 def_setting timeformat {
     set tf [nickdb_get $n timeformat]
     return "$tf: [timeformat_desc $tf]"
@@ -1226,22 +1255,11 @@ def_setting marktime {
     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"
+	set mt [parse_interval $mt $marktime_min]
     }
     nickdb_set $n marktime $mt
-    lnick_marktime_start [irctolower $n] "So:" 500
+    lnick_marktime_start [irctolower $n] "So:" 500 0
     ucmdr {} [marktime_desc $mt]
 }
 
@@ -1254,7 +1272,105 @@ def_setting security {
     }
 } {}
 
+def_setting tellme {
+    set secv [nickdb_get $n tellsec]
+    set ms [tellme_sec_desc $secv]
+    manyset $secv sec
+    switch -exact $sec {
+	insecure - secure {
+	    set mr [tellme_rel_desc [nickdb_get $n tellrel]]
+	    return "$ms  $mr"
+	}
+	refuse - mailto {
+	    return $ms
+	}
+    }
+} {
+    set setting [string tolower [ta_word]]
+    switch -exact $setting {
+	insecure - secure - refuse {
+	    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
+	}
+	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)."
+	    }
+	    set sr sec
+	    set v [list mailto [ta_word] $u]
+	}
+	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"
+		}
+	    }
+	    set sr rel
+	    set v $setting
+	    if {"$setting" != "unreliable"} {
+		set every [parse_interval [ta_word] 300]
+		lappend v $every
+	    }
+	    if {"$setting" == "remind"} {
+		if {[ta_anymore]} {
+		    set within [parse_interval [ta_word] 5]
+		} else {
+		    set within 30
+		}
+		if {$within > $every} {
+		    error "remind interval must be at least time to respond"
+		}
+		lappend v $within
+	    }
+	    ta_nomore
+	}
+	default {
+	    error "invalid tellme setting $setting"
+	}
+    }
+    nickdb_set $n tell$sr $v
+    ucmdr [tellme_${sr}_desc $v] {}
+}
+
+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 ol {}
+    set now [clock seconds]
+    while {[llength $ml]} {
+	manyset $ml r t n
+	set ml [lreplace $ml 0 2]
+	set td [expr {$now-$t}]
+	if {$n == 1} {
+	    set iv [showinterval $td]
+	    set ifo "$r, $iv"
+	    set if1 "message to $r, $iv."
+	} else {
+	    set iv [showintervalsecs $td 0]
+	    set ifo "$r, $n messages, oldest $iv"
+	    set if1 "$n messages to $r, oldest $iv."
+	}
+	if {$is1} {
+	    sendprivmsg $luser "$m1 $if1"
+	    return
+	} else {
+	    lappend ol " to $ifo[expr {[llength $ml] ? ";" : "."}]"
+	}
+    }
+    sendprivmsg $luser "$m1 messages:"
+    msendprivmsg $luser $ol
+}
+
 def_ucmd set {
+    global settings
     prefix_nick
     check_notonchan
     if {![nickdb_exists $n]} {
@@ -1262,8 +1378,7 @@ def_ucmd set {
     }
     if {![ta_anymore]} {
 	set ol {}
-	foreach proc [lsort [info procs]] {
-	    if {![regexp {^set_show/(.*)$} $proc dummy opt]} continue
+	foreach opt $settings {
 	    lappend ol [format "%-10s %s" $opt [set_show/$opt]]
 	}
 	ucmdr {} [join $ol "\n"]
@@ -1273,7 +1388,7 @@ def_ucmd set {
 	    error "no setting $opt"
 	}
 	if {![ta_anymore]} {
-	    ucmdr {} "$opt [set_show/$opt]"
+	    ucmdr {} "$opt: [set_show/$opt]"
 	} else {
 	    nick_securitycheck 0
 	    if {[catch { info body set_set/$opt }]} {
@@ -1383,32 +1498,34 @@ proc lnick_marktime_cancel {luser} {
     catch { unset mi }
 }
 
-proc lnick_marktime_doafter {luser why ms} {
+proc lnick_marktime_doafter {luser why ms mentiontold} {
     lnick_marktime_cancel $luser
     upvar #0 nick_markid($luser) mi
-    set mi [after $ms [list lnick_marktime_now $luser $why]]
+    set mi [after $ms [list lnick_marktime_now $luser $why 0]]
 }
 
 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}]
+    lnick_marktime_doafter $luser "Time passes." [expr {$mt*1000}] 0
 }
 
-proc lnick_marktime_start {luser why ms} {
+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]
     } else {
-	lnick_marktime_doafter $luser $why $ms
+	lnick_marktime_doafter $luser $why $ms $mentiontold
     }
 }
 
-proc lnick_marktime_now {luser why} {
+proc lnick_marktime_now {luser why mentiontold} {
     upvar #0 nick_onchans($luser) oc
     global calling_nick
     set calling_nick $luser
     sendprivmsg $luser [lnick_pingstring $why $oc ""]
+    if {$mentiontold} { lnick_checktold $luser }
     lnick_marktime_reset $luser
 }    
 
@@ -1417,7 +1534,7 @@ proc lnick_pingstring {why oc apstring} {
     catch { exec uptime } uptime
     set nnicks [llength [array names nick_onchans]]
     if {[regexp \
- {^ *([0-9:apm]+) +up.*, +(\d+) users, +load average: +([0-9., ]+) *$} \
+ {^ *([0-9:apm]+) +up.*, +(\d+) users?, +load average: +([0-9., ]+) *$} \
             $uptime dummy time users load]} {
 	regsub -all , $load {} load
         set uptime "$time  $nnicks/$users  $load"
@@ -1445,12 +1562,12 @@ proc lnick_pingstring {why oc apstring} {
 }
 
 def_ucmd ping {
+    prefix_nick
+    set ln [irctolower $n]
     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 {
@@ -1458,6 +1575,7 @@ def_ucmd ping {
 	}
 	if {[llength $oc]} { lnick_marktime_reset $ln }
     }
+    lnick_checktold $ln
     ucmdr {} [lnick_pingstring "Pong!" $oc $text]
 }
 
@@ -1473,50 +1591,12 @@ proc ensure_globalsecret {} {
     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 crlf
-
-    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 }
     }
 }
 
 ensure_globalsecret
-ensure_outqueue
 loadhelp
 ensure_connecting