#!/usr/bin/env wish ## -*- tcl -*- # tk_smtpd -Copyright (C) 2004 Pat Thoyts # # 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 {[llength [info commands console]]} { 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 . {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: