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