1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
|
#!/usr/bin/env wish
## -*- tcl -*-
# 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 {[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 . <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:
|
