sauce 0.9.0+nmu3 / usr / sbin / sauce

#! /usr/bin/tclsh
#
# This file is part of SAUCE, a very picky anti-spam receiver-SMTP.
# SAUCE is Copyright (C) 1997-2003 Ian Jackson
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2, or (at your option)
# any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software Foundation,
# Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 
#
# $Id: sauce.tcl,v 1.113 2006/04/02 23:40:53 ian Exp $

# wishlist: blacklist even if spam-message aborted
# wishlist: use adns client instead of host
# wishlist: limit number of simultaneous connections from one host or /24

# set tcl_traceExec 1

set sauce_libraries {
    readconf
    library
    thread
    dns
    avf
    avfpool
    smtp
    msgdata
    notifybl
    datastate
    yesmaster
    sconfig
    stall
}
source /usr/share/sauce/readlibs

proc readconfig_posthook {} {
    global fill_msgs canonical_hostname

    if {![info exists fill_msgs]} {
	set fill_msgs [list \
 "Your system has had many errors while trying to send us mail." \
 "Teergrube (spam countermeasure) triggered: stalling SMTP responses." \
 "Please consult your system administrator or postmaster." \
 "Check your retry configuration, and look for spam in your queue." \
 "Queries ?  Contact postmaster@$canonical_hostname." \
 ]
    }
    addr_patterns_compile
    dns_readconfig

    return {}
}

proc addr_patterns_compile {} {
    global addr_patterns

    set donelocal 0
    set el {}
    set preproc    "    upvar 1 state state\n"
    append preproc "    set dm \[string tolower \$dm\]\n"
    set proc {}
    foreach le $addr_patterns {
	manyset $le at ap
	set cond {}
	if {[regexp {(.*)\@$} $ap dm ap]} {
	    if {!$donelocal} {
		append preproc \
			"    global local_domain\n" \
			"    set islocal \[info exists local_domain(\$dm)\]\n"
		set donelocal 1
	    }
	    append cond {$islocal && }
	    set matchag {$lp}
	} else {
	    set matchag {$lp@$dm}
	}
	append cond "\[[list regexp "^$ap$"]"
	append cond " $matchag dummy d1\]"
	set subpolicy {}
	if {[regexp {^(user|policy)\=(.+)$} $at dummy up subpolicy] || \
		[regexp {^(user|policy)$} $at dummy up]} {
	    set policy {}
	    if {"$up" == "policy"} {
		set policy [list :$subpolicy]
	    } elseif {[string length $subpolicy]} {
		set policy [list $subpolicy]
	    } else {
		set policy {[addr_classify_safed1 $d1]}
	    }
	    if {[regexp {\:$} $subpolicy]} {
		append policy {[addr_classify_safed1 $d1]}
	    }
	    append cond " && \[addr_classify_policy $policy\]"
	    set at \$at
	}
	append proc "    if [list $cond] {\n"
	append proc "        return $at\n"
	append proc "    }\n"
    }
    append proc "    return normal\n"
    proc addr_classify_compound {lp dm} $preproc$proc
}

proc addr_classify_safed1 {d1} {
    regsub -nocase -all {[^-+_.%$0-9a-z]} $d1 ? d1
    regexp -nocase {^([-+_.%$0-9a-z?]{0,126})(.*)$} $d1 dummy d1 rhs
    if {[string length $rhs]} { append d1 * }
    return $d1
}

proc addr_classify_policy {user} {
    foreach v {state lp dm at} { upvar 1 $v $v }
    global policy_file policies_dir errorCode policy_file

    if {[regexp {/} $user] || [regexp {^\.} $user]} {
	error "policy name contains / or starts with .: `$user'"
    }

    set filename $policies_dir/p$user
    upvar #0 acuser_dit($user) dit
    if {[catch {
	file stat $filename statinfo
	set newdit "$statinfo(dev) $statinfo(ino) $statinfo(ctime)"
	if {![info exists dit] || "$dit" != "$newdit"} {
	    source $filename
	    set dit $newdit
	}
    } emsg]} {
	manyset $errorCode posix enoent string
	catch { unset dit }
	if {"$posix" != "POSIX"} {
	    error "$emsg (unexpected error code $errorCode)"
	}
	if {"$enoent" != "ENOENT"} {
	    set at [list 451 "unable to check user $user policy: $string"]
	    return 1
	}
	return 0
    }
    set nat [acuser_proc/$user]
    if {![string length $nat]} { return 0 }
    set at $nat
    return 1
}

proc addr_classify {lp dm statevar} {
    upvar 1 $statevar state
    set class [addr_classify_compound $lp $dm]
    set errok [regexp {^errok\-(.*)$} $class dummy class]
    return [list $class $errok]
}

set nconns 0
set nstalls 0

readconfig

if {![file isdirectory $var_dir]} {
    error "database directory $var_dir is not an existing directory"
}

set avfchancounter 0
if {[info exists asynch_appdebug]} {
    set debug_level $asynch_appdebug
}

########## controlling stuff

proc shutdown {} {
    global force_shutdown_delay
    log notice "shutdown request received"
    after $force_shutdown_delay {
	thread_forceshutdown
    }
    thread_sysshutdown {
	log notice "shutting down now"
	exit
    }
}

proc decr_conncount {nkind ra} {
    global addrconcurr $nkind
    if {![incr addrconcurr($nkind:$ra) -1]} { unset addrconcurr($nkind:$ra) }
    incr $nkind -1
}

proc incr_conncount {nkind ra} {
    global addrconcurr $nkind
    upvar #0 addrconcurr($nkind:$ra) acra
    if {![info exists acra]} { set acra 0 }
    incr acra
    incr $nkind
    return $acra
}

proc conn_done {nkind chan ra lh args} {
    catch_close_cleardesc chan
    decr_conncount $nkind $ra
}

proc conn_err {nkind chan ra lh printwhat emsg} {
    global canonical_hostname fail_send_timeout
    if {[catch {
	set resp "421 $canonical_hostname $printwhat, try later"
	set m failed
	logreject_val m addr $ra
	logreject_val m resp $resp
	logreject_val m why $emsg
	log reject $m
	set toid [after $fail_send_timeout conn_done $nkind $chan $ra $lh]
 	threadio_puts {} {} $chan "$resp\r\n" conn_err_done conn_err_done \
		$nkind $chan $ra $lh $toid
    }]} {
	conn_done $nkind $chan $ra $lh
    }
}

proc conn_err_done {nkind chan ra lh toid args} {
    after cancel $toid
    conn_done $nkind $chan $ra $lh
}

proc new_conn_checkbusy {chan ra lh desc tcount tmax msg} {
    # => 1 iff we are too busy (will then have called conn_err)
    global annoyance_toobusy annoy_grudge_max nstalls stalls_max
    global annoy_grumpy nconns busyfury_firewall
    if {$tcount <= $tmax} { return 0 }
    manyset [intern_getsiteannoy $ra $annoyance_toobusy] annoyval annoytype
    if {$busyfury_firewall==1 && $annoyval == $annoy_grudge_max} {
        bff_add $ra
    }

    set explain \
	    "$msg ($tcount/$tmax $annoyval) \[[irrit_present $annoytype]\]"

    if {$nstalls < $stalls_max && $annoyval > $annoy_grumpy} {
	decr_conncount nconns $ra
	incr_conncount nstalls $ra
	set thread [thread_start stall $desc-stall $ra $chan $explain]
	thread_join {} {} stall $thread conn_done conn_err \
	    nstalls $chan $ra $lh "Internal error in stall"
    } else {
        conn_err nconns $chan $ra $lh $explain {}
	if {$busyfury_firewall==2} { bff_add $ra }
    }
    return 1
}

proc new_conn {chan ra rp} {
    global ipaddr_phase_proportion ipaddr_phase_offset local_interface current_bigerr
    global nconns conns_max annoy_love_max annoy_grudge_max

    if {[catch {
	if {$ipaddr_phase_proportion < 256 && \
	    ![info exists local_interface($ra)]} {
	    set cp $ipaddr_phase_offset
	    foreach tb [split $ra .] fc {3 23 73 131} {
		set cp [expr {($cp+$tb*$fc)%256}]
	    }
	    if {$cp < $ipaddr_phase_proportion} {
		log notice "$ra connected, phase $cp < $ipaddr_phase_proportion"
	    } else {
 log notice "$ra connected, phase $cp >= $ipaddr_phase_proportion, twisting"
		fconfigure $chan -blocking true
		exec <@ $chan >@ $chan sh -c { sendmail -bs <&1 & }
		return
	    }
	}
	set lalhlp [fconfigure $chan -sockname]
	fconfigure $chan -translation {binary crlf} -blocking false
    } emsg]} {
	if {[string length $emsg]} { log error "get local address: $emsg" }
	catch { close $chan }
    } else {
	set lh [lindex $lalhlp 1]
	set desc "$lh-$ra:$rp"
	if {$ipaddr_phase_proportion == 256} { debug0 1 "$desc connected" }

	set acra [incr_conncount nconns $ra]

	chanset_desc $chan $desc
	if {[thread_shuttingdown]} {
	    conn_err nconns $chan $ra $lh "Shutting down" {}
	} elseif {[string length $current_bigerr]} {
	    conn_err nconns $chan $ra $lh $current_bigerr {}
	    set current_bigerr {}
	    readconfig
	    reopenlogs
	} else {
	    manyset [intern_getsiteannoy $ra 0] annoyval annoytype
	    if {$annoyval > 0} {
		set tmax [expr {int(
		    double($conns_max) *
		    pow(0.25, sqrt(double($annoyval) / double($annoy_grudge_max)))
		)}]
		if {[new_conn_checkbusy $chan $ra $lh $desc $nconns $tmax \
			"Too busy"]} return
	    }
	    set tmax [expr {int(
		double($conns_max) *
		-double($annoyval) / double($annoy_love_max)
	    )}]
	    if {$acra>1 && \
		[new_conn_checkbusy $chan $ra $lh $desc $acra $tmax \
		    "Excessive concurrency"]} return
	    set thread [thread_start ic $desc $chan $lalhlp $ra $rp]
	    thread_join {} {} ic $thread conn_done conn_err \
		    nconns $chan $ra $lh "Internal error"
	}
    }
}

