diff options
author | William Joye <wjoye@cfa.harvard.edu> | 2016-10-27 19:39:39 (GMT) |
---|---|---|
committer | William Joye <wjoye@cfa.harvard.edu> | 2016-10-27 19:39:39 (GMT) |
commit | ea28451286d3ea4a772fa174483f9a7a66bb1ab3 (patch) | |
tree | 6ee9d8a7848333a7ceeee3b13d492e40225f8b86 /tcllib/modules/smtpd | |
parent | b5ca09bae0d6a1edce939eea03594dd56383f2c8 (diff) | |
parent | 7c621da28f07e449ad90c387344f07a453927569 (diff) | |
download | blt-ea28451286d3ea4a772fa174483f9a7a66bb1ab3.zip blt-ea28451286d3ea4a772fa174483f9a7a66bb1ab3.tar.gz blt-ea28451286d3ea4a772fa174483f9a7a66bb1ab3.tar.bz2 |
Merge commit '7c621da28f07e449ad90c387344f07a453927569' as 'tcllib'
Diffstat (limited to 'tcllib/modules/smtpd')
-rw-r--r-- | tcllib/modules/smtpd/ChangeLog | 191 | ||||
-rw-r--r-- | tcllib/modules/smtpd/clients/README | 13 | ||||
-rw-r--r-- | tcllib/modules/smtpd/clients/mail-test.php | 21 | ||||
-rw-r--r-- | tcllib/modules/smtpd/clients/mail-test.pl | 121 | ||||
-rw-r--r-- | tcllib/modules/smtpd/clients/mail-test.py | 53 | ||||
-rw-r--r-- | tcllib/modules/smtpd/clients/mail-test.rb | 16 | ||||
-rw-r--r-- | tcllib/modules/smtpd/clients/mail-test.tcl | 15 | ||||
-rw-r--r-- | tcllib/modules/smtpd/clients/php.ini | 56 | ||||
-rw-r--r-- | tcllib/modules/smtpd/pkgIndex.tcl | 12 | ||||
-rw-r--r-- | tcllib/modules/smtpd/smtpd.man | 294 | ||||
-rw-r--r-- | tcllib/modules/smtpd/smtpd.tcl | 924 |
11 files changed, 1716 insertions, 0 deletions
diff --git a/tcllib/modules/smtpd/ChangeLog b/tcllib/modules/smtpd/ChangeLog new file mode 100644 index 0000000..90c634c --- /dev/null +++ b/tcllib/modules/smtpd/ChangeLog @@ -0,0 +1,191 @@ +2013-02-01 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.15 ======================== + * + +2011-12-13 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.14 ======================== + * + +2011-04-11 Andreas Kupries <andreask@activestate.com> + + * smtpd.man: [RFE 3247765]: Added option to configure the + * smtpd.tcl: smtpd greeting/banner. Bumped to version 1.5 + * pkgIndex.tcl + +2011-01-24 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.13 ======================== + * + +2009-12-07 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.12 ======================== + * + +2008-12-12 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.11.1 ======================== + * + +2008-10-16 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.11 ======================== + * + +2007-09-12 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.10 ======================== + * + +2007-03-21 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * smtpd.man: Fixed all warnings due to use of now deprecated + commands. Added a section about how to give feedback. + +2006-10-03 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.9 ======================== + * + +2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.8 ======================== + * + +2005-06-21 Pat Thoyts <patthoyts@users.sourceforge.net> + + * smtpd.tcl: bug #1224575 - as per RFC2821:3.7 we must accept null + return path addresses. The programmers validate_sender proc can + then decide to accept or reject such a submission. + +2005-06-14 Pat Thoyts <patthoyts@users.sourceforge.net> + + * smtpd.tcl: The -deliver options should accept a script prefix + not just a command. Set version to 1.4.0 + +2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.7 ======================== + * + +2004-06-26 Pat Thoyts <patthoyts@users.sourceforge.net> + + * smtpd.tcl: Implemented RFC3207 - Secure SMTP over TLS. This adds + a number of configuration options and a new command (available if + the tls package is provided and -usetls is set to true.) Also + implemented the SMTP HELP command and switched to using the logger + package from tcllib. + * /examples/smtpd/tk_smtpdTLS: New demo server to show off the + TLS features added here. + +2004-06-18 Pat Thoyts <patthoyts@users.sourceforge.net> + + * pkgIndex.tcl: Incremented version to 1.2.2 + * smtpd.man: + * smtpd.tcl: + + * smtpd.tcl (::smtpd::gmtoffset): Fixed bug #934134. The TZ + calculation was inverted and failed to cope with times spanning + midnight. + * smtpd.tcl (::smtpd::HELO): Shortened the response to a single + line which is a more common smtpd response and may help with + simple clients. + +2004-05-23 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.6.1 ======================== + * + +2004-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.6 ======================== + * + +2003-05-05 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * + * Released and tagged Tcllib 1.4 ======================== + * + +2003-04-10 Andreas Kupries <andreask@activestate.com> + + * smtpd.tcl: Fixed bug #614591. + +2003-01-25 Pat Thoyts <patthoyts@users.sourceforge.net> + + * smtpd.tcl: Fix bug #674333: require Tcl version 8.3+ + (the mime package requires 8.3 therefore so do we.) + +2003-01-16 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * smtpd.man: More semantic markup, less visual one. + +2003-01-02 Pat Thoyts <patthoyts@users.sourceforge.net> + + * smtpd.tcl: Added exception catching to all channel comms. + Added some ESMTP option handling (rudimentary). + Added SMTP Transparency handling. (RFC 2821: 4.5.2) + Improved error messages for DATA command. + +2002-10-25 Pat Thoyts <patthoyts@users.sourceforge.net> + + * smtpd.tcl: Implemented request #627960 to propagate the network + interface name into the server messages. Added a catch around + the deliver call and permit the deliver code to return SMTP + failure codes via ::errorCode. + +2002-10-08 Pat Thoyts <patthoyts@users.sourceforge.net> + + * smtpd.tcl: Implemented feature request #531531. Added + -deliverMIME option to provide mail as a MIME token. + * smtpd.man: Updated for the new delivery option. + * tk_smtpdMIME: New example using the -deliverMIME option. + +2002-09-25 David N. Welton <davidw@dedasys.com> + + * smtpd.man: Fixed documentation error in deliver example. + +2002-09-19 David N. Welton <davidw@dedasys.com> + + * smtpd.tcl (smtpd::service): Added Andreas' suggested changes to + avoid a bgerror caused by a broken pipe. + +2002-09-16 Pat Thoyts <patthoyts@users.sourceforge.net> + + * smtpd.tcl: fixed bug #609835 to cope with multiple addresses in + MAIL and RCPT commands without raising exception. + +2002-04-10 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * smtpd.man: Added doctools manpage. + +2001-12-10 Pat Thoyts <patthoyts@users.sourceforge.net> + + * smtpd.tcl (smtpd::gmtoffset): Fixed for cases where the hour + offset is invalid. + +2001-11-19 Andreas Kupries <andreas_kupries@users.sourceforge.net> + + * Moved example.tcl to the standard location in + 'tcllib/examples/smtpd'. Also renamed it to "tk_smtpd". + +2001-11-06 Pat Thoyts <patthoyts@users.sourceforge.net> + + * smtpd.tcl: Tcl SMTP server package. + * smtpd.n: Manual page for the Tcl SMTP server. + * example.tcl: Simple demo of server use and authentication. + diff --git a/tcllib/modules/smtpd/clients/README b/tcllib/modules/smtpd/clients/README new file mode 100644 index 0000000..d472066 --- /dev/null +++ b/tcllib/modules/smtpd/clients/README @@ -0,0 +1,13 @@ +These files are mail sending test scripts written in various scripting +languages. The purpose of these is to check that our SMTPd +inter-operates successfully with everyone else's SMTP client software. + +Feel free to add a test script for your favourite other language - or to +improve the usage of any of the current languages. + +mail-test.pl - Perl test script +mail-test.py - Python test +mail-test.rb - Ruby test +mail-test.php - PHP test (requires some php.ini configuration) +php.ini - PHP ini file (default for Windows installations) +mail-test.tcl - and of course, a Tcl client! diff --git a/tcllib/modules/smtpd/clients/mail-test.php b/tcllib/modules/smtpd/clients/mail-test.php new file mode 100644 index 0000000..5940c56 --- /dev/null +++ b/tcllib/modules/smtpd/clients/mail-test.php @@ -0,0 +1,21 @@ +<? + # Send a message from PHP (check the php.ini for the + # server, port and default sender details) + + $sndr = 'php-test-script@localhost'; + $rcpt = 'tcllib-test@localhost'; + + $subject = "Testing from PHP"; + + $hdrs = "MIME-Version: 1.0\r\n"; + $hdrs .= "Content-type: text/plain; charset=iso-8859-1\r\n"; + $hdrs .= "From: PHP Script <" . $sndr . ">"; + + $body = "This is a sample message send from PHP.\r\n"; + $body .= "As always, let us check the transparency function:\r\n"; + $body .= ". <-- there should be a dot there.\r\n"; + $body .= "Bye"; + + mail($rcpt, $subject, $body, $hdrs); + +?> diff --git a/tcllib/modules/smtpd/clients/mail-test.pl b/tcllib/modules/smtpd/clients/mail-test.pl new file mode 100644 index 0000000..54c4a09 --- /dev/null +++ b/tcllib/modules/smtpd/clients/mail-test.pl @@ -0,0 +1,121 @@ +# mail-test.pl - Copyright (C) 2003 Pat Thoyts <patthoyts@users.sf.net> +# +# Send some mail from Perl. +# +# This sends two messages, one valid and one without a recipient using the +# SMTP protocol. +# +# usage: ./mail-test.pl smtpd-host ?smtpd-port? +# +# ------------------------------------------------------------------------- + +use diagnostics; +use strict; + +use Net::SMTP; +use Sys::Hostname; + +my ($smtp_smart_host, $smtp_smart_port) = (shift, shift); + +$smtp_smart_host = 'localhost' if (!$smtp_smart_host); +$smtp_smart_port = 25 if (!$smtp_smart_port); + +my $smtp_default_from = 'postmaster@' . hostname(); +my $smtp_timeout = 120; +my $smtp_log_mail = 0; +my $smtp_debug = 1; + +my $sender_address = 'perl-test-script@' . hostname() . ''; +my $recipient_address = 'tcl-smtpd@' . $smtp_smart_host . ''; +my $from_address = 'Perl Test Script <perl-test-script@' . hostname() . '>'; +my $ro_address = 'Tcl Server <tcl-smtpd@' . $smtp_smart_host . '>'; + +print "Sending valid message\n"; +test_ok(); +print "Sending invalid message\n"; +test_no_rcpt(); + +sub test_no_rcpt { + my $header = 'From: ' . $sender_address . "\n"; + $header .= 'Subject: perl test' . "\n"; + my $message = <<EOF; +This is a sample message in no particular format, sent by Perl's +Net::SMTP package. +Let's check the transparency code with a sentance ending on the next line +. Like this! +EOF + + Sendmail($header . "\n" . $message . "\n"); +} + +sub test_ok { + my $header = 'From: ' . $sender_address . "\n"; + $header .= 'To: ' . $recipient_address . "\n"; + $header .= 'Subject: perl test' . "\n"; + my $message = <<EOF; +This is a sample message in no particular format, sent by Perl's +Net::SMTP package. +Let's check the transparency code with a sentance ending on the next line +. Like this! +EOF + + Sendmail($header . "\n" . $message . "\n"); +} + +# ------------------------------------------------------------------------- +# Sendmail replacement (replaces exec'ing /usr/lib/sendmail...) +# +# Just call this function with the entire mail (headers and body together). +# The recipient and sender addresses are extracted from the mail text. +# ------------------------------------------------------------------------- + +sub Sendmail { + my ($msg) = (@_); + my @rcpts = (); + my $from = $smtp_default_from; + + # Process the message headers to identify the recipient list. + my @msg = split(/^$/m, $msg); + my $header = $msg[0]; + $header =~ s/\n\s+/ /g; # fix continuation lines + + my @lines = split(/^/m, $header); + chomp(@lines); + foreach my $line (@lines) { + my ($key, $value) = split(/:\s*/, $line, 2); + if ($key =~ /To|CC|BCC/i ) { + push(@rcpts, $value); + } + if ($key =~ /From/i) { + $from = $value; + } + } + + my $smtp = Net::SMTP->new($smtp_smart_host, + Hello => hostname(), + Port => $smtp_smart_port, + Timeout => $smtp_timeout, + Debug => $smtp_debug) + || die "SMTP failed to connect: $!"; + + $smtp->mail($from, (Size=>length($msg), Bits=>'8')); + $smtp->to(@rcpts); + if ($smtp->data()) { # start sending data; + $smtp->datasend($msg); # send the message + $smtp->dataend(); # finished sending data + } else { + $smtp->reset(); + } + $smtp->quit; # end of session + + if ( $smtp_log_mail ) { + if ( open(MAILLOG, ">> data/maillog") ) { + print MAILLOG "From $from at ", localtime() . "\n"; + print MAILLOG "To: " . join(@rcpts, ',') . "\n"; + print MAILLOG $msg . "\n\n"; + close(MAILLOG); + } + } +} + +# ------------------------------------------------------------------------- diff --git a/tcllib/modules/smtpd/clients/mail-test.py b/tcllib/modules/smtpd/clients/mail-test.py new file mode 100644 index 0000000..d50c98b --- /dev/null +++ b/tcllib/modules/smtpd/clients/mail-test.py @@ -0,0 +1,53 @@ +# Python mail sample + +import sys, smtplib + + +class SMTPTest: + def __init__(self, interface='localhost', port=25): + self.svr = smtplib.SMTP(interface, port) + self.svr.set_debuglevel(1) + + def sendmail(self, sender, recipient, message): + try: + self.svr.sendmail(sender, recipient, message) + except: + print "oops" + + def quit(self): + self.svr.quit() + +def test(): + sndr = "python-script-test@localhost" + rcpt = "tcllib-test@localhost" + mesg = """From: Python Mailer <python-script@localhost> +To: Tcllib Tester <tcllib-test@localhost> +Date: Fri Dec 20 14:20:49 2002 +Subject: test from python + +This is a sample message from Python. +Hope it's OK +Check transparency: +. <- there should be one dot here. +Done +""" + # Connect + svr = SMTPTest('localhost') + + # Try normal message + svr.sendmail(sndr, rcpt, mesg) + + # should fail: invalid recipient. + svr.sendmail(sndr, "", mesg) + + # should fail: NULL recipient only valid for sender + svr.sendmail(sndr, "<>", mesg) + + # should be ok: null sender (permitted for daemon responses) + svr.sendmail("<>", rcpt, mesg) + + svr.quit() + + +if __name__ == '__main__': + test() diff --git a/tcllib/modules/smtpd/clients/mail-test.rb b/tcllib/modules/smtpd/clients/mail-test.rb new file mode 100644 index 0000000..6a81152 --- /dev/null +++ b/tcllib/modules/smtpd/clients/mail-test.rb @@ -0,0 +1,16 @@ +require 'net/smtp' + +sndr = 'ruby-test-script@localhost' +rcpt = 'tcllib-test@localhost' +msg = 'From: Ruby <ruby-test-script@localhost> +To: SMTPD <tcllib-test@localhost> +Subject: Testing from Ruby + +This is a sample message send from Ruby. +As always, let us check the transparency function: +. <-- there should be a dot there. +Bye' + +Net::SMTP.start('localhost', 25) do |smtp| + smtp.send_mail msg, sndr, rcpt +end diff --git a/tcllib/modules/smtpd/clients/mail-test.tcl b/tcllib/modules/smtpd/clients/mail-test.tcl new file mode 100644 index 0000000..358cb83 --- /dev/null +++ b/tcllib/modules/smtpd/clients/mail-test.tcl @@ -0,0 +1,15 @@ +package require mime +package require smtp + +set sndr "tcl-test-script@localhost" +set rcpt "tcllib-test@localhost" +set msg "This is a sample message send from Tcl.\nAs\ +always, let us check the transparency function:\n. <-- there\ +should be a dot there.\nBye" + +set tok [mime::initialize -canonical text/plain -encoding 7bit -string $msg] +mime::setheader $tok Subject "Testing from Tcl" +smtp::sendmessage $tok -servers localhost \ + -header [list To $rcpt] \ + -header [list From $sndr] + diff --git a/tcllib/modules/smtpd/clients/php.ini b/tcllib/modules/smtpd/clients/php.ini new file mode 100644 index 0000000..9a840be --- /dev/null +++ b/tcllib/modules/smtpd/clients/php.ini @@ -0,0 +1,56 @@ +[PHP] +engine = On +short_open_tag = On +asp_tags = Off +precision = 14 +y2k_compliance = Off +output_buffering = 4096 +output_handler = +zlib.output_compression = Off +implicit_flush = Off +allow_call_time_pass_reference = Off +safe_mode = Off +safe_mode_gid = Off +safe_mode_include_dir = +safe_mode_exec_dir = +safe_mode_allowed_env_vars = PHP_ +safe_mode_protected_env_vars = LD_LIBRARY_PATH +disable_functions = +expose_php = On +max_execution_time = 30 ; Maximum execution time of each script, in seconds +memory_limit = 8M ; Maximum amount of memory a script may consume (8MB) +error_reporting = E_ALL +display_errors = Off +display_startup_errors = Off +log_errors = On +track_errors = Off +warn_plus_overloading = Off +variables_order = "GPCS" +register_globals = Off +register_argc_argv = Off +post_max_size = 8M +gpc_order = "GPC" +magic_quotes_gpc = Off +magic_quotes_runtime = Off +magic_quotes_sybase = Off +auto_prepend_file = +auto_append_file = +default_mimetype = "text/html" +doc_root = +user_dir = +extension_dir = ./ +enable_dl = On +file_uploads = On +upload_max_filesize = 2M +allow_url_fopen = On +[mail function] +; Win32 only +SMTP = localhost +sendmail_from = postmaster@localhost + +; For Unix only. You may supply arguments as well (default: "sendmail -t -i"). +;sendmail_path = + +; Local Variables: +; tab-width: 4 +; End: diff --git a/tcllib/modules/smtpd/pkgIndex.tcl b/tcllib/modules/smtpd/pkgIndex.tcl new file mode 100644 index 0000000..f1c4fb8 --- /dev/null +++ b/tcllib/modules/smtpd/pkgIndex.tcl @@ -0,0 +1,12 @@ +# Tcl package index file, version 1.1 +# This file is generated by the "pkg_mkIndex" command +# and sourced either when an application starts up or +# by a "package unknown" script. It invokes the +# "package ifneeded" command to set up package-related +# information so that packages will be loaded automatically +# in response to "package require" commands. When this +# script is sourced, the variable $dir must contain the +# full path name of this file's directory. + +if {![package vsatisfies [package provide Tcl] 8.3]} {return} +package ifneeded smtpd 1.5 [list source [file join $dir smtpd.tcl]] diff --git a/tcllib/modules/smtpd/smtpd.man b/tcllib/modules/smtpd/smtpd.man new file mode 100644 index 0000000..b6680ef --- /dev/null +++ b/tcllib/modules/smtpd/smtpd.man @@ -0,0 +1,294 @@ +[comment {-*- tcl -*- doctools manpage}] +[manpage_begin smtpd n 1.5] +[keywords {rfc 821}] +[keywords {rfc 2821}] +[keywords services] +[keywords smtp] +[keywords smtpd] +[keywords socket] +[keywords vwait] +[copyright {Pat Thoyts <patthoyts@users.sourceforge.net>}] +[moddesc {Tcl SMTP Server Package}] +[titledesc {Tcl SMTP server implementation}] +[category Networking] +[require Tcl 8.3] +[require smtpd [opt 1.5]] +[description] +[para] + +The [package smtpd] package provides a simple Tcl-only server library +for the Simple Mail Transfer Protocol as described in + +RFC 821 ([uri http://www.rfc-editor.org/rfc/rfc821.txt]) and +RFC 2821 ([uri http://www.rfc-editor.org/rfc/rfc2821.txt]). + +By default the server will bind to the default network address and the +standard SMTP port (25). + +[para] + +This package was designed to permit testing of Mail User Agent code +from a developers workstation. [emph "It does not attempt to deliver \ +mail to your mailbox." ] Instead users of this package are expected to +write a procedure that will be called when mail arrives. Once this +procedure returns, the server has nothing further to do with the mail. + +[section SECURITY] + +On Unix platforms binding to the SMTP port requires root privileges. I +would not recommend running any script-based server as root unless +there is some method for dropping root privileges immediately after +the socket is bound. Under Windows platforms, it is not necessary to +have root or administrator privileges to bind low numbered +sockets. However, security on these platforms is weak anyway. + +[para] + +In short, this code should probably not be used as a permanently +running Mail Transfer Agent on an Internet connected server, even +though we are careful not to evaluate remote user input. There are +many other well tested and security audited programs that can be used +as mail servers for internet connected hosts. + +[include ../common-text/tls-security-notes.inc] + +[section COMMANDS] + +[list_begin definitions] + +[call [cmd ::smtpd::start] [opt [arg myaddr]] [opt [arg port]]] + +Start the service listening on [arg port] or the default port 25. If +[arg myaddr] is given as a domain-style name or numerical +dotted-quad IP address then the server socket will be bound to that +network interface. By default the server is bound to all network +interfaces. For example: + +[para] + +[example { + set sock [::smtpd::start [info hostname] 0] +}] + +[para] + +will bind to the hosts internet interface on the first available port. + +[para] + +At present the package only supports a single instance of a SMTP +server. This could be changed if required at the cost of making the +package a little more complicated to read. If there is a good reason +for running multiple SMTP services then it will only be necessary to +fix the [var options] array and the [var ::smtpd::stopped] variable +usage. + +[para] + +As the server code uses [cmd fileevent](n) handlers to process the +input on sockets you will need to run the event loop. This means +either you should be running from within [syscmd wish](1) or you +should [cmd vwait](n) on the [var ::smtpd::stopped] variable which is +set when the server is stopped. + +[call [cmd ::smtpd::stop]] + +Halt the server and release the listening socket. If the server has +not been started then this command does nothing. + +The [var ::smtpd::stopped] variable is set for use with + +[cmd vwait](n). + +[para] + +It should be noted that stopping the server does not disconnect any +currently active sessions as these are operating over an independent +channel. Only explicitly tracking and closing these sessions, or +exiting the server process will close down all the running +sessions. This is similar to the usual unix daemon practice where the +server performs a [syscmd fork](2) and the client session continues on +the child process. + +[call [cmd ::smptd::configure] [opt "[arg option] [arg value]"] [opt "[arg option] [arg value] [arg ...]"]] + +Set configuration options for the SMTP server. Most values are the +name of a callback procedure to be called at various points in the +SMTP protocol. See the [sectref CALLBACKS] section for details of the +procedures. + +[list_begin definitions] + +[def "[option -banner] [arg text]"] + +Text of a custom banner message. The default banner is "tcllib smtpd 1.5". +Note that changing the banner does not affect the bracketing text +in the full greeting, printing status 220, server-address, and timestamp. + +[def "[option -validate_host] [arg proc]"] + +Callback to authenticate new connections based on the ip-address of +the client. + +[def "[option -validate_sender] [arg proc]"] + +Callback to authenticate new connections based on the senders email +address. + +[def "[option -validate_recipient] [arg proc]"] + +Callback to validate and authorize a recipient email address + +[def "[option -deliverMIME] [arg proc]"] + +Callback used to deliver mail as a mime token created by the tcllib +[package mime] package. + +[def "[option -deliver] [arg proc]"] + +Callback used to deliver email. This option has no effect if +the [option -deliverMIME] option has been set. + +[list_end] + +[call [cmd ::smtpd::cget] [opt [arg option]]] + +If no [arg option] is specified the command will return a list of all +options and their current values. If an option is specified it will +return the value of that option. + +[list_end] + +[section CALLBACKS] + +[list_begin definitions] +[def "[cmd validate_host] callback"] + +This procedure is called with the clients ip address as soon as a +connection request has been accepted and before any protocol commands +are processed. If you wish to deny access to a specific host then an +error should be returned by this callback. For example: + +[para] +[example { + proc validate_host {ipnum} { + if {[string match "192.168.1.*" $ipnum]} { + error "go away!" + } + } +}] +[para] + +If access is denied the client will receive a standard message that +includes the text of your error, such as: + +[para] +[example { + 550 Access denied: I hate you. +}] +[para] + +As per the SMTP protocol, the connection is not closed but we wait for +the client to send a QUIT command. Any other commands cause a + +[const {503 Bad Sequence}] error. + +[def "[cmd validate_sender] callback"] + +The validate_sender callback is called with the senders mail address +during processing of a MAIL command to allow you to accept or reject +mail based upon the declared sender. To reject mail you should throw +an error. For example, to reject mail from user "denied": + +[para] +[example { + proc validate_sender {address} { + eval array set addr [mime::parseaddress $address] + if {[string match "denied" $addr(local)]} { + error "mailbox $addr(local) denied" + } + return + } +}] + +[para] + +The content of any error message will not be passed back to the client. + +[def "[cmd validate_recipient] callback"] + +The validate_recipient callback is similar to the validate_sender +callback and permits you to verify a local mailbox and accept mail for +a local user address during RCPT command handling. To reject mail, +throw an error as above. The error message is ignored. + +[def "[cmd deliverMIME] callback"]] + +The deliverMIME callback is called once a mail message has been +successfully passed to the server. A mime token is constructed from +the sender, recipients and data and the users procedure it called with +this single argument. When the call returns, the mime token is cleaned +up so if the user wishes to preserve the data she must make a copy. + +[para] +[example { + proc deliverMIME {token} { + set sender [lindex [mime::getheader $token From] 0] + set recipients [lindex [mime::getheader $token To] 0] + set mail "From $sender [clock format [clock seconds]]" + append mail "\n" [mime::buildmessage $token] + puts $mail + } +}] + +[def "[cmd deliver] callback"] + +The deliver callback is called once a mail message has been +successfully passed to the server and there is no -deliverMIME option +set. The procedure is called with the sender, a list of recipients and +the text of the mail as a list of lines. For example: + +[para] +[example { + proc deliver {sender recipients data} { + set mail "From $sender \ + [clock format [clock seconds]]" + append mail "\n" [join $data "\n"] + puts "$mail" + } +}] +[para] + +Note that the DATA command will return an error if no sender or +recipient has yet been defined. + +[list_end] + +[section VARIABLES] + +[list_begin definitions] + +[def [var ::smtpd::stopped]] + +This variable is set to [const true] during the [cmd ::smtpd::stop] +command to permit the use of the [cmd vwait](n) command. + +[comment ::smtpd::postmaster] +[comment {The e-mail address of the person that is the contact for the server.}] + +[list_end] + +[section AUTHOR] + +Written by Pat Thoyts [uri mailto:patthoyts@users.sourceforge.net]. + +[section LICENSE] + +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 +[file license.terms] for more details. + +[vset CATEGORY smtpd] +[include ../doctools2base/include/feedback.inc] +[manpage_end] diff --git a/tcllib/modules/smtpd/smtpd.tcl b/tcllib/modules/smtpd/smtpd.tcl new file mode 100644 index 0000000..96b2d9e --- /dev/null +++ b/tcllib/modules/smtpd/smtpd.tcl @@ -0,0 +1,924 @@ +# smtpd.tcl - Copyright (C) 2001 Pat Thoyts <patthoyts@users.sourceforge.net> +# +# This provides a minimal implementation of the Simple Mail Tranfer Protocol +# as per RFC821 and RFC2821 (http://www.normos.org/ietf/rfc/rfc821.txt) and +# is designed for use during local testing of SMTP client software. +# +# ------------------------------------------------------------------------- +# 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. +# ------------------------------------------------------------------------- +# @mdgen EXCLUDE: clients/mail-test.tcl + +package require Tcl 8.3; # tcl minimum version +package require logger; # tcllib 1.3 +package require mime; # tcllib + +package provide smtpd 1.5 + +namespace eval ::smtpd { + variable version [package present smtpd] + variable stopped + + namespace export start stop configure + + variable commands + if {![info exists commands]} { + set commands {EHLO HELO MAIL RCPT DATA RSET NOOP QUIT HELP} + # non-minimal commands HELP VRFY EXPN VERB ETRN DSN + } + + variable extensions + if {! [info exists extensions]} { + array set extensions { + 8BITMIME {} + SIZE 0 + } + } + + variable options + if {! [info exists options]} { + array set options { + serveraddr {} + deliverMIME {} + deliver {} + validate_host {} + validate_sender {} + validate_recipient {} + usetls 0 + tlsopts {} + } + set options(banner) "tcllib smtpd $version" + } + variable tlsopts {-cadir -cafile -certfile -cipher + -command -keyfile -password -request -require -ssl2 -ssl3 -tls1} + + variable log + if {![info exists log]} { + set log [logger::init smtpd] + ${log}::setlevel warn + proc ${log}::stdoutcmd {level text} { + variable service + puts "\[[clock format [clock seconds] -format {%H:%M:%S}]\ + $service $level\] $text" + } + } + + variable Help + if {![info exists Help]} { + array set Help { + {} {{Topics:} { HELO MAIL DATA RSET NOOP QUIT} + {For more information use "HELP <topic>".}} + HELO {{HELO <hostname>} { Introduce yourself.}} + MAIL {{MAIL FROM: <sender> [ <parameters> ]} + { Specify the sender of the message.} + { If using ESMTP there may be additional parameters of the} + { form NAME=VALUE.}} + DATA {{DATA} { Send your mail message.} + { End with a line containing a single dot.}} + RSET {{RSET} { Reset the session.}} + NOOP {{NOOP} { Command ignored by server.}} + QUIT {{QUIT} { Exit SMTP session}} + } + } +} + +# ------------------------------------------------------------------------- +# Description: +# Obtain configuration options for the server. +# +proc ::smtpd::cget {option} { + variable options + variable tlsopts + variable log + set optname [string trimleft $option -] + if { [string equal option -loglevel] } { + return [${log}::currentloglevel] + } elseif { [info exists options($optname)] } { + return $options($optname) + } elseif {[lsearch -exact $tlsopts -$optname] != -1} { + set ndx [lsearch -exact $options(tlsopts) -$optname] + if {$ndx != -1} { + return [lindex $options(tlsopts) [incr ndx]] + } + return {} + } else { + return -code error "unknown option \"-$optname\": \ + must be one of -[join [array names options] {, -}]" + } +} + +# ------------------------------------------------------------------------- +# Description: +# Configure server options. These include validation of hosts or users +# and a procedure to handle delivery of incoming mail. The -deliver +# procedure must handle mail because the server may release all session +# resources once the deliver proc has completed. +# An example might be to exec procmail to deliver the mail to users. +# +proc ::smtpd::configure {args} { + variable options + variable commands + variable extensions + variable log + variable tlsopts + + if {[llength $args] == 0} { + set r [list -loglevel [${log}::currentloglevel]] + foreach {opt value} [array get options] { + lappend r -$opt $value + } + lappend r - + return $r + } + + while {[string match -* [set option [lindex $args 0]]]} { + switch -glob -- $option { + -loglevel {${log}::setlevel [Pop args 1]} + -deliverMIME {set options(deliverMIME) [Pop args 1]} + -deliver {set options(deliver) [Pop args 1]} + -validate_host {set options(validate_host) [Pop args 1]} + -validate_sender {set options(validate_sender) [Pop args 1]} + -validate_recipient {set options(validate_recipient) [Pop args 1]} + -banner {set options(banner) [Pop args 1]} + -usetls { + set usetls [Pop args 1] + if {$usetls && ![catch {package require tls}]} { + set options(usetls) 1 + set extensions(STARTTLS) {} + lappend commands STARTTLS + } + } + -- { Pop args; break } + default { + set failed 1 + if {[lsearch $tlsopts $option] != -1} { + set options(tlsopts) \ + [concat $options(tlsopts) $option [Pop args 1]] + set failed 0 + } + set msg "unknown option: \"$option\":\ + must be one of -deliverMIME, -deliver,\ + -validate_host, -validate_recipient,\ + -validate_sender or an option suitable\ + to tls::init" + if {$failed} { + return -code error $msg + } + } + } + Pop args + } + return {} +} + +# ------------------------------------------------------------------------- +# Description: +# Start the server on the given interface and port. +# +proc ::smtpd::start {{myaddr {}} {port 25}} { + variable options + variable stopped + + if {[info exists options(socket)]} { + return -code error \ + "smtpd service already running on socket $options(socket)" + } + + if {$myaddr != {}} { + set options(serveraddr) $myaddr + set myaddr "-myaddr $myaddr" + } else { + if {$options(serveraddr) == {}} { + set options(serveraddr) [info hostname] + } + } + + set options(socket) [eval socket \ + -server [namespace current]::accept $myaddr $port] + set stopped 0 + Log notice "smtpd service started on $options(socket)" + return $options(socket) +} + +# ------------------------------------------------------------------------- +# Description: +# Stop a running server. Do nothing if the server isn't running. +# +proc ::smtpd::stop {} { + variable options + variable stopped + if {[info exists options(socket)]} { + close $options(socket) + set stopped 1 + Log notice "smtpd service stopped" + unset options(socket) + } +} + +# ------------------------------------------------------------------------- +# Description: +# Accept a new connection and setup a fileevent handler to process the new +# session. Performs a host id validation step before allowing access. +# +proc ::smtpd::accept {channel client_addr client_port} { + variable options + variable version + upvar [namespace current]::state_$channel State + + # init state array + catch {unset State} + initializeState $channel + set State(access) allowed + set State(client_addr) $client_addr + set State(client_port) $client_port + set accepted true + + # configure the data channel + fconfigure $channel -buffering line -translation crlf -encoding ascii + fileevent $channel readable [list [namespace current]::service $channel] + + # check host access permissions + if {[cget -validate_host] != {}} { + if {[catch {eval [cget -validate_host] $client_addr} msg] } { + Log notice "access denied for $client_addr:$client_port: $msg" + Puts $channel "550 Access denied: $msg" + set State(access) denied + set accepted false + } + } + + if {$accepted} { + # Accept the connection + Log notice "connect from $client_addr:$client_port on $channel" + Puts $channel "220 $options(serveraddr) $options(banner); [timestamp]" + } + + return +} + +# ------------------------------------------------------------------------- +# Description: +# Initialize the channel state array. Called by accept and RSET. +# +proc ::smtpd::initializeState {channel} { + upvar [namespace current]::state_$channel State + set State(indata) 0 + set State(to) {} + set State(from) {} + set State(data) {} + set State(options) {} +} + +# ------------------------------------------------------------------------- +# Description: +# Access the state of a connected session using the channel name as part +# of the state array name. Called with no value, it returns the current +# value of the item (or {} if not defined). +# +proc ::smtpd::state {channel args} { + if {[llength $args] == 0} { + return [array get [namespace current]::state_$channel] + } + + set arrname [namespace current]::[subst state_$channel] + + if {[llength $args] == 1} { + set r {} + if {[info exists [subst $arrname]($args)]} { + # FRINK: nocheck + set r [set [subst $arrname]($args)] + } + return $r + } + + foreach {name value} $args { + # FRINK: nocheck + set [namespace current]::[subst state_$channel]($name) $value + } + return {} +} + +# ------------------------------------------------------------------------- +# Description: +# Pop the nth element off a list. Used in options processing. +# +proc ::smtpd::Pop {varname {nth 0}} { + upvar $varname args + set r [lindex $args $nth] + set args [lreplace $args $nth $nth] + return $r +} + +# ------------------------------------------------------------------------- +# Description: +# Wrapper to call our log procedure. +# +proc ::smtpd::Log {level text} { + variable log + ${log}::${level} $text +} + +# ------------------------------------------------------------------------- +# Description: +# Safe puts. +# If the client closes the channel, then puts will throw an error. Lets +# terminate the session if this occurs. +proc ::smtpd::Puts {channel args} { + if {[catch {uplevel puts $channel $args} msg]} { + Log error $msg + catch { + close $channel + # FRINK: nocheck + unset -- [namespace current]::state_$channel + } + } + return $msg +} + +# ------------------------------------------------------------------------- +# Description: +# Perform the chat with a connected client. This procedure accepts input on +# the connected socket and executes commands according to the state of the +# session. +# +proc ::smtpd::service {channel} { + variable commands + variable options + upvar [namespace current]::state_$channel State + + if {[eof $channel]} { + close $channel + return + } + + if {[catch {gets $channel cmdline} msg]} { + close $channel + Log error $msg + return + } + + if { $cmdline == "" && [eof $channel] } { + Log warn "client has closed the channel" + return + } + + Log debug "received: $cmdline" + + # If we are handling a DATA section, keep looking for the end of data. + if {$State(indata)} { + if {$cmdline == "."} { + set State(indata) 0 + fconfigure $channel -translation crlf + if {[catch {deliver $channel} err]} { + # permit delivery handler to return SMTP errors in errorCode + if {[regexp {\d{3}} $::errorCode]} { + Puts $channel "$::errorCode $err" + } else { + Puts $channel "554 Transaction failed: $err" + } + } else { + Puts $channel "250 [state $channel id]\ + Message accepted for delivery" + } + } else { + # RFC 2821 section 4.5.2: Transparency + if {[string match {..*} $cmdline]} { + set cmdline [string range $cmdline 1 end] + } + lappend State(data) $cmdline + } + return + } + + # Process SMTP commands (case insensitive) + set cmd [string toupper [lindex [split $cmdline] 0]] + if {[lsearch $commands $cmd] != -1} { + if {[info proc $cmd] == {}} { + Puts $channel "500 $cmd not implemented" + } else { + # If access denied then client can only issue QUIT. + if {$State(access) == "denied" && $cmd != "QUIT" } { + Puts $channel "503 bad sequence of commands" + } else { + set r [eval $cmd $channel [list $cmdline]] + } + } + } else { + Puts $channel "500 Invalid command" + } + + return +} + +# ------------------------------------------------------------------------- +# Description: +# Generate a random ASCII character for use in mail identifiers. +# +proc ::smtpd::uidchar {} { + set c . + while {! [string is alnum $c]} { + set n [expr {int(rand() * 74 + 48)}] + set c [format %c $n] + } + return $c +} + +# Description: +# Generate a unique random identifier using only ASCII alphanumeric chars. +# +proc ::smtpd::uid {} { + set r {} + for {set cn 0} {$cn < 12} {incr cn} { + append r [uidchar] + } + return $r +} + +# ------------------------------------------------------------------------- +# Description: +# Calculate the local offset from GMT in hours for use in the timestamp +# +proc ::smtpd::gmtoffset {} { + set now [clock seconds] + set local [clock format $now -format "%j %H" -gmt false] + set zulu [clock format $now -format "%j %H" -gmt true] + set lh [expr {([scan [lindex $local 0] %d] * 24) \ + + [scan [lindex $local 1] %d]}] + set zh [expr {([scan [lindex $zulu 0] %d] * 24) \ + + [scan [lindex $zulu 1] %d]}] + set off [expr {$lh - $zh}] + set off [format "%+03d00" $off] + return $off +} + +# ------------------------------------------------------------------------- +# Description: +# Generate a standard SMTP compliant timestamp. That is a local time but with +# the timezone represented as an offset. +# +proc ::smtpd::timestamp {} { + set ts [clock format [clock seconds] \ + -format "%a, %d %b %Y %H:%M:%S" -gmt false] + append ts " " [gmtoffset] + return $ts +} + +# ------------------------------------------------------------------------- +# Description: +# Get the servers ip address (from http://purl.org/mini/tcl/526.html) +# +proc ::smtpd::server_ip {} { + set me [socket -server xxx -myaddr [info hostname] 0] + set ip [lindex [fconfigure $me -sockname] 0] + close $me + return $ip +} + +# ------------------------------------------------------------------------- +# Description: +# deliver is called once a mail transaction is completed and there is +# no deliver procedure defined +# The configured -deliverMIME procedure is called with a MIME token. +# If no such callback is defined then try the -deliver option and use +# the old API. +# +proc ::smtpd::deliver {channel} { + set deliverMIME [cget deliverMIME] + if { $deliverMIME != {} \ + && [state $channel from] != {} \ + && [state $channel to] != {} \ + && [state $channel data] != {} } { + + # create a MIME token from the mail message. + set tok [mime::initialize -string \ + [join [state $channel data] "\n"]] +# mime::setheader $tok "From" [state $channel from] +# foreach recipient [state $channel to] { +# mime::setheader $tok "To" $recipient -mode append +# } + + # catch and rethrow any errors. + set err [catch {eval $deliverMIME [list $tok]} msg] + mime::finalize $tok -subordinates all + if {$err} { + Log debug "error in deliver: $msg" + return -code error -errorcode $::errorCode \ + -errorinfo $::errorInfo $msg + } + + } else { + # Try the old interface + deliver_old $channel + } +} + +# ------------------------------------------------------------------------- +# Description: +# Deliver is called once a mail transaction is completed (defined as the +# completion of a DATA command). The configured -deliver procedure is called +# with the sender, list of recipients and the text of the mail. +# +proc ::smtpd::deliver_old {channel} { + set deliver [cget deliver] + if { $deliver != {} \ + && [state $channel from] != {} \ + && [state $channel to] != {} \ + && [state $channel data] != {} } { + if {[catch {$deliver [state $channel from] \ + [state $channel to] \ + [state $channel data]} msg]} { + Log debug "error in deliver: $msg" + return -code error -errorcode $::errorCode \ + -errorinfo $::errorInfo $msg + } + } +} + +# ------------------------------------------------------------------------- +proc ::smtpd::split_address {address} { + set start [string first < $address] + set end [string last > $address] + set addr [string range $address $start $end] + incr end + set opts [string trim [string range $address $end end]] + return [list $addr $opts] +} + +# ------------------------------------------------------------------------- +# The SMTP Commands +# ------------------------------------------------------------------------- +# Description: +# Initiate an SMTP session +# Reference: +# RFC2821 4.1.1.1 +# +proc ::smtpd::HELO {channel line} { + variable options + + if {[state $channel domain] != {}} { + Puts $channel "503 bad sequence of commands" + Log debug "HELO received out of sequence." + return + } + + set r [regexp -nocase {^HELO\s+([-\w\.]+)\s*$} $line -> domain] + if {$r == 0} { + Puts $channel "501 Syntax error in parameters or arguments" + Log debug "HELO received \"$line\"" + return + } + Puts $channel "250 $options(serveraddr) Hello $domain\ + \[[state $channel client_addr]\], pleased to meet you" + state $channel domain $domain + Log debug "HELO on $channel from $domain" + return +} + +# ------------------------------------------------------------------------- +# Description: +# Initiate an ESMTP session +# Reference: +# RFC2821 4.1.1.1 +proc ::smtpd::EHLO {channel line} { + variable options + variable extensions + + if {[state $channel domain] != {}} { + Puts $channel "503 bad sequence of commands" + Log debug "EHLO received out of sequence." + return + } + + set r [regexp -nocase {^EHLO\s+([-\w\.]+)\s*$} $line -> domain] + if {$r == 0} { + Puts $channel "501 Syntax error in parameters or arguments" + Log debug "EHLO received \"$line\"" + return + } + Puts $channel "250-$options(serveraddr) Hello $domain\ + \[[state $channel client_addr]\], pleased to meet you" + foreach {extn opts} [array get extensions] { + Puts $channel [string trimright "250-$extn $opts"] + } + Puts $channel "250 Ready for mail." + state $channel domain $domain + Log debug "EHLO on $channel from $domain" + return +} + +# ------------------------------------------------------------------------- +# Description: +# Reference: +# RFC2821 4.1.1.2 +# +proc ::smtpd::MAIL {channel line} { + set r [regexp -nocase {^MAIL FROM:\s*(.*)} $line -> from] + if {$r == 0} { + Puts $channel "501 Syntax error in parameters or arguments" + Log debug "MAIL received \"$line\"" + return + } + if {[catch { + set from [split_address $from] + set opts [lindex $from 1] + set from [lindex $from 0] + eval array set addr [mime::parseaddress $from] + # RFC2821 3.7: we must accept null return path addresses. + if {[string equal "<>" $from]} { + set addr(error) {} + } + } msg]} { + set addr(error) $msg + } + if {$addr(error) != {} } { + Log debug "MAIL failed $addr(error)" + Puts $channel "501 Syntax error in parameters or arguments" + return + } + + if {[cget -validate_sender] != {}} { + if {[catch {eval [cget -validate_sender] $addr(address)}]} { + # this user has been denied + Log info "MAIL denied user $addr(address)" + Puts $channel "553 Requested action not taken:\ + mailbox name not allowed" + return + } + } + + Log debug "MAIL FROM: $addr(address)" + state $channel from $from + state $channel options $opts + Puts $channel "250 OK" + return +} + +# ------------------------------------------------------------------------- +# Description: +# Specify a recipient for this mail. This command may be executed multiple +# times to contruct a list of recipients. If a -validate_recipient +# procedure is configured then this is used. An error from the validation +# procedure indicates an invalid or unacceptable mailbox. +# Reference: +# RFC2821 4.1.1.3 +# Notes: +# The postmaster mailbox MUST be supported. (RFC2821: 4.5.1) +# +proc ::smtpd::RCPT {channel line} { + set r [regexp -nocase {^RCPT TO:\s*(.*)} $line -> to] + if {$r == 0} { + Puts $channel "501 Syntax error in parameters or arguments" + Log debug "RCPT received \"$line\"" + return + } + if {[catch { + set to [split_address $to] + set opts [lindex $to 1] + set to [lindex $to 0] + eval array set addr [mime::parseaddress $to] + } msg]} { + set addr(error) $msg + } + + if {$addr(error) != {}} { + Log debug "RCPT failed $addr(error)" + Puts $channel "501 Syntax error in parameters or arguments" + return + } + + if {[string match -nocase "postmaster" $addr(local)]} { + # we MUST support this recipient somehow as mail. + Log notice "RCPT to postmaster" + } else { + if {[cget -validate_recipient] != {}} { + if {[catch {eval [cget -validate_recipient] $addr(address)}]} { + # this recipient has been denied + Log info "RCPT denied mailbox $addr(address)" + Puts $channel "553 Requested action not taken:\ + mailbox name not allowed" + return + } + } + } + + Log debug "RCPT TO: $addr(address)" + set recipients {} + catch {set recipients [state $channel to]} + lappend recipients $to + state $channel to $recipients + Puts $channel "250 OK" + return +} + +# ------------------------------------------------------------------------- +# Description: +# Begin accepting data for the mail payload. A line containing a single +# period marks the end of the data and the server will then deliver the +# mail. RCPT and MAIL commands must have been executed before the DATA +# command. +# Reference: +# RFC2821 4.1.1.4 +# Notes: +# The DATA section is the only part of the protocol permitted to use non- +# ASCII characters and non-CRLF line endings and some clients take +# advantage of this. Therefore we change the translation option on the +# channel and reset it once the DATA command is completed. See the +# 'service' procedure for the handling of DATA lines. +# We also insert trace information as per RFC2821:4.4 +# +proc ::smtpd::DATA {channel line} { + variable version + upvar [namespace current]::state_$channel State + Log debug "DATA" + if { $State(from) == {}} { + Puts $channel "503 bad sequence: no sender specified" + } elseif { $State(to) == {}} { + Puts $channel "503 bad sequence: no recipient specified" + } else { + Puts $channel "354 Enter mail, end with \".\" on a line by itself" + set State(id) [uid] + set State(indata) 1 + + lappend trace "Return-Path: $State(from)" + lappend trace "Received: from [state $channel domain]\ + \[[state $channel client_addr]\]" + lappend trace "\tby [info hostname] with tcllib smtpd ($version)" + if {[info exists State(tls)] && $State(tls)} { + catch { + array set t [::tls::status $channel] + lappend trace "\t(version=TLS1/SSL3 cipher=$t(cipher) bits=$t(sbits) verify=NO)" + } + } + lappend trace "\tid $State(id); [timestamp]" + set State(data) $trace + fconfigure $channel -translation auto ;# naughty: RFC2821:2.3.7 + } + return +} + +# ------------------------------------------------------------------------- +# Description: +# Reset the server state for this connection. +# Reference: +# RFC2821 4.1.1.5 +# +proc ::smtpd::RSET {channel line} { + upvar [namespace current]::state_$channel State + Log debug "RSET on $channel" + if {[catch {initializeState $channel} msg]} { + Log warn "RSET: $msg" + } + Puts $channel "250 OK" + return +} + +# ------------------------------------------------------------------------- +# Description: +# Verify the existence of a mailbox on the server +# Reference: +# RFC2821 4.1.1.6 +# +#proc ::smtpd::VRFY {channel line} { +# # VRFY SP String CRLF +#} + +# ------------------------------------------------------------------------- +# Description: +# Expand a mailing list. +# Reference: +# RFC2821 4.1.1.7 +# +#proc ::smtpd::EXPN {channel line} { +# # EXPN SP String CRLF +#} + +# ------------------------------------------------------------------------- +# Description: +# Return a help message. +# Reference: +# RFC2821 4.1.1.8 +# +proc ::smtpd::HELP {channel line} { + variable Help + set cmd {} + regexp {^HELP\s*(\w+)?} $line -> cmd + if {[info exists Help($cmd)]} { + foreach line $Help($cmd) { + Puts $channel "214-$line" + } + Puts $channel "214 End of HELP" + } else { + Puts $channel "504 HELP topic \"$cmd\" unknown." + } +} + +# ------------------------------------------------------------------------- +# Description: +# Perform no action. +# Reference: +# RFC2821 4.1.1.9 +# +proc ::smtpd::NOOP {channel line} { + set str {} + regexp -nocase {^NOOP (.*)$} -> str + Log debug "NOOP: $str" + Puts $channel "250 OK" + return +} + +# ------------------------------------------------------------------------- +# Description: +# Terminate a session and close the transmission channel. +# Reference: +# RFC2821 4.1.1.10 +# Notes: +# The server is only permitted to close the channel once it has received +# a QUIT message. +# +proc ::smtpd::QUIT {channel line} { + variable options + upvar [namespace current]::state_$channel State + + Log debug "QUIT on $channel" + Puts $channel "221 $options(serveraddr) Service closing transmission channel" + close $channel + + # cleanup the session state array. + unset State + return +} + +# ------------------------------------------------------------------------- +# Description: +# Implement support for secure mail transactions using the TLS package. +# Reference: +# RFC3207 +# Notes: +# +proc ::smtpd::STARTTLS {channel line} { + variable options + upvar [namespace current]::state_$channel State + + Log debug "$line on $channel" + if {![string equal $line STARTTLS]} { + Puts $channel "501 Syntax error (no parameters allowed)" + return + } + + if {[lsearch -exact $options(tlsopts) -certfile] == -1 + || [lsearch -exact $options(tlsopts) -keyfile] == -1} { + Puts $channel "454 TLS not available due to temporary reason" + return + } + + set import [linsert $options(tlsopts) 0 ::tls::import $channel -server 1] + Puts $channel "220 Ready to start TLS" + if {[catch $import msg]} { + Puts $channel "454 TLS not available due to temporary reason" + } else { + set State(domain) {}; # RFC3207:4.2 + set State(tls) 1 + } + return +} + +# ------------------------------------------------------------------------- +# Logging callback for use with tls - you must specify this when configuring +# smtpd if you wan to use it. +# +proc ::smtpd::tlscallback {option args} { + switch -exact -- $option { + "error" { + foreach {chan msg} $args break + Log error "TLS error '$msg'" + } + "verify" { + foreach {chan depth cert rc err} $args break + if {$rc ne "1"} { + Log error "TLS verify/$depth Bad cert '$err' (rc=$rc)" + } else { + array set c $cert + Log notice "TLS verify/$depth: $c(subject)" + } + return $rc + } + "info" { + foreach {chan major minor state msg} $args break + if {$msg ne ""} { append state ": $msg" } + Log debug "TLS ${major}.${minor} $state" + } + default { + Log warn "bad option \"$option\" in smtpd::callback" + } + } +} + +# ------------------------------------------------------------------------- +# ------------------------------------------------------------------------- +# Local variables: +# mode: tcl +# indent-tabs-mode: nil +# End: |