1#! /bin/sh
2# -*- tcl -*- \
3exec wish "$0" ${1+"$@"}
4
5# tk_smtpd -Copyright (C) 2004 Pat Thoyts <patthoyts@users.sourceforge.net>
6#
7# Test of the mail server. All incoming messages are displayed in a 
8# message dialog. This version requires smtpd 1.3.0 which has support for
9# secure mail transactions. If you have the tls package available then the
10# mail connection will be upgraded as per RFC 3207.
11#
12# For this to work smtpd::configure command must be called with some options
13# for the tls::import command. See the tls package documentation and this
14# example for details. A server certificate is required as well. A 
15# demonstration self-signed certificate is provided.
16#
17# Usage tk_smtpd 0.0.0.0 8025
18#    or tk_smtpd 127.0.0.1 2525
19#    or tk_smtpd
20# to listen to the default port 25 on all tcp/ip interfaces. 
21# Alternatively you may configure the server via the GUI.
22#
23# -------------------------------------------------------------------------
24# This software is distributed in the hope that it will be useful, but
25# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
26# or FITNESS FOR A PARTICULAR PURPOSE.  See the file 'license.terms' for
27# more details.
28# -------------------------------------------------------------------------
29
30package require Tcl   8.3
31package require Tk    8.3
32package require mime  1.3
33package require smtpd 1.4
34
35variable options
36if {![info exists options]} {
37    set dir [file dirname [info script]]
38    array set options [list \
39        loglevel   debug    \
40        interface  0.0.0.0  \
41        port       2525     \
42        usetls     1        \
43        require    0        \
44        request    1        \
45        certfile           [file join $dir server-public.pem] \
46        keyfile            [file join $dir server-private.key] \
47    ]
48}
49
50variable forever
51if {![info exists forever]} { set forever 0 }
52variable console
53if {![info exists console]} { set console 0 }
54
55wm title . "Tcllib SMTPd [package provide smtpd] Demo"
56set _dlgid 0
57
58# Handle new mail by raising a message dialog for each recipient.
59proc deliverMIME {token} {
60
61    set senders [mime::getheader $token From]
62    set recipients [mime::getheader $token To]
63
64    if {[catch {eval array set saddr \
65                    [mime::parseaddress [lindex $senders 0]]}]} {
66        error "invalid sender address \"$senders\""
67    }
68    set mail "From $saddr(address) [::smtpd::timestamp]\n"
69    append mail [mime::buildmessage $token]
70    foreach rcpt $recipients {
71        if {! [catch {eval array set addr [mime::parseaddress $rcpt]}]} {
72            display "To: $addr(address)" $mail
73        }
74    }
75}
76
77proc display {title mail} {
78    global _dlgid
79    incr _dlgid
80    set dlg [toplevel .dlg$_dlgid]
81    set txt [text ${dlg}.e -yscrollcommand [list ${dlg}.sb set]]
82    set scr [scrollbar ${dlg}.sb -command [list $txt yview]]
83    set but [button ${dlg}.b -text "Dismiss" -command [list destroy $dlg]]
84    grid $txt $scr -sticky news
85    grid $but   -  -sticky ns
86    grid rowconfigure    $dlg 0 -weight 1
87    grid columnconfigure $dlg 0 -weight 1
88    wm title $dlg $title
89    $txt insert 0.0 [string map {\r\n \n} $mail]
90}
91
92# Accept everyone except those spammers on 192.168.1.* :)
93proc validate_host {ipnum} {
94    if {[string match "192.168.1.*" $ipnum]} {
95        error "your domain is not allowed to post, Spammers!"
96    }
97}
98
99# Accept mail from anyone except user 'denied'
100proc validate_sender {address} {
101    eval array set addr [mime::parseaddress $address]
102    if {[string match "denied" $addr(local)]} {
103        error "mailbox $addr(local) denied"
104    }
105    return    
106}
107
108# Only reject mail for recipients beginning with 'bogus'
109proc validate_recipient {address} {
110    eval array set addr [mime::parseaddress $address]
111    if {[string match "bogus*" $addr(local)]} {
112        error "mailbox $addr(local) denied"
113    }
114    return
115}
116
117# -------------------------------------------------------------------------
118
119proc Start {} {
120    variable options
121    smtpd::configure \
122        -loglevel           $options(loglevel) \
123        -deliverMIME        ::deliverMIME \
124        -validate_host      ::validate_host \
125        -validate_recipient ::validate_recipient \
126        -validate_sender    ::validate_sender \
127        -certfile           $options(certfile) \
128        -keyfile            $options(keyfile) \
129        -usetls             $options(usetls) \
130        -ssl2               1 \
131        -ssl3               1 \
132        -tls1               1 \
133        -require            $options(require) \
134        -request            $options(request) \
135        -command            ::smtpd::tlscallback
136
137    smtpd::start $options(interface) $options(port)
138}
139
140proc Stop {} {
141    smtpd::stop
142}
143
144proc Exit {} {
145    variable forever
146    Stop
147    set forever 1
148}
149
150proc ${::smtpd::log}::stdoutcmd {level text} {
151    .t insert end "$text\n" $level
152    .t see end
153}
154
155proc tkerror {msg} {
156    .t insert end "$msg\n" error
157    .t see end
158}
159
160proc ToggleConsole {} {
161    variable console
162    if {[info command console] ne {}} {
163        if {$console} {
164            console hide ; set console 0
165        } else {
166            console show ; set console 1
167        }
168    }
169}
170
171# Configure a GUI
172proc Main {} {
173    variable options
174    label .l1 -text "Address" -anchor nw
175    entry .e1 -textvariable ::options(interface)
176    label .l2 -text "Port" -anchor nw
177    entry .e2 -textvariable ::options(port)
178    label .l3 -text "Public certificate file" -anchor nw
179    entry .e3 -textvariable ::options(certfile)
180    label .l4 -text "Private key file" -anchor nw
181    entry .e4 -textvariable ::options(keyfile)
182    label .l5 -text "Log level" -anchor nw
183    entry .e5 -textvariable ::options(loglevel)
184
185    frame .f3 -borderwidth 0
186    checkbutton .c1 -text "Support TLS" -variable ::options(usetls)
187    checkbutton .c2 -text "Request cerificate" -variable ::options(request)
188    checkbutton .c3 -text "Require certificate" -variable ::options(require)
189    grid .c1 .c2 .c3 -in .f3 -sticky news
190
191    frame .f1 -borderwidth 0
192    text .t -height 10 -yscrollcommand [list .sb set]
193    scrollbar .sb -command [list .t yview]
194    grid .t .sb -in .f1 -sticky news
195    
196    frame  .f2 -borderwidth 0
197    button .b1 -width -12 -text Start -command Start
198    button .b2 -width -12 -text Stop -command Stop
199    button .b3 -width -12 -text Exit -command Exit
200    grid   .b1 .b2 .b3 -in .f2 -sticky ne -padx 1 -pady 2
201
202    grid .l1 .e1 .l2 .e2  -sticky news
203    grid .f3 -   -   -    -sticky news
204    grid .l3 .e3 -   -    -sticky news
205    grid .l4 .e4 -   -    -sticky news
206    grid .f1 -   -   -    -sticky news
207    grid .l5 .e5 .f2 -    -sticky ne
208    grid rowconfigure    . 4 -weight 1
209    grid columnconfigure . 3 -weight 1
210    grid rowconfigure    .f1 0 -weight 1
211    grid columnconfigure .f1 0 -weight 1
212
213    bind . <F2> {ToggleConsole}
214}
215
216# -------------------------------------------------------------------------
217
218if {$tcl_interactive } {
219
220    puts {you'll want to issue 'smtpd::start' to begin}
221
222} else {
223
224    if {$argc > 0} {
225        set iface [lindex $argv 0]
226    }
227    if {$argc > 1} {
228        set port [lindex $argv 1]
229    }
230
231    Main
232    tkwait variable forever
233    destroy .
234}
235
236#
237# Local variables:
238#  mode: tcl
239#  indent-tabs-mode: nil
240# End:
241