#! /bin/sh
# -*- tcl -*- \
exec wish "$0" ${1+"$@"}

# tk_smtpdTLS -Copyright (C) 2004 Pat Thoyts <patthoyts@users.sourceforge.net>
#
# Test of the mail server. All incoming messages are displayed in a 
# message dialog. This version requires smtpd 1.3.0 which has support for
# secure mail transactions. If you have the tls package available then the
# mail connection will be upgraded as per RFC 3207.
#
# For this to work smtpd::configure command must be called with some options
# for the tls::import command. See the tls package documentation and this
# example for details. A server certificate is required as well. A 
# demonstration self-signed certificate is provided.
#
# This example works nicely under Windows or within tkcon.
#
# Usage tk_smtpdTLS 0.0.0.0 8025
#    or tk_smtpdTLS 127.0.0.1 2525
#    or tk_smtpdTLS
# 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.
# -------------------------------------------------------------------------

package require Tcl   8.3
package require Tk    8.3
package require mime  1.3
package require smtpd 1.3

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) [::smtpd::timestamp]\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 txt [text ${dlg}.e -yscrollcommand [list ${dlg}.sb set]]
    set scr [scrollbar ${dlg}.sb -command [list $txt yview]]
    set but [button ${dlg}.b -text "Dismiss" -command [list destroy $dlg]]
    grid $txt $scr -sticky news
    grid $but   -  -sticky ns
    grid rowconfigure    $dlg 0 -weight 1
    grid columnconfigure $dlg 0 -weight 1
    wm title $dlg $title
    $txt insert 0.0 [string map {\r\n \n} $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 with TLS support.
set dir [file dirname [info script]]
smtpd::configure \
    -loglevel           debug \
    -deliverMIME        ::deliverMIME \
    -validate_host      ::validate_host \
    -validate_recipient ::validate_recipient \
    -validate_sender    ::validate_sender \
    -certfile           [file join $dir server-public.pem] \
    -keyfile            [file join $dir server-private.key] \
    -usetls             1 \
    -ssl2               1 \
    -ssl3               1 \
    -tls1               1 \
    -require            0 \
    -request            1

# For windows, display the console for the log messages.
if {[info command console] != {}} {
    console show
    console eval {wm title . "Test SMTPD"}
}
proc ::tkerror {err} {puts stderr $err}
catch {set ::tls::debug 2}
smtpd::Log debug "[smtpd::configure]"

# 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:
