#! /bin/sh
#
# tk_smtpdMIME -Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net>
#
# Simple test of the mail server. All incoming messages are displayed in a 
# message dialog.
#
# This uses the new MIME token passing interface to the smtpd module.
#
# This example works nicely under Windows or within tkcon.
#
# Usage tk_smtpd 0.0.0.0 8025
#    or tk_smtpd 127.0.0.1 2525
#    or tk_smtpd
# to listen to the default port 25 on all tcp/ip interfaces.
#
# -------------------------------------------------------------------------
# This software 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 file 'license.terms' for
# more details.
# -------------------------------------------------------------------------
# \
exec wish "$0" ${1+"$@"}

package require smtpd
package require mime
package require Tk
wm withdraw .
set _dlgid 0

# Handle new mail by raising a message dialog for each recipient.
proc deliverMIME {token} {

    set senders [mime::getheader $token From]
    set recipients [mime::getheader $token To]

    if {[catch {eval array set saddr \
                    [mime::parseaddress [lindex $senders 0]]}]} {
        error "invalid sender address \"$senders\""
    }
    set mail "From $saddr(address) [clock format [clock seconds]]\n"
    append mail [mime::buildmessage $token]
    foreach rcpt $recipients {
        if {! [catch {eval array set addr [mime::parseaddress $rcpt]}]} {
            display "To: $addr(address)" $mail
        }
    }
}

proc display {title mail} {
    global _dlgid
    incr _dlgid
    set dlg [toplevel .dlg$_dlgid]
    set frm [frame ${dlg}.f -bd 0]
    set txt [text ${frm}.e -yscrollcommand [list ${frm}.sb set]]
    set scr [scrollbar ${frm}.sb -command [list $txt yview]]
    set but [button ${dlg}.b -text "Dismiss" -command [list destroy $dlg]]
    pack $scr -side right -fill y
    pack $txt -side left -fill both -expand 1
    pack $frm -side top -fill both -expand 1
    pack $but -side bottom
    wm title $dlg $title
    $txt insert 0.0 $mail
}

# Accept everyone except those spammers on 192.168.1.* :)
proc validate_host {ipnum} {
    if {[string match "192.168.1.*" $ipnum]} {
        error "your domain is not allowed to post, Spammers!"
    }
}

# Accept mail from anyone except user 'denied'
proc validate_sender {address} {
    eval array set addr [mime::parseaddress $address]
    if {[string match "denied" $addr(local)]} {
        error "mailbox $addr(local) denied"
    }
    return    
}

# Only reject mail for recipients beginning with 'bogus'
proc validate_recipient {address} {
    eval array set addr [mime::parseaddress $address]
    if {[string match "bogus*" $addr(local)]} {
        error "mailbox $addr(local) denied"
    }
    return
}

# Setup the mail server
smtpd::configure \
    -deliverMIME        ::deliverMIME \
    -validate_host      ::validate_host \
    -validate_recipient ::validate_recipient \
    -validate_sender    ::validate_sender

# Run the server on the default port 25. For unix change to 
# a high numbered port eg: 2525 or 8025 etc with
# smtpd::start 127.0.0.1 8025 or smtpd::start 0.0.0.0 2525

set iface 0.0.0.0
set port 25

if {$tcl_interactive } {

    puts {you'll want to issue 'smtpd::start' to begin}

} else {

    if {$argc > 0} {
        set iface [lindex $argv 0]
    }
    if {$argc > 1} {
        set port [lindex $argv 1]
    }
        
    smtpd::start $iface $port
}

#
# Local variables:
#  mode: tcl
#  indent-tabs-mode: nil
# End: