1# smtpd.tcl - Copyright (C) 2001 Pat Thoyts <patthoyts@users.sourceforge.net> 2# 3# This provides a minimal implementation of the Simple Mail Tranfer Protocol 4# as per RFC821 and RFC2821 (http://www.normos.org/ietf/rfc/rfc821.txt) and 5# is designed for use during local testing of SMTP client software. 6# 7# ------------------------------------------------------------------------- 8# This software is distributed in the hope that it will be useful, but 9# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 10# or FITNESS FOR A PARTICULAR PURPOSE. See the file 'license.terms' for 11# more details. 12# ------------------------------------------------------------------------- 13 14package require Tcl 8.3; # tcl minimum version 15package require logger; # tcllib 1.3 16package require mime; # tcllib 17 18# @mdgen EXCLUDE: clients/mail-test.tcl 19 20namespace eval ::smtpd { 21 variable rcsid {$Id: smtpd.tcl,v 1.20 2005/12/09 18:27:17 andreas_kupries Exp $} 22 variable version 1.4.0 23 variable stopped 24 25 namespace export start stop configure 26 27 variable commands 28 if {![info exists commands]} { 29 set commands {EHLO HELO MAIL RCPT DATA RSET NOOP QUIT HELP} 30 # non-minimal commands HELP VRFY EXPN VERB ETRN DSN 31 } 32 33 variable extensions 34 if {! [info exists extensions]} { 35 array set extensions { 36 8BITMIME {} 37 SIZE 0 38 } 39 } 40 41 variable options 42 if {! [info exists options]} { 43 array set options { 44 serveraddr {} 45 deliverMIME {} 46 deliver {} 47 validate_host {} 48 validate_sender {} 49 validate_recipient {} 50 usetls 0 51 tlsopts {} 52 } 53 } 54 variable tlsopts {-cadir -cafile -certfile -cipher 55 -command -keyfile -password -request -require -ssl2 -ssl3 -tls1} 56 57 variable log 58 if {![info exists log]} { 59 set log [logger::init smtpd] 60 ${log}::setlevel warn 61 proc ${log}::stdoutcmd {level text} { 62 variable service 63 puts "\[[clock format [clock seconds] -format {%H:%M:%S}]\ 64 $service $level\] $text" 65 } 66 } 67 68 variable Help 69 if {![info exists Help]} { 70 array set Help { 71 {} {{Topics:} { HELO MAIL DATA RSET NOOP QUIT} 72 {For more information use "HELP <topic>".}} 73 HELO {{HELO <hostname>} { Introduce yourself.}} 74 MAIL {{MAIL FROM: <sender> [ <parameters> ]} 75 { Specify the sender of the message.} 76 { If using ESMTP there may be additional parameters of the} 77 { form NAME=VALUE.}} 78 DATA {{DATA} { Send your mail message.} 79 { End with a line containing a single dot.}} 80 RSET {{RSET} { Reset the session.}} 81 NOOP {{NOOP} { Command ignored by server.}} 82 QUIT {{QUIT} { Exit SMTP session}} 83 } 84 } 85} 86 87# ------------------------------------------------------------------------- 88# Description: 89# Obtain configuration options for the server. 90# 91proc ::smtpd::cget {option} { 92 variable options 93 variable tlsopts 94 variable log 95 set optname [string trimleft $option -] 96 if { [string equal option -loglevel] } { 97 return [${log}::currentloglevel] 98 } elseif { [info exists options($optname)] } { 99 return $options($optname) 100 } elseif {[lsearch -exact $tlsopts -$optname] != -1} { 101 set ndx [lsearch -exact $options(tlsopts) -$optname] 102 if {$ndx != -1} { 103 return [lindex $options(tlsopts) [incr ndx]] 104 } 105 return {} 106 } else { 107 return -code error "unknown option \"-$optname\": \ 108 must be one of -[join [array names options] {, -}]" 109 } 110} 111 112# ------------------------------------------------------------------------- 113# Description: 114# Configure server options. These include validation of hosts or users 115# and a procedure to handle delivery of incoming mail. The -deliver 116# procedure must handle mail because the server may release all session 117# resources once the deliver proc has completed. 118# An example might be to exec procmail to deliver the mail to users. 119# 120proc ::smtpd::configure {args} { 121 variable options 122 variable commands 123 variable extensions 124 variable log 125 variable tlsopts 126 127 if {[llength $args] == 0} { 128 set r [list -loglevel [${log}::currentloglevel]] 129 foreach {opt value} [array get options] { 130 lappend r -$opt $value 131 } 132 lappend r - 133 return $r 134 } 135 136 while {[string match -* [set option [lindex $args 0]]]} { 137 switch -glob -- $option { 138 -loglevel {${log}::setlevel [Pop args 1]} 139 -deliverMIME {set options(deliverMIME) [Pop args 1]} 140 -deliver {set options(deliver) [Pop args 1]} 141 -validate_host {set options(validate_host) [Pop args 1]} 142 -validate_sender {set options(validate_sender) [Pop args 1]} 143 -validate_recipient {set options(validate_recipient) [Pop args 1]} 144 -usetls { 145 set usetls [Pop args 1] 146 if {$usetls && ![catch {package require tls}]} { 147 set options(usetls) 1 148 set extensions(STARTTLS) {} 149 lappend commands STARTTLS 150 } 151 } 152 -- { Pop args; break } 153 default { 154 set failed 1 155 if {[lsearch $tlsopts $option] != -1} { 156 set options(tlsopts) \ 157 [concat $options(tlsopts) $option [Pop args 1]] 158 set failed 0 159 } 160 set msg "unknown option: \"$option\":\ 161 must be one of -deliverMIME, -deliver,\ 162 -validate_host, -validate_recipient,\ 163 -validate_sender or an option suitable\ 164 to tls::init" 165 if {$failed} { 166 return -code error $msg 167 } 168 } 169 } 170 Pop args 171 } 172 return {} 173} 174 175# ------------------------------------------------------------------------- 176# Description: 177# Start the server on the given interface and port. 178# 179proc ::smtpd::start {{myaddr {}} {port 25}} { 180 variable options 181 variable stopped 182 183 if {[info exists options(socket)]} { 184 return -code error \ 185 "smtpd service already running on socket $options(socket)" 186 } 187 188 if {$myaddr != {}} { 189 set options(serveraddr) $myaddr 190 set myaddr "-myaddr $myaddr" 191 } else { 192 if {$options(serveraddr) == {}} { 193 set options(serveraddr) [info hostname] 194 } 195 } 196 197 set options(socket) [eval socket \ 198 -server [namespace current]::accept $myaddr $port] 199 set stopped 0 200 Log notice "smtpd service started on $options(socket)" 201 return $options(socket) 202} 203 204# ------------------------------------------------------------------------- 205# Description: 206# Stop a running server. Do nothing if the server isn't running. 207# 208proc ::smtpd::stop {} { 209 variable options 210 variable stopped 211 if {[info exists options(socket)]} { 212 close $options(socket) 213 set stopped 1 214 Log notice "smtpd service stopped" 215 unset options(socket) 216 } 217} 218 219# ------------------------------------------------------------------------- 220# Description: 221# Accept a new connection and setup a fileevent handler to process the new 222# session. Performs a host id validation step before allowing access. 223# 224proc ::smtpd::accept {channel client_addr client_port} { 225 variable options 226 variable version 227 upvar [namespace current]::state_$channel State 228 229 # init state array 230 catch {unset State} 231 initializeState $channel 232 set State(access) allowed 233 set State(client_addr) $client_addr 234 set State(client_port) $client_port 235 set accepted true 236 237 # configure the data channel 238 fconfigure $channel -buffering line -translation crlf -encoding ascii 239 fileevent $channel readable [list [namespace current]::service $channel] 240 241 # check host access permissions 242 if {[cget -validate_host] != {}} { 243 if {[catch {eval [cget -validate_host] $client_addr} msg] } { 244 Log notice "access denied for $client_addr:$client_port: $msg" 245 Puts $channel "550 Access denied: $msg" 246 set State(access) denied 247 set accepted false 248 } 249 } 250 251 if {$accepted} { 252 # Accept the connection 253 Log notice "connect from $client_addr:$client_port on $channel" 254 Puts $channel "220 $options(serveraddr) tcllib smtpd $version; [timestamp]" 255 } 256 257 return 258} 259 260# ------------------------------------------------------------------------- 261# Description: 262# Initialize the channel state array. Called by accept and RSET. 263# 264proc ::smtpd::initializeState {channel} { 265 upvar [namespace current]::state_$channel State 266 set State(indata) 0 267 set State(to) {} 268 set State(from) {} 269 set State(data) {} 270 set State(options) {} 271} 272 273# ------------------------------------------------------------------------- 274# Description: 275# Access the state of a connected session using the channel name as part 276# of the state array name. Called with no value, it returns the current 277# value of the item (or {} if not defined). 278# 279proc ::smtpd::state {channel args} { 280 if {[llength $args] == 0} { 281 return [array get [namespace current]::state_$channel] 282 } 283 284 set arrname [namespace current]::[subst state_$channel] 285 286 if {[llength $args] == 1} { 287 set r {} 288 if {[info exists [subst $arrname]($args)]} { 289 # FRINK: nocheck 290 set r [set [subst $arrname]($args)] 291 } 292 return $r 293 } 294 295 foreach {name value} $args { 296 # FRINK: nocheck 297 set [namespace current]::[subst state_$channel]($name) $value 298 } 299 return {} 300} 301 302# ------------------------------------------------------------------------- 303# Description: 304# Pop the nth element off a list. Used in options processing. 305# 306proc ::smtpd::Pop {varname {nth 0}} { 307 upvar $varname args 308 set r [lindex $args $nth] 309 set args [lreplace $args $nth $nth] 310 return $r 311} 312 313# ------------------------------------------------------------------------- 314# Description: 315# Wrapper to call our log procedure. 316# 317proc ::smtpd::Log {level text} { 318 variable log 319 ${log}::${level} $text 320} 321 322# ------------------------------------------------------------------------- 323# Description: 324# Safe puts. 325# If the client closes the channel, then puts will throw an error. Lets 326# terminate the session if this occurs. 327proc ::smtpd::Puts {channel args} { 328 if {[catch {uplevel puts $channel $args} msg]} { 329 Log error $msg 330 catch { 331 close $channel 332 # FRINK: nocheck 333 unset -- [namespace current]::state_$channel 334 } 335 } 336 return $msg 337} 338 339# ------------------------------------------------------------------------- 340# Description: 341# Perform the chat with a connected client. This procedure accepts input on 342# the connected socket and executes commands according to the state of the 343# session. 344# 345proc ::smtpd::service {channel} { 346 variable commands 347 variable options 348 upvar [namespace current]::state_$channel State 349 350 if {[eof $channel]} { 351 close $channel 352 return 353 } 354 355 if {[catch {gets $channel cmdline} msg]} { 356 close $channel 357 Log error $msg 358 return 359 } 360 361 if { $cmdline == "" && [eof $channel] } { 362 Log warn "client has closed the channel" 363 return 364 } 365 366 Log debug "received: $cmdline" 367 368 # If we are handling a DATA section, keep looking for the end of data. 369 if {$State(indata)} { 370 if {$cmdline == "."} { 371 set State(indata) 0 372 fconfigure $channel -translation crlf 373 if {[catch {deliver $channel} err]} { 374 # permit delivery handler to return SMTP errors in errorCode 375 if {[regexp {\d{3}} $::errorCode]} { 376 Puts $channel "$::errorCode $err" 377 } else { 378 Puts $channel "554 Transaction failed: $err" 379 } 380 } else { 381 Puts $channel "250 [state $channel id]\ 382 Message accepted for delivery" 383 } 384 } else { 385 # RFC 2821 section 4.5.2: Transparency 386 if {[string match {..*} $cmdline]} { 387 set cmdline [string range $cmdline 1 end] 388 } 389 lappend State(data) $cmdline 390 } 391 return 392 } 393 394 # Process SMTP commands (case insensitive) 395 set cmd [string toupper [lindex [split $cmdline] 0]] 396 if {[lsearch $commands $cmd] != -1} { 397 if {[info proc $cmd] == {}} { 398 Puts $channel "500 $cmd not implemented" 399 } else { 400 # If access denied then client can only issue QUIT. 401 if {$State(access) == "denied" && $cmd != "QUIT" } { 402 Puts $channel "503 bad sequence of commands" 403 } else { 404 set r [eval $cmd $channel [list $cmdline]] 405 } 406 } 407 } else { 408 Puts $channel "500 Invalid command" 409 } 410 411 return 412} 413 414# ------------------------------------------------------------------------- 415# Description: 416# Generate a random ASCII character for use in mail identifiers. 417# 418proc ::smtpd::uidchar {} { 419 set c . 420 while {! [string is alnum $c]} { 421 set n [expr {int(rand() * 74 + 48)}] 422 set c [format %c $n] 423 } 424 return $c 425} 426 427# Description: 428# Generate a unique random identifier using only ASCII alphanumeric chars. 429# 430proc ::smtpd::uid {} { 431 set r {} 432 for {set cn 0} {$cn < 12} {incr cn} { 433 append r [uidchar] 434 } 435 return $r 436} 437 438# ------------------------------------------------------------------------- 439# Description: 440# Calculate the local offset from GMT in hours for use in the timestamp 441# 442proc ::smtpd::gmtoffset {} { 443 set now [clock seconds] 444 set local [clock format $now -format "%j %H" -gmt false] 445 set zulu [clock format $now -format "%j %H" -gmt true] 446 set lh [expr {([scan [lindex $local 0] %d] * 24) \ 447 + [scan [lindex $local 1] %d]}] 448 set zh [expr {([scan [lindex $zulu 0] %d] * 24) \ 449 + [scan [lindex $zulu 1] %d]}] 450 set off [expr {$lh - $zh}] 451 set off [format "%+03d00" $off] 452 return $off 453} 454 455# ------------------------------------------------------------------------- 456# Description: 457# Generate a standard SMTP compliant timestamp. That is a local time but with 458# the timezone represented as an offset. 459# 460proc ::smtpd::timestamp {} { 461 set ts [clock format [clock seconds] \ 462 -format "%a, %d %b %Y %H:%M:%S" -gmt false] 463 append ts " " [gmtoffset] 464 return $ts 465} 466 467# ------------------------------------------------------------------------- 468# Description: 469# Get the servers ip address (from http://purl.org/mini/tcl/526.html) 470# 471proc ::smtpd::server_ip {} { 472 set me [socket -server xxx -myaddr [info hostname] 0] 473 set ip [lindex [fconfigure $me -sockname] 0] 474 close $me 475 return $ip 476} 477 478# ------------------------------------------------------------------------- 479# Description: 480# deliver is called once a mail transaction is completed and there is 481# no deliver procedure defined 482# The configured -deliverMIME procedure is called with a MIME token. 483# If no such callback is defined then try the -deliver option and use 484# the old API. 485# 486proc ::smtpd::deliver {channel} { 487 set deliverMIME [cget deliverMIME] 488 if { $deliverMIME != {} \ 489 && [state $channel from] != {} \ 490 && [state $channel to] != {} \ 491 && [state $channel data] != {} } { 492 493 # create a MIME token from the mail message. 494 set tok [mime::initialize -string \ 495 [join [state $channel data] "\n"]] 496# mime::setheader $tok "From" [state $channel from] 497# foreach recipient [state $channel to] { 498# mime::setheader $tok "To" $recipient -mode append 499# } 500 501 # catch and rethrow any errors. 502 set err [catch {eval $deliverMIME [list $tok]} msg] 503 mime::finalize $tok -subordinates all 504 if {$err} { 505 Log debug "error in deliver: $msg" 506 return -code error -errorcode $::errorCode \ 507 -errorinfo $::errorInfo $msg 508 } 509 510 } else { 511 # Try the old interface 512 deliver_old $channel 513 } 514} 515 516# ------------------------------------------------------------------------- 517# Description: 518# Deliver is called once a mail transaction is completed (defined as the 519# completion of a DATA command). The configured -deliver procedure is called 520# with the sender, list of recipients and the text of the mail. 521# 522proc ::smtpd::deliver_old {channel} { 523 set deliver [cget deliver] 524 if { $deliver != {} \ 525 && [state $channel from] != {} \ 526 && [state $channel to] != {} \ 527 && [state $channel data] != {} } { 528 if {[catch {$deliver [state $channel from] \ 529 [state $channel to] \ 530 [state $channel data]} msg]} { 531 Log debug "error in deliver: $msg" 532 return -code error -errorcode $::errorCode \ 533 -errorinfo $::errorInfo $msg 534 } 535 } 536} 537 538# ------------------------------------------------------------------------- 539proc ::smtpd::split_address {address} { 540 set start [string first < $address] 541 set end [string last > $address] 542 set addr [string range $address $start $end] 543 incr end 544 set opts [string trim [string range $address $end end]] 545 return [list $addr $opts] 546} 547 548# ------------------------------------------------------------------------- 549# The SMTP Commands 550# ------------------------------------------------------------------------- 551# Description: 552# Initiate an SMTP session 553# Reference: 554# RFC2821 4.1.1.1 555# 556proc ::smtpd::HELO {channel line} { 557 variable options 558 559 if {[state $channel domain] != {}} { 560 Puts $channel "503 bad sequence of commands" 561 Log debug "HELO received out of sequence." 562 return 563 } 564 565 set r [regexp -nocase {^HELO\s+([-\w\.]+)\s*$} $line -> domain] 566 if {$r == 0} { 567 Puts $channel "501 Syntax error in parameters or arguments" 568 Log debug "HELO received \"$line\"" 569 return 570 } 571 Puts $channel "250 $options(serveraddr) Hello $domain\ 572 \[[state $channel client_addr]\], pleased to meet you" 573 state $channel domain $domain 574 Log debug "HELO on $channel from $domain" 575 return 576} 577 578# ------------------------------------------------------------------------- 579# Description: 580# Initiate an ESMTP session 581# Reference: 582# RFC2821 4.1.1.1 583proc ::smtpd::EHLO {channel line} { 584 variable options 585 variable extensions 586 587 if {[state $channel domain] != {}} { 588 Puts $channel "503 bad sequence of commands" 589 Log debug "EHLO received out of sequence." 590 return 591 } 592 593 set r [regexp -nocase {^EHLO\s+([-\w\.]+)\s*$} $line -> domain] 594 if {$r == 0} { 595 Puts $channel "501 Syntax error in parameters or arguments" 596 Log debug "EHLO received \"$line\"" 597 return 598 } 599 Puts $channel "250-$options(serveraddr) Hello $domain\ 600 \[[state $channel client_addr]\], pleased to meet you" 601 foreach {extn opts} [array get extensions] { 602 Puts $channel [string trimright "250-$extn $opts"] 603 } 604 Puts $channel "250 Ready for mail." 605 state $channel domain $domain 606 Log debug "EHLO on $channel from $domain" 607 return 608} 609 610# ------------------------------------------------------------------------- 611# Description: 612# Reference: 613# RFC2821 4.1.1.2 614# 615proc ::smtpd::MAIL {channel line} { 616 set r [regexp -nocase {^MAIL FROM:\s*(.*)} $line -> from] 617 if {$r == 0} { 618 Puts $channel "501 Syntax error in parameters or arguments" 619 Log debug "MAIL received \"$line\"" 620 return 621 } 622 if {[catch { 623 set from [split_address $from] 624 set opts [lindex $from 1] 625 set from [lindex $from 0] 626 eval array set addr [mime::parseaddress $from] 627 # RFC2821 3.7: we must accept null return path addresses. 628 if {[string equal "<>" $from]} { 629 set addr(error) {} 630 } 631 } msg]} { 632 set addr(error) $msg 633 } 634 if {$addr(error) != {} } { 635 Log debug "MAIL failed $addr(error)" 636 Puts $channel "501 Syntax error in parameters or arguments" 637 return 638 } 639 640 if {[cget -validate_sender] != {}} { 641 if {[catch {eval [cget -validate_sender] $addr(address)}]} { 642 # this user has been denied 643 Log info "MAIL denied user $addr(address)" 644 Puts $channel "553 Requested action not taken:\ 645 mailbox name not allowed" 646 return 647 } 648 } 649 650 Log debug "MAIL FROM: $addr(address)" 651 state $channel from $from 652 state $channel options $opts 653 Puts $channel "250 OK" 654 return 655} 656 657# ------------------------------------------------------------------------- 658# Description: 659# Specify a recipient for this mail. This command may be executed multiple 660# times to contruct a list of recipients. If a -validate_recipient 661# procedure is configured then this is used. An error from the validation 662# procedure indicates an invalid or unacceptable mailbox. 663# Reference: 664# RFC2821 4.1.1.3 665# Notes: 666# The postmaster mailbox MUST be supported. (RFC2821: 4.5.1) 667# 668proc ::smtpd::RCPT {channel line} { 669 set r [regexp -nocase {^RCPT TO:\s*(.*)} $line -> to] 670 if {$r == 0} { 671 Puts $channel "501 Syntax error in parameters or arguments" 672 Log debug "RCPT received \"$line\"" 673 return 674 } 675 if {[catch { 676 set to [split_address $to] 677 set opts [lindex $to 1] 678 set to [lindex $to 0] 679 eval array set addr [mime::parseaddress $to] 680 } msg]} { 681 set addr(error) $msg 682 } 683 684 if {$addr(error) != {}} { 685 Log debug "RCPT failed $addr(error)" 686 Puts $channel "501 Syntax error in parameters or arguments" 687 return 688 } 689 690 if {[string match -nocase "postmaster" $addr(local)]} { 691 # we MUST support this recipient somehow as mail. 692 Log notice "RCPT to postmaster" 693 } else { 694 if {[cget -validate_recipient] != {}} { 695 if {[catch {eval [cget -validate_recipient] $addr(address)}]} { 696 # this recipient has been denied 697 Log info "RCPT denied mailbox $addr(address)" 698 Puts $channel "553 Requested action not taken:\ 699 mailbox name not allowed" 700 return 701 } 702 } 703 } 704 705 Log debug "RCPT TO: $addr(address)" 706 set recipients {} 707 catch {set recipients [state $channel to]} 708 lappend recipients $to 709 state $channel to $recipients 710 Puts $channel "250 OK" 711 return 712} 713 714# ------------------------------------------------------------------------- 715# Description: 716# Begin accepting data for the mail payload. A line containing a single 717# period marks the end of the data and the server will then deliver the 718# mail. RCPT and MAIL commands must have been executed before the DATA 719# command. 720# Reference: 721# RFC2821 4.1.1.4 722# Notes: 723# The DATA section is the only part of the protocol permitted to use non- 724# ASCII characters and non-CRLF line endings and some clients take 725# advantage of this. Therefore we change the translation option on the 726# channel and reset it once the DATA command is completed. See the 727# 'service' procedure for the handling of DATA lines. 728# We also insert trace information as per RFC2821:4.4 729# 730proc ::smtpd::DATA {channel line} { 731 variable version 732 upvar [namespace current]::state_$channel State 733 Log debug "DATA" 734 if { $State(from) == {}} { 735 Puts $channel "503 bad sequence: no sender specified" 736 } elseif { $State(to) == {}} { 737 Puts $channel "503 bad sequence: no recipient specified" 738 } else { 739 Puts $channel "354 Enter mail, end with \".\" on a line by itself" 740 set State(id) [uid] 741 set State(indata) 1 742 743 lappend trace "Return-Path: $State(from)" 744 lappend trace "Received: from [state $channel domain]\ 745 \[[state $channel client_addr]\]" 746 lappend trace "\tby [info hostname] with tcllib smtpd ($version)" 747 if {[info exists State(tls)] && $State(tls)} { 748 catch { 749 array set t [::tls::status $channel] 750 lappend trace "\t(version=TLS1/SSL3 cipher=$t(cipher) bits=$t(sbits) verify=NO)" 751 } 752 } 753 lappend trace "\tid $State(id); [timestamp]" 754 set State(data) $trace 755 fconfigure $channel -translation auto ;# naughty: RFC2821:2.3.7 756 } 757 return 758} 759 760# ------------------------------------------------------------------------- 761# Description: 762# Reset the server state for this connection. 763# Reference: 764# RFC2821 4.1.1.5 765# 766proc ::smtpd::RSET {channel line} { 767 upvar [namespace current]::state_$channel State 768 Log debug "RSET on $channel" 769 if {[catch {initializeState $channel} msg]} { 770 Log warn "RSET: $msg" 771 } 772 Puts $channel "250 OK" 773 return 774} 775 776# ------------------------------------------------------------------------- 777# Description: 778# Verify the existence of a mailbox on the server 779# Reference: 780# RFC2821 4.1.1.6 781# 782#proc ::smtpd::VRFY {channel line} { 783# # VRFY SP String CRLF 784#} 785 786# ------------------------------------------------------------------------- 787# Description: 788# Expand a mailing list. 789# Reference: 790# RFC2821 4.1.1.7 791# 792#proc ::smtpd::EXPN {channel line} { 793# # EXPN SP String CRLF 794#} 795 796# ------------------------------------------------------------------------- 797# Description: 798# Return a help message. 799# Reference: 800# RFC2821 4.1.1.8 801# 802proc ::smtpd::HELP {channel line} { 803 variable Help 804 set cmd {} 805 regexp {^HELP\s*(\w+)?} $line -> cmd 806 if {[info exists Help($cmd)]} { 807 foreach line $Help($cmd) { 808 Puts $channel "214-$line" 809 } 810 Puts $channel "214 End of HELP" 811 } else { 812 Puts $channel "504 HELP topic \"$cmd\" unknown." 813 } 814} 815 816# ------------------------------------------------------------------------- 817# Description: 818# Perform no action. 819# Reference: 820# RFC2821 4.1.1.9 821# 822proc ::smtpd::NOOP {channel line} { 823 set str {} 824 regexp -nocase {^NOOP (.*)$} -> str 825 Log debug "NOOP: $str" 826 Puts $channel "250 OK" 827 return 828} 829 830# ------------------------------------------------------------------------- 831# Description: 832# Terminate a session and close the transmission channel. 833# Reference: 834# RFC2821 4.1.1.10 835# Notes: 836# The server is only permitted to close the channel once it has received 837# a QUIT message. 838# 839proc ::smtpd::QUIT {channel line} { 840 variable options 841 upvar [namespace current]::state_$channel State 842 843 Log debug "QUIT on $channel" 844 Puts $channel "221 $options(serveraddr) Service closing transmission channel" 845 close $channel 846 847 # cleanup the session state array. 848 unset State 849 return 850} 851 852# ------------------------------------------------------------------------- 853# Description: 854# Implement support for secure mail transactions using the TLS package. 855# Reference: 856# RFC3207 857# Notes: 858# 859proc ::smtpd::STARTTLS {channel line} { 860 variable options 861 upvar [namespace current]::state_$channel State 862 863 Log debug "$line on $channel" 864 if {![string equal $line STARTTLS]} { 865 Puts $channel "501 Syntax error (no parameters allowed)" 866 return 867 } 868 869 if {[lsearch -exact $options(tlsopts) -certfile] == -1 870 || [lsearch -exact $options(tlsopts) -keyfile] == -1} { 871 Puts $channel "454 TLS not available due to temporary reason" 872 return 873 } 874 875 set import [linsert $options(tlsopts) 0 ::tls::import $channel -server 1] 876 Puts $channel "220 Ready to start TLS" 877 if {[catch $import msg]} { 878 Puts $channel "454 TLS not available due to temporary reason" 879 } else { 880 set State(domain) {}; # RFC3207:4.2 881 set State(tls) 1 882 } 883 return 884} 885 886# ------------------------------------------------------------------------- 887# Logging callback for use with tls - you must specify this when configuring 888# smtpd if you wan to use it. 889# 890proc ::smtpd::tlscallback {option args} { 891 switch -exact -- $option { 892 "error" { 893 foreach {chan msg} $args break 894 Log error "TLS error '$msg'" 895 } 896 "verify" { 897 foreach {chan depth cert rc err} $args break 898 if {$rc ne "1"} { 899 Log error "TLS verify/$depth Bad cert '$err' (rc=$rc)" 900 } else { 901 array set c $cert 902 Log notice "TLS verify/$depth: $c(subject)" 903 } 904 return $rc 905 } 906 "info" { 907 foreach {chan major minor state msg} $args break 908 if {$msg ne ""} { append state ": $msg" } 909 Log debug "TLS ${major}.${minor} $state" 910 } 911 default { 912 Log warn "bad option \"$option\" in smtpd::callback" 913 } 914 } 915} 916 917# ------------------------------------------------------------------------- 918 919package provide smtpd $smtpd::version 920 921# ------------------------------------------------------------------------- 922# Local variables: 923# mode: tcl 924# indent-tabs-mode: nil 925# End: 926