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

# tk_smtpd -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.
#
# 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. 
# Alternatively you may configure the server via the GUI.
#
# -------------------------------------------------------------------------
# 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.4

variable options
if {![info exists options]} {
    set dir [file dirname [info script]]
    array set options [list \
        loglevel   debug    \
        interface  0.0.0.0  \
        port       2525     \
        usetls     1        \
        require    0        \
        request    1        \
        certfile           [file join $dir server-public.pem] \
        keyfile            [file join $dir server-private.key] \
    ]
}

variable forever
if {![info exists forever]} { set forever 0 }
variable console
if {![info exists console]} { set console 0 }

wm title . "Tcllib SMTPd [package provide smtpd] Demo"
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
}

# -------------------------------------------------------------------------

proc Start {} {
    variable options
    smtpd::configure \
        -loglevel           $options(loglevel) \
        -deliverMIME        ::deliverMIME \
        -validate_host      ::validate_host \
        -validate_recipient ::validate_recipient \
        -validate_sender    ::validate_sender \
        -certfile           $options(certfile) \
        -keyfile            $options(keyfile) \
        -usetls             $options(usetls) \
        -ssl2               1 \
        -ssl3               1 \
        -tls1               1 \
        -require            $options(require) \
        -request            $options(request) \
        -command            ::smtpd::tlscallback

    smtpd::start $options(interface) $options(port)
}

proc Stop {} {
    smtpd::stop
}

proc Exit {} {
    variable forever
    Stop
    set forever 1
}

proc ${::smtpd::log}::stdoutcmd {level text} {
    .t insert end "$text\n" $level
    .t see end
}

proc tkerror {msg} {
    .t insert end "$msg\n" error
    .t see end
}

proc ToggleConsole {} {
    variable console
    if {[info command console] ne {}} {
        if {$console} {
            console hide ; set console 0
        } else {
            console show ; set console 1
        }
    }
}

# Configure a GUI
proc Main {} {
    variable options
    label .l1 -text "Address" -anchor nw
    entry .e1 -textvariable ::options(interface)
    label .l2 -text "Port" -anchor nw
    entry .e2 -textvariable ::options(port)
    label .l3 -text "Public certificate file" -anchor nw
    entry .e3 -textvariable ::options(certfile)
    label .l4 -text "Private key file" -anchor nw
    entry .e4 -textvariable ::options(keyfile)
    label .l5 -text "Log level" -anchor nw
    entry .e5 -textvariable ::options(loglevel)

    frame .f3 -borderwidth 0
    checkbutton .c1 -text "Support TLS" -variable ::options(usetls)
    checkbutton .c2 -text "Request cerificate" -variable ::options(request)
    checkbutton .c3 -text "Require certificate" -variable ::options(require)
    grid .c1 .c2 .c3 -in .f3 -sticky news

    frame .f1 -borderwidth 0
    text .t -height 10 -yscrollcommand [list .sb set]
    scrollbar .sb -command [list .t yview]
    grid .t .sb -in .f1 -sticky news
    
    frame  .f2 -borderwidth 0
    button .b1 -width -12 -text Start -command Start
    button .b2 -width -12 -text Stop -command Stop
    button .b3 -width -12 -text Exit -command Exit
    grid   .b1 .b2 .b3 -in .f2 -sticky ne -padx 1 -pady 2

    grid .l1 .e1 .l2 .e2  -sticky news
    grid .f3 -   -   -    -sticky news
    grid .l3 .e3 -   -    -sticky news
    grid .l4 .e4 -   -    -sticky news
    grid .f1 -   -   -    -sticky news
    grid .l5 .e5 .f2 -    -sticky ne
    grid rowconfigure    . 4 -weight 1
    grid columnconfigure . 3 -weight 1
    grid rowconfigure    .f1 0 -weight 1
    grid columnconfigure .f1 0 -weight 1

    bind . <F2> {ToggleConsole}
}

# -------------------------------------------------------------------------

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]
    }

    Main
    tkwait variable forever
    destroy .
}

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