########### stall.tcl
#
# Pure-teergrube server (over-aggressive callers are diverted here)
#
# 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: stall.tcl,v 1.1.4.1 2008/03/08 15:42:34 ian Exp $


########## stalling threads
# thread_start $chan $desc
#
# errors/results ignored
#
# state variables:
#
# Always set:
# chan              incoming SMTP connection
# counter           no. of messages we have sent
# timeout           id of timeout after (or unset)

thread_typedefine stall {ra chan explain} {
    global nstalls stalls_max addrconcurr
    set state(chan) $chan
    set state(counter) 0

    set stallscounts "$addrconcurr(nstalls:$ra)/$nstalls/$stalls_max"
    log reject "$ra stalling ($stallscounts) $explain"
    fconfigure $state(chan) -buffering none
    threadio_gets stall $id $state(chan) finish finish
    stall_pause {} $explain
} {
    thread_finish stall $id
} {
    catch { after cancel $state(timeout) }
    catch { fileevent $state(chan) readable {} }
    catch { fileevent $state(chan) writable {} }
}

thread_subproc stall pause {newline message} {
    global stall_interval
    set state(timeout) [thread_after stall $id $stall_interval \
	    write $newline $message]
}

thread_chainproc stall write {newline message} {
    global stall_count command_timeout
    incr state(counter)
    set resp $newline
    append resp 421
    if {$state(counter) < $stall_count} {
	append resp "-$message"
	set onok written
    } else {
	append resp " $message\n"
	set onok finish
    }
    set state(timeout) [thread_after \
	    stall $id $command_timeout stall finish]
    threadio_puts stall $id $state(chan) $resp $onok finish
}

thread_chainproc stall written {} {
    after cancel $state(timeout)
    stall_pause "\n" $state(counter)
}

thread_chainproc stall finish {args} {
    thread_finish stall $id
}