proc bff_log {addr how} {
    log reject "firewall addr=$addr $how"
}

proc bff_add {addr} {
    global busyfury_firewall busyfury_firewall_time bff_addrs
    if {!$busyfury_firewall || !$busyfury_firewall_time} return
    if {[info exists bff_addrs($addr)]} return
    set bff_addrs($addr) [after $busyfury_firewall_time bff_expire $addr]
    bff_log $addr deny
    bff_setup
}

proc bff_expire {addr} {
    global bff_addrs
    unset bff_addrs($addr)
    bff_log $addr accept
    bff_setup
}

proc bff_setup {} {
    global busyfury_firewall bff_addrs firewall_command
    if {!$busyfury_firewall} return
    set addrs [array names bff_addrs]
    set cmd [concat [list $firewall_command < /dev/null] $addrs]
    if {[catch {
	eval exec $cmd
    } emsg]} {
	log error "unable to set firewall state: $emsg"
    } else {
	set result [split $emsg "\n"]
	foreach l $result {
	    log debug "set firewall: $l"
	}
    }
}

proc globalavfpool_start {} {
    global avfpoolid
    set avfpoolid [thread_start avfpool avfpool]
    thread_join {} {} avfpool $avfpoolid globalavfpool_done globalavfpool_done
}

proc globalavfpool_done {args} {
    log error "avfpool done !  report: $args"
    globalavfpool_start
}

proc setstate {type entry why args} {
    global var_dir errorInfo errorCode
    log dbreasons [list $type $entry [lindex $args 0] $why]
    eval [list ds_set $type-list $entry] $args
}

proc databases_init {} {
    global var_dir
    global initdb_file

    foreach what {addr site} \
	    re {{^(black|white|whitesoon|verified)$} {^(black|white|whitesoon)$}} \
	    doquote {1 0} {
	ds_bind $what-list $var_dir/cdb.$what-list $re $doquote
	ds_bind $what-seen $var_dir/cdb.$what-seen {^\d+$} $doquote
    }
    ds_bind site-annoy $var_dir/cdb.site-annoy {^\d+am?\d+$} 0

    set f [open $initdb_file r]
    set lno 0
    while {[gets $f l] != -1} {
	incr lno
	if {[regexp {^\#} $l]} { continue }
	if {![regexp {^(site|addr)\s+(white|black)\s+(.*\S)\s*$} \
		     $l dummy type state keyquoted]} {
	    error "$filename:$lno:bad format in blacklist/whitelist config"
	}
	set key [subst -nocommands -novariables $keyquoted]
	ds_setforever $type-list $key $state
    }
    close $f
}

if {[catch {
    if {[llength $real_argv]} {
	error "please supply no non-option arguments"
    }
    reopenlogs
    if {[file writable /]} {
	error "do not run sauce as root; use something like authbind instead"
    }
    databases_init
} emsg]} {
    if {![string length $current_bigerr]} {
	log fatal "error starting up: $emsg ($errorInfo)"
	set current_bigerr "Error starting up"
    }
}

if {[string length $current_bigerr]} {
    log fatal "fatal errors, stopping ($current_bigerr)";
    exit 1
}

set adminsecret {}
globalavfpool_start

if {[catch {
    if {[array size local_interface]} {
	foreach li [array names local_interface] {
	    socket -myaddr $li -server new_conn $port
	}
    } else {
	socket -server new_conn $port
    }

    thread_start adminsecret admin-secret
    bff_setup
    log notice started

    if {![info exists asynch_script]} {
	vwait quit_now
    }
} emsg]} {
    log fatal "main program returned error: $emsg, $errorInfo"
}