1# smtp.tcl - SMTP client 2# 3# Copyright (c) 1999-2000 Marshall T. Rose 4# Copyright (c) 2003-2006 Pat Thoyts 5# 6# See the file "license.terms" for information on usage and redistribution 7# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 8# 9 10package require Tcl 8.3 11package require mime 1.4.1 12 13catch { 14 package require SASL 1.0; # tcllib 1.8 15 package require SASL::NTLM 1.0; # tcllib 1.8 16} 17 18# 19# state variables: 20# 21# sd: socket to server 22# afterID: afterID associated with ::smtp::timer 23# options: array of user-supplied options 24# readable: semaphore for vwait 25# addrs: number of recipients negotiated 26# error: error during read 27# line: response read from server 28# crP: just put a \r in the data 29# nlP: just put a \n in the data 30# size: number of octets sent in DATA 31# 32 33namespace eval ::smtp { 34 variable trf 1 35 variable smtp 36 array set smtp { uid 0 } 37 38 namespace export sendmessage 39} 40 41if {[catch {package require Trf 2.0}]} { 42 # Trf is not available, but we can live without it as long as the 43 # transform and unstack procs are defined. 44 45 # Warning! 46 # This is a fragile emulation of the more general calling sequence 47 # that appears to work with this code here. 48 49 proc transform {args} { 50 upvar state mystate 51 set mystate(size) 1 52 } 53 proc unstack {channel} { 54 # do nothing 55 return 56 } 57 set ::smtp::trf 0 58} 59 60 61# ::smtp::sendmessage -- 62# 63# Sends a mime object (containing a message) to some recipients 64# 65# Arguments: 66# part The MIME object containing the message to send 67# args A list of arguments specifying various options for sending the 68# message: 69# -atleastone A boolean specifying whether or not to send the 70# message at all if any of the recipients are 71# invalid. A value of false (as defined by 72# ::smtp::boolean) means that ALL recipients must be 73# valid in order to send the message. A value of 74# true means that as long as at least one recipient 75# is valid, the message will be sent. 76# -debug A boolean specifying whether or not debugging is 77# on. If debugging is enabled, status messages are 78# printed to stderr while trying to send mail. 79# -queue A boolean specifying whether or not the message 80# being sent should be queued for later delivery. 81# -header A single RFC 822 header key and value (as a list), 82# used to specify to whom to send the message 83# (To, Cc, Bcc), the "From", etc. 84# -originator The originator of the message (equivalent to 85# specifying a From header). 86# -recipients A string containing recipient e-mail addresses. 87# NOTE: This option overrides any recipient addresses 88# specified with -header. 89# -servers A list of mail servers that could process the 90# request. 91# -ports A list of SMTP ports to use for each SMTP server 92# specified 93# -client The string to use as our host name for EHLO or HELO 94# This defaults to 'localhost' or [info hostname] 95# -maxsecs Maximum number of seconds to allow the SMTP server 96# to accept the message. If not specified, the default 97# is 120 seconds. 98# -usetls A boolean flag. If the server supports it and we 99# have the package, use TLS to secure the connection. 100# -tlspolicy A command to call if the TLS negotiation fails for 101# some reason. Return 'insecure' to continue with 102# normal SMTP or 'secure' to close the connection and 103# try another server. 104# -tlsimport after a succesfull socket command, import tls on 105# channel - used for native smtps negotiation 106# -username These are needed if your SMTP server requires 107# -password authentication. 108# 109# Results: 110# Message is sent. On success, return "". On failure, throw an 111# exception with an error code and error message. 112 113proc ::smtp::sendmessage {part args} { 114 global errorCode errorInfo 115 116 # Here are the meanings of the following boolean variables: 117 # aloP -- value of -atleastone option above. 118 # debugP -- value of -debug option above. 119 # origP -- 1 if -originator option was specified, 0 otherwise. 120 # queueP -- value of -queue option above. 121 122 set aloP 0 123 set debugP 0 124 set origP 0 125 set queueP 0 126 set maxsecs 120 127 set originator "" 128 set recipients "" 129 set servers [list localhost] 130 set client "" ;# default is set after options processing 131 set ports [list 25] 132 set tlsP 1 133 set tlspolicy {} 134 set tlsimport 0 135 set username {} 136 set password {} 137 138 array set header "" 139 140 # lowerL will contain the list of header keys (converted to lower case) 141 # specified with various -header options. mixedL is the mixed-case version 142 # of the list. 143 set lowerL "" 144 set mixedL "" 145 146 # Parse options (args). 147 148 if {[expr {[llength $args]%2}]} { 149 # Some option didn't get a value. 150 error "Each option must have a value! Invalid option list: $args" 151 } 152 153 foreach {option value} $args { 154 switch -- $option { 155 -atleastone {set aloP [boolean $value]} 156 -debug {set debugP [boolean $value]} 157 -queue {set queueP [boolean $value]} 158 -usetls {set tlsP [boolean $value]} 159 -tlspolicy {set tlspolicy $value} 160 -tlsimport {set tlsimport [boolean $value]} 161 -maxsecs {set maxsecs [expr {$value < 0 ? 0 : $value}]} 162 -header { 163 if {[llength $value] != 2} { 164 error "-header expects a key and a value, not $value" 165 } 166 set mixed [lindex $value 0] 167 set lower [string tolower $mixed] 168 set disallowedHdrList \ 169 [list content-type \ 170 content-transfer-encoding \ 171 content-md5 \ 172 mime-version] 173 if {[lsearch -exact $disallowedHdrList $lower] > -1} { 174 error "Content-Type, Content-Transfer-Encoding,\ 175 Content-MD5, and MIME-Version cannot be user-specified." 176 } 177 if {[lsearch -exact $lowerL $lower] < 0} { 178 lappend lowerL $lower 179 lappend mixedL $mixed 180 } 181 182 lappend header($lower) [lindex $value 1] 183 } 184 185 -originator { 186 set originator $value 187 if {$originator == ""} { 188 set origP 1 189 } 190 } 191 192 -recipients { 193 set recipients $value 194 } 195 196 -servers { 197 set servers $value 198 } 199 200 -client { 201 set client $value 202 } 203 204 -ports { 205 set ports $value 206 } 207 208 -username { set username $value } 209 -password { set password $value } 210 211 default { 212 error "unknown option $option" 213 } 214 } 215 } 216 217 if {[lsearch -glob $lowerL resent-*] >= 0} { 218 set prefixL resent- 219 set prefixM Resent- 220 } else { 221 set prefixL "" 222 set prefixM "" 223 } 224 225 # Set a bunch of variables whose value will be the real header to be used 226 # in the outbound message (with proper case and prefix). 227 228 foreach mixed {From Sender To cc Dcc Bcc Date Message-ID} { 229 set lower [string tolower $mixed] 230 # FRINK: nocheck 231 set ${lower}L $prefixL$lower 232 # FRINK: nocheck 233 set ${lower}M $prefixM$mixed 234 } 235 236 if {$origP} { 237 # -originator was specified with "", so SMTP sender should be marked "". 238 set sender "" 239 } else { 240 # -originator was specified with a value, OR -originator wasn't 241 # specified at all. 242 243 # If no -originator was provided, get the originator from the "From" 244 # header. If there was no "From" header get it from the username 245 # executing the script. 246 247 set who "-originator" 248 if {$originator == ""} { 249 if {![info exists header($fromL)]} { 250 set originator $::tcl_platform(user) 251 } else { 252 set originator [join $header($fromL) ,] 253 254 # Indicate that we're using the From header for the originator. 255 256 set who $fromM 257 } 258 } 259 260 # If there's no "From" header, create a From header with the value 261 # of -originator as the value. 262 263 if {[lsearch -exact $lowerL $fromL] < 0} { 264 lappend lowerL $fromL 265 lappend mixedL $fromM 266 lappend header($fromL) $originator 267 } 268 269 # ::mime::parseaddress returns a list whose elements are huge key-value 270 # lists with info about the addresses. In this case, we only want one 271 # originator, so we want the length of the main list to be 1. 272 273 set addrs [::mime::parseaddress $originator] 274 if {[llength $addrs] > 1} { 275 error "too many mailboxes in $who: $originator" 276 } 277 array set aprops {error "invalid address \"$from\""} 278 array set aprops [lindex $addrs 0] 279 if {$aprops(error) != ""} { 280 error "error in $who: $aprops(error)" 281 } 282 283 # sender = validated originator or the value of the From header. 284 285 set sender $aprops(address) 286 287 # If no Sender header has been specified and From is different from 288 # originator, then set the sender header to the From. Otherwise, don't 289 # specify a Sender header. 290 set from [join $header($fromL) ,] 291 if {[lsearch -exact $lowerL $senderL] < 0 && \ 292 [string compare $originator $from]} { 293 if {[info exists aprops]} { 294 unset aprops 295 } 296 array set aprops {error "invalid address \"$from\""} 297 array set aprops [lindex [::mime::parseaddress $from] 0] 298 if {$aprops(error) != ""} { 299 error "error in $fromM: $aprops(error)" 300 } 301 if {[string compare $aprops(address) $sender]} { 302 lappend lowerL $senderL 303 lappend mixedL $senderM 304 lappend header($senderL) $aprops(address) 305 } 306 } 307 } 308 309 # We're done parsing the arguments. 310 311 if {$recipients != ""} { 312 set who -recipients 313 } elseif {![info exists header($toL)]} { 314 error "need -header \"$toM ...\"" 315 } else { 316 set recipients [join $header($toL) ,] 317 # Add Cc values to recipients list 318 set who $toM 319 if {[info exists header($ccL)]} { 320 append recipients ,[join $header($ccL) ,] 321 append who /$ccM 322 } 323 324 set dccInd [lsearch -exact $lowerL $dccL] 325 if {$dccInd >= 0} { 326 # Add Dcc values to recipients list, and get rid of Dcc header 327 # since we don't want to output that. 328 append recipients ,[join $header($dccL) ,] 329 append who /$dccM 330 331 unset header($dccL) 332 set lowerL [lreplace $lowerL $dccInd $dccInd] 333 set mixedL [lreplace $mixedL $dccInd $dccInd] 334 } 335 } 336 337 set brecipients "" 338 set bccInd [lsearch -exact $lowerL $bccL] 339 if {$bccInd >= 0} { 340 set bccP 1 341 342 # Build valid bcc list and remove bcc element of header array (so that 343 # bcc info won't be sent with mail). 344 foreach addr [::mime::parseaddress [join $header($bccL) ,]] { 345 if {[info exists aprops]} { 346 unset aprops 347 } 348 array set aprops {error "invalid address \"$from\""} 349 array set aprops $addr 350 if {$aprops(error) != ""} { 351 error "error in $bccM: $aprops(error)" 352 } 353 lappend brecipients $aprops(address) 354 } 355 356 unset header($bccL) 357 set lowerL [lreplace $lowerL $bccInd $bccInd] 358 set mixedL [lreplace $mixedL $bccInd $bccInd] 359 } else { 360 set bccP 0 361 } 362 363 # If there are no To headers, add "" to bcc list. WHY?? 364 if {[lsearch -exact $lowerL $toL] < 0} { 365 lappend lowerL $bccL 366 lappend mixedL $bccM 367 lappend header($bccL) "" 368 } 369 370 # Construct valid recipients list from recipients list. 371 372 set vrecipients "" 373 foreach addr [::mime::parseaddress $recipients] { 374 if {[info exists aprops]} { 375 unset aprops 376 } 377 array set aprops {error "invalid address \"$from\""} 378 array set aprops $addr 379 if {$aprops(error) != ""} { 380 error "error in $who: $aprops(error)" 381 } 382 lappend vrecipients $aprops(address) 383 } 384 385 # If there's no date header, get the date from the mime message. Same for 386 # the message-id. 387 388 if {([lsearch -exact $lowerL $dateL] < 0) \ 389 && ([catch { ::mime::getheader $part $dateL }])} { 390 lappend lowerL $dateL 391 lappend mixedL $dateM 392 lappend header($dateL) [::mime::parsedatetime -now proper] 393 } 394 395 if {([lsearch -exact $lowerL ${message-idL}] < 0) \ 396 && ([catch { ::mime::getheader $part ${message-idL} }])} { 397 lappend lowerL ${message-idL} 398 lappend mixedL ${message-idM} 399 lappend header(${message-idL}) [::mime::uniqueID] 400 401 } 402 403 # Get all the headers from the MIME object and save them so that they can 404 # later be restored. 405 set savedH [::mime::getheader $part] 406 407 # Take all the headers defined earlier and add them to the MIME message. 408 foreach lower $lowerL mixed $mixedL { 409 foreach value $header($lower) { 410 ::mime::setheader $part $mixed $value -mode append 411 } 412 } 413 414 if {[string length $client] < 1} { 415 if {![string compare $servers localhost]} { 416 set client localhost 417 } else { 418 set client [info hostname] 419 } 420 } 421 422 # Create smtp token, which essentially means begin talking to the SMTP 423 # server. 424 set token [initialize -debug $debugP -client $client \ 425 -maxsecs $maxsecs -usetls $tlsP \ 426 -multiple $bccP -queue $queueP \ 427 -servers $servers -ports $ports \ 428 -tlspolicy $tlspolicy -tlsimport $tlsimport \ 429 -username $username -password $password] 430 431 if {![string match "::smtp::*" $token]} { 432 # An error occurred and $token contains the error info 433 array set respArr $token 434 return -code error $respArr(diagnostic) 435 } 436 437 set code [catch { sendmessageaux $token $part \ 438 $sender $vrecipients $aloP } \ 439 result] 440 set ecode $errorCode 441 set einfo $errorInfo 442 443 # Send the message to bcc recipients as a MIME attachment. 444 445 if {($code == 0) && ($bccP)} { 446 set inner [::mime::initialize -canonical message/rfc822 \ 447 -header [list Content-Description \ 448 "Original Message"] \ 449 -parts [list $part]] 450 451 set subject "\[$bccM\]" 452 if {[info exists header(subject)]} { 453 append subject " " [lindex $header(subject) 0] 454 } 455 456 set outer [::mime::initialize \ 457 -canonical multipart/digest \ 458 -header [list From $originator] \ 459 -header [list Bcc ""] \ 460 -header [list Date \ 461 [::mime::parsedatetime -now proper]] \ 462 -header [list Subject $subject] \ 463 -header [list Message-ID [::mime::uniqueID]] \ 464 -header [list Content-Description \ 465 "Blind Carbon Copy"] \ 466 -parts [list $inner]] 467 468 469 set code [catch { sendmessageaux $token $outer \ 470 $sender $brecipients \ 471 $aloP } result2] 472 set ecode $errorCode 473 set einfo $errorInfo 474 475 if {$code == 0} { 476 set result [concat $result $result2] 477 } else { 478 set result $result2 479 } 480 481 catch { ::mime::finalize $inner -subordinates none } 482 catch { ::mime::finalize $outer -subordinates none } 483 } 484 485 # Determine if there was any error in prior operations and set errorcodes 486 # and error messages appropriately. 487 488 switch -- $code { 489 0 { 490 set status orderly 491 } 492 493 7 { 494 set code 1 495 array set response $result 496 set result "$response(code): $response(diagnostic)" 497 set status abort 498 } 499 500 default { 501 set status abort 502 } 503 } 504 505 # Destroy SMTP token 'cause we're done with it. 506 507 catch { finalize $token -close $status } 508 509 # Restore provided MIME object to original state (without the SMTP headers). 510 511 foreach key [::mime::getheader $part -names] { 512 mime::setheader $part $key "" -mode delete 513 } 514 foreach {key values} $savedH { 515 foreach value $values { 516 ::mime::setheader $part $key $value -mode append 517 } 518 } 519 520 return -code $code -errorinfo $einfo -errorcode $ecode $result 521} 522 523# ::smtp::sendmessageaux -- 524# 525# Sends a mime object (containing a message) to some recipients using an 526# existing SMTP token. 527# 528# Arguments: 529# token SMTP token that has an open connection to the SMTP server. 530# part The MIME object containing the message to send. 531# originator The e-mail address of the entity sending the message, 532# usually the From clause. 533# recipients List of e-mail addresses to whom message will be sent. 534# aloP Boolean "atleastone" setting; see the -atleastone option 535# in ::smtp::sendmessage for details. 536# 537# Results: 538# Message is sent. On success, return "". On failure, throw an 539# exception with an error code and error message. 540 541proc ::smtp::sendmessageaux {token part originator recipients aloP} { 542 global errorCode errorInfo 543 544 winit $token $part $originator 545 546 set goodP 0 547 set badP 0 548 set oops "" 549 foreach recipient $recipients { 550 set code [catch { waddr $token $recipient } result] 551 set ecode $errorCode 552 set einfo $errorInfo 553 554 switch -- $code { 555 0 { 556 incr goodP 557 } 558 559 7 { 560 incr badP 561 562 array set response $result 563 lappend oops [list $recipient $response(code) \ 564 $response(diagnostic)] 565 } 566 567 default { 568 return -code $code -errorinfo $einfo -errorcode $ecode $result 569 } 570 } 571 } 572 573 if {($goodP) && ((!$badP) || ($aloP))} { 574 wtext $token $part 575 } else { 576 catch { talk $token 300 RSET } 577 } 578 579 return $oops 580} 581 582# ::smtp::initialize -- 583# 584# Create an SMTP token and open a connection to the SMTP server. 585# 586# Arguments: 587# args A list of arguments specifying various options for sending the 588# message: 589# -debug A boolean specifying whether or not debugging is 590# on. If debugging is enabled, status messages are 591# printed to stderr while trying to send mail. 592# -client Either localhost or the name of the local host. 593# -multiple Multiple messages will be sent using this token. 594# -queue A boolean specifying whether or not the message 595# being sent should be queued for later delivery. 596# -servers A list of mail servers that could process the 597# request. 598# -ports A list of ports on mail servers that could process 599# the request (one port per server-- defaults to 25). 600# -usetls A boolean to indicate we will use TLS if possible. 601# -tlspolicy Command called if TLS setup fails. 602# -tlsimport after a succesfull socket command, import tls on 603# channel - used for native smtps negotiation 604# -username These provide the authentication information 605# -password to be used if needed by the SMTP server. 606# 607# Results: 608# On success, return an smtp token. On failure, throw 609# an exception with an error code and error message. 610 611proc ::smtp::initialize {args} { 612 global errorCode errorInfo 613 614 variable smtp 615 616 set token [namespace current]::[incr smtp(uid)] 617 # FRINK: nocheck 618 variable $token 619 upvar 0 $token state 620 621 array set state [list afterID "" options "" readable 0] 622 array set options [list -debug 0 -client localhost -multiple 1 \ 623 -maxsecs 120 -queue 0 -servers localhost \ 624 -ports 25 -usetls 1 -tlspolicy {} \ 625 -tlsimport 0 \ 626 -username {} -password {}] 627 array set options $args 628 set state(options) [array get options] 629 630 # Iterate through servers until one accepts a connection (and responds 631 # nicely). 632 633 foreach server $options(-servers) port $options(-ports) { 634 if {$server == ""} continue 635 636 set state(readable) 0 637 if {$port == ""} { set port 25 } 638 639 if {$options(-debug)} { 640 puts stderr "Trying $server..." 641 flush stderr 642 } 643 644 if {[info exists state(sd)]} { 645 unset state(sd) 646 } 647 648 if {[set code [catch { 649 set state(sd) [socket -async $server $port] 650 if { $options(-tlsimport) } { 651 package require tls 652 tls::import $state(sd) 653 } 654 fconfigure $state(sd) -blocking off -translation binary 655 fileevent $state(sd) readable [list ::smtp::readable $token] 656 } result]]} { 657 set ecode $errorCode 658 set einfo $errorInfo 659 660 catch { close $state(sd) } 661 continue 662 } 663 664 if {[set code [catch { hear $token 600 } result]]} { 665 array set response [list code 400 diagnostic $result] 666 } else { 667 array set response $result 668 } 669 set ecode $errorCode 670 set einfo $errorInfo 671 switch -- $response(code) { 672 220 { 673 } 674 675 421 - default { 676 # 421 - Temporary problem on server 677 catch {close $state(sd)} 678 continue 679 } 680 } 681 682 set r [initialize_ehlo $token] 683 if {$r != {}} { 684 return $r 685 } 686 } 687 688 # None of the servers accepted our connection, so close everything up and 689 # return an error. 690 finalize $token -close drop 691 692 return -code $code -errorinfo $einfo -errorcode $ecode $result 693} 694 695# If we cannot load the tls package, ignore the error 696# Result value is a Tcl return code, not a bool. 697# 0 == OK 698proc ::smtp::load_tls {} { 699 set r [catch {package require tls}] 700 if {$r} {set ::errorInfo ""} 701 return $r 702} 703 704proc ::smtp::initialize_ehlo {token} { 705 global errorCode errorInfo 706 upvar einfo einfo 707 upvar ecode ecode 708 upvar code code 709 710 # FRINK: nocheck 711 variable $token 712 upvar 0 $token state 713 array set options $state(options) 714 715 # Try enhanced SMTP first. 716 717 if {[set code [catch {smtp::talk $token 300 "EHLO $options(-client)"} \ 718 result]]} { 719 array set response [list code 400 diagnostic $result args ""] 720 } else { 721 array set response $result 722 } 723 set ecode $errorCode 724 set einfo $errorInfo 725 if {(500 <= $response(code)) && ($response(code) <= 599)} { 726 if {[set code [catch { talk $token 300 \ 727 "HELO $options(-client)" } \ 728 result]]} { 729 array set response [list code 400 diagnostic $result args ""] 730 } else { 731 array set response $result 732 } 733 set ecode $errorCode 734 set einfo $errorInfo 735 } 736 737 if {$response(code) == 250} { 738 # Successful response to HELO or EHLO command, so set up queuing 739 # and whatnot and return the token. 740 741 set state(esmtp) $response(args) 742 743 if {(!$options(-multiple)) \ 744 && ([lsearch $response(args) ONEX] >= 0)} { 745 catch {smtp::talk $token 300 ONEX} 746 } 747 if {($options(-queue)) \ 748 && ([lsearch $response(args) XQUE] >= 0)} { 749 catch {smtp::talk $token 300 QUED} 750 } 751 752 # Support STARTTLS extension. 753 # The state(tls) item is used to see if we have already tried this. 754 if {($options(-usetls)) && ![info exists state(tls)] \ 755 && (([lsearch $response(args) STARTTLS] >= 0) 756 || ([lsearch $response(args) TLS] >= 0))} { 757 if {[load_tls] == 0} { 758 set state(tls) 0 759 if {![catch {smtp::talk $token 300 STARTTLS} resp]} { 760 array set starttls $resp 761 if {$starttls(code) == 220} { 762 fileevent $state(sd) readable {} 763 catch { 764 ::tls::import $state(sd) 765 catch {::tls::handshake $state(sd)} msg 766 set state(tls) 1 767 } 768 fileevent $state(sd) readable \ 769 [list ::smtp::readable $token] 770 return [initialize_ehlo $token] 771 } else { 772 # Call a TLS client policy proc here 773 # returns secure - close and try another server. 774 # returns insecure - continue on current socket 775 set policy insecure 776 if {$options(-tlspolicy) != {}} { 777 catch { 778 eval $options(-tlspolicy) \ 779 [list $starttls(code)] \ 780 [list $starttls(diagnostic)] 781 } policy 782 } 783 if {$policy != "insecure"} { 784 set code error 785 set ecode $starttls(code) 786 set einfo $starttls(diagnostic) 787 catch {close $state(sd)} 788 return {} 789 } 790 } 791 } 792 } 793 } 794 795 # If we have not already tried and the server supports it and we 796 # have a username -- lets try to authenticate. 797 # 798 if {![info exists state(auth)] 799 && [llength [package provide SASL]] != 0 800 && [set andx [lsearch -glob $response(args) "AUTH*"]] >= 0 801 && [string length $options(-username)] > 0 } { 802 803 # May be AUTH mech or AUTH=mech 804 # We want to use the strongest mechanism that has been offered 805 # and that we support. If we cannot find a mechanism that 806 # succeeds, we will go ahead and try to carry on unauthenticated. 807 # This may still work else we'll get an unauthorised error later. 808 809 set mechs [string range [lindex $response(args) $andx] 5 end] 810 foreach mech [SASL::mechanisms] { 811 if {[lsearch -exact $mechs $mech] == -1} { continue } 812 if {[catch { 813 Authenticate $token $mech 814 } msg]} { 815 if {$options(-debug)} { 816 puts stderr "AUTH $mech failed: $msg " 817 flush stderr 818 } 819 } 820 if {[info exists state(auth)] && $state(auth)} { 821 if {$state(auth) == 1} { 822 break 823 } else { 824 # After successful AUTH we are supposed to redo 825 # our connection for mechanisms that setup a new 826 # security layer -- these should set state(auth) 827 # greater than 1 828 fileevent $state(sd) readable \ 829 [list ::smtp::readable $token] 830 return [initialize_ehlo $token] 831 } 832 } 833 } 834 } 835 836 return $token 837 } else { 838 # Bad response; close the connection and hope the next server 839 # is happier. 840 catch {close $state(sd)} 841 } 842 return {} 843} 844 845proc ::smtp::SASLCallback {token context command args} { 846 upvar #0 $token state 847 upvar #0 $context ctx 848 array set options $state(options) 849 switch -exact -- $command { 850 login { return "" } 851 username { return $options(-username) } 852 password { return $options(-password) } 853 hostname { return [info host] } 854 realm { 855 if {[string equal $ctx(mech) "NTLM"] \ 856 && [info exists ::env(USERDOMAIN)]} { 857 return $::env(USERDOMAIN) 858 } else { 859 return "" 860 } 861 } 862 default { 863 return -code error "error: unsupported SASL information requested" 864 } 865 } 866} 867 868proc ::smtp::Authenticate {token mechanism} { 869 upvar 0 $token state 870 package require base64 871 set ctx [SASL::new -mechanism $mechanism \ 872 -callback [list [namespace origin SASLCallback] $token]] 873 874 set state(auth) 0 875 set result [smtp::talk $token 300 "AUTH $mechanism"] 876 array set response $result 877 878 while {$response(code) == 334} { 879 # The NTLM initial response is not base64 encoded so handle it. 880 if {[catch {base64::decode $response(diagnostic)} challenge]} { 881 set challenge $response(diagnostic) 882 } 883 SASL::step $ctx $challenge 884 set result [smtp::talk $token 300 \ 885 [base64::encode -maxlen 0 [SASL::response $ctx]]] 886 array set response $result 887 } 888 889 if {$response(code) == 235} { 890 set state(auth) 1 891 return $result 892 } else { 893 return -code 7 $result 894 } 895} 896 897# ::smtp::finalize -- 898# 899# Deletes an SMTP token by closing the connection to the SMTP server, 900# cleanup up various state. 901# 902# Arguments: 903# token SMTP token that has an open connection to the SMTP server. 904# args Optional arguments, where the only useful option is -close, 905# whose valid values are the following: 906# orderly Normal successful completion. Close connection and 907# clear state variables. 908# abort A connection exists to the SMTP server, but it's in 909# a weird state and needs to be reset before being 910# closed. Then clear state variables. 911# drop No connection exists, so we just need to clean up 912# state variables. 913# 914# Results: 915# SMTP connection is closed and state variables are cleared. If there's 916# an error while attempting to close the connection to the SMTP server, 917# throw an exception with the error code and error message. 918 919proc ::smtp::finalize {token args} { 920 global errorCode errorInfo 921 # FRINK: nocheck 922 variable $token 923 upvar 0 $token state 924 925 array set options [list -close orderly] 926 array set options $args 927 928 switch -- $options(-close) { 929 orderly { 930 set code [catch { talk $token 120 QUIT } result] 931 } 932 933 abort { 934 set code [catch { 935 talk $token 0 RSET 936 talk $token 0 QUIT 937 } result] 938 } 939 940 drop { 941 set code 0 942 set result "" 943 } 944 945 default { 946 error "unknown value for -close $options(-close)" 947 } 948 } 949 set ecode $errorCode 950 set einfo $errorInfo 951 952 catch { close $state(sd) } 953 954 if {$state(afterID) != ""} { 955 catch { after cancel $state(afterID) } 956 } 957 958 foreach name [array names state] { 959 unset state($name) 960 } 961 # FRINK: nocheck 962 unset $token 963 964 return -code $code -errorinfo $einfo -errorcode $ecode $result 965} 966 967# ::smtp::winit -- 968# 969# Send originator info to SMTP server. This occurs after HELO/EHLO 970# command has completed successfully (in ::smtp::initialize). This function 971# is called by ::smtp::sendmessageaux. 972# 973# Arguments: 974# token SMTP token that has an open connection to the SMTP server. 975# part MIME token for the message to be sent. May be used for 976# handling some SMTP extensions. 977# originator The e-mail address of the entity sending the message, 978# usually the From clause. 979# mode SMTP command specifying the mode of communication. Default 980# value is MAIL. 981# 982# Results: 983# Originator info is sent and SMTP server's response is returned. If an 984# error occurs, throw an exception. 985 986proc ::smtp::winit {token part originator {mode MAIL}} { 987 # FRINK: nocheck 988 variable $token 989 upvar 0 $token state 990 991 if {[lsearch -exact [list MAIL SEND SOML SAML] $mode] < 0} { 992 error "unknown origination mode $mode" 993 } 994 995 set from "$mode FROM:<$originator>" 996 997 # RFC 1870 - SMTP Service Extension for Message Size Declaration 998 if {[info exists state(esmtp)] 999 && [lsearch -glob $state(esmtp) "SIZE*"] != -1} { 1000 catch { 1001 set size [string length [mime::buildmessage $part]] 1002 append from " SIZE=$size" 1003 } 1004 } 1005 1006 array set response [set result [talk $token 600 $from]] 1007 1008 if {$response(code) == 250} { 1009 set state(addrs) 0 1010 return $result 1011 } else { 1012 return -code 7 $result 1013 } 1014} 1015 1016# ::smtp::waddr -- 1017# 1018# Send recipient info to SMTP server. This occurs after originator info 1019# is sent (in ::smtp::winit). This function is called by 1020# ::smtp::sendmessageaux. 1021# 1022# Arguments: 1023# token SMTP token that has an open connection to the SMTP server. 1024# recipient One of the recipients to whom the message should be 1025# delivered. 1026# 1027# Results: 1028# Recipient info is sent and SMTP server's response is returned. If an 1029# error occurs, throw an exception. 1030 1031proc ::smtp::waddr {token recipient} { 1032 # FRINK: nocheck 1033 variable $token 1034 upvar 0 $token state 1035 1036 set result [talk $token 3600 "RCPT TO:<$recipient>"] 1037 array set response $result 1038 1039 switch -- $response(code) { 1040 250 - 251 { 1041 incr state(addrs) 1042 return $result 1043 } 1044 1045 default { 1046 return -code 7 $result 1047 } 1048 } 1049} 1050 1051# ::smtp::wtext -- 1052# 1053# Send message to SMTP server. This occurs after recipient info 1054# is sent (in ::smtp::winit). This function is called by 1055# ::smtp::sendmessageaux. 1056# 1057# Arguments: 1058# token SMTP token that has an open connection to the SMTP server. 1059# part The MIME object containing the message to send. 1060# 1061# Results: 1062# MIME message is sent and SMTP server's response is returned. If an 1063# error occurs, throw an exception. 1064 1065proc ::smtp::wtext {token part} { 1066 # FRINK: nocheck 1067 variable $token 1068 upvar 0 $token state 1069 array set options $state(options) 1070 1071 set result [talk $token 300 DATA] 1072 array set response $result 1073 if {$response(code) != 354} { 1074 return -code 7 $result 1075 } 1076 1077 if {[catch { wtextaux $token $part } result]} { 1078 catch { puts -nonewline $state(sd) "\r\n.\r\n" ; flush $state(sd) } 1079 return -code 7 [list code 400 diagnostic $result] 1080 } 1081 1082 set secs $options(-maxsecs) 1083 1084 set result [talk $token $secs .] 1085 array set response $result 1086 switch -- $response(code) { 1087 250 - 251 { 1088 return $result 1089 } 1090 1091 default { 1092 return -code 7 $result 1093 } 1094 } 1095} 1096 1097# ::smtp::wtextaux -- 1098# 1099# Helper function that coordinates writing the MIME message to the socket. 1100# In particular, it stacks the channel leading to the SMTP server, sets up 1101# some file events, sends the message, unstacks the channel, resets the 1102# file events to their original state, and returns. 1103# 1104# Arguments: 1105# token SMTP token that has an open connection to the SMTP server. 1106# part The MIME object containing the message to send. 1107# 1108# Results: 1109# Message is sent. If anything goes wrong, throw an exception. 1110 1111proc ::smtp::wtextaux {token part} { 1112 global errorCode errorInfo 1113 1114 # FRINK: nocheck 1115 variable $token 1116 upvar 0 $token state 1117 1118 # Workaround a bug with stacking channels on top of TLS. 1119 # FRINK: nocheck 1120 set trf [set [namespace current]::trf] 1121 if {[info exists state(tls)] && $state(tls)} { 1122 set trf 0 1123 } 1124 1125 flush $state(sd) 1126 fileevent $state(sd) readable "" 1127 if {$trf} { 1128 transform -attach $state(sd) -command [list ::smtp::wdata $token] 1129 } else { 1130 set state(size) 1 1131 } 1132 fileevent $state(sd) readable [list ::smtp::readable $token] 1133 1134 # If trf is not available, get the contents of the message, 1135 # replace all '.'s that start their own line with '..'s, and 1136 # then write the mime body out to the filehandle. Do not forget to 1137 # deal with bare LF's here too (SF bug #499242). 1138 1139 if {$trf} { 1140 set code [catch { ::mime::copymessage $part $state(sd) } result] 1141 } else { 1142 set code [catch { ::mime::buildmessage $part } result] 1143 if {$code == 0} { 1144 # Detect and transform bare LF's into proper CR/LF 1145 # sequences. 1146 1147 while {[regsub -all -- {([^\r])\n} $result "\\1\r\n" result]} {} 1148 regsub -all -- {\n\.} $result "\n.." result 1149 1150 # Fix for bug #827436 - mail data must end with CRLF.CRLF 1151 if {[string compare [string index $result end] "\n"] != 0} { 1152 append result "\r\n" 1153 } 1154 set state(size) [string length $result] 1155 puts -nonewline $state(sd) $result 1156 set result "" 1157 } 1158 } 1159 set ecode $errorCode 1160 set einfo $errorInfo 1161 1162 flush $state(sd) 1163 fileevent $state(sd) readable "" 1164 if {$trf} { 1165 unstack $state(sd) 1166 } 1167 fileevent $state(sd) readable [list ::smtp::readable $token] 1168 1169 return -code $code -errorinfo $einfo -errorcode $ecode $result 1170} 1171 1172# ::smtp::wdata -- 1173# 1174# This is the custom transform using Trf to do CR/LF translation. If Trf 1175# is not installed on the system, then this function never gets called and 1176# no translation occurs. 1177# 1178# Arguments: 1179# token SMTP token that has an open connection to the SMTP server. 1180# command Trf provided command for manipulating socket data. 1181# buffer Data to be converted. 1182# 1183# Results: 1184# buffer is translated, and state(size) is set. If Trf is not installed 1185# on the system, the transform proc defined at the top of this file sets 1186# state(size) to 1. state(size) is used later to determine a timeout 1187# value. 1188 1189proc ::smtp::wdata {token command buffer} { 1190 # FRINK: nocheck 1191 variable $token 1192 upvar 0 $token state 1193 1194 switch -- $command { 1195 create/write - 1196 clear/write - 1197 delete/write { 1198 set state(crP) 0 1199 set state(nlP) 1 1200 set state(size) 0 1201 } 1202 1203 write { 1204 set result "" 1205 1206 foreach c [split $buffer ""] { 1207 switch -- $c { 1208 "." { 1209 if {$state(nlP)} { 1210 append result . 1211 } 1212 set state(crP) 0 1213 set state(nlP) 0 1214 } 1215 1216 "\r" { 1217 set state(crP) 1 1218 set state(nlP) 0 1219 } 1220 1221 "\n" { 1222 if {!$state(crP)} { 1223 append result "\r" 1224 } 1225 set state(crP) 0 1226 set state(nlP) 1 1227 } 1228 1229 default { 1230 set state(crP) 0 1231 set state(nlP) 0 1232 } 1233 } 1234 1235 append result $c 1236 } 1237 1238 incr state(size) [string length $result] 1239 return $result 1240 } 1241 1242 flush/write { 1243 set result "" 1244 1245 if {!$state(nlP)} { 1246 if {!$state(crP)} { 1247 append result "\r" 1248 } 1249 append result "\n" 1250 } 1251 1252 incr state(size) [string length $result] 1253 return $result 1254 } 1255 1256 create/read - 1257 delete/read { 1258 # Bugfix for [#539952] 1259 } 1260 1261 query/ratio { 1262 # Indicator for unseekable channel, 1263 # for versions of Trf which ask for 1264 # this. 1265 return {0 0} 1266 } 1267 query/maxRead { 1268 # No limits on reading bytes from the channel below, for 1269 # versions of Trf which ask for this information 1270 return -1 1271 } 1272 1273 default { 1274 # Silently pass all unknown commands. 1275 #error "Unknown command \"$command\"" 1276 } 1277 } 1278 1279 return "" 1280} 1281 1282# ::smtp::talk -- 1283# 1284# Sends an SMTP command to a server 1285# 1286# Arguments: 1287# token SMTP token that has an open connection to the SMTP server. 1288# secs Timeout after which command should be aborted. 1289# command Command to send to SMTP server. 1290# 1291# Results: 1292# command is sent and response is returned. If anything goes wrong, throw 1293# an exception. 1294 1295proc ::smtp::talk {token secs command} { 1296 # FRINK: nocheck 1297 variable $token 1298 upvar 0 $token state 1299 1300 array set options $state(options) 1301 1302 if {$options(-debug)} { 1303 puts stderr "--> $command (wait upto $secs seconds)" 1304 flush stderr 1305 } 1306 1307 if {[catch { puts -nonewline $state(sd) "$command\r\n" 1308 flush $state(sd) } result]} { 1309 return [list code 400 diagnostic $result] 1310 } 1311 1312 if {$secs == 0} { 1313 return "" 1314 } 1315 1316 return [hear $token $secs] 1317} 1318 1319# ::smtp::hear -- 1320# 1321# Listens for SMTP server's response to some prior command. 1322# 1323# Arguments: 1324# token SMTP token that has an open connection to the SMTP server. 1325# secs Timeout after which we should stop waiting for a response. 1326# 1327# Results: 1328# Response is returned. 1329 1330proc ::smtp::hear {token secs} { 1331 # FRINK: nocheck 1332 variable $token 1333 upvar 0 $token state 1334 1335 array set options $state(options) 1336 1337 array set response [list args ""] 1338 1339 set firstP 1 1340 while {1} { 1341 if {$secs >= 0} { 1342 ## SF [ 836442 ] timeout with large data 1343 ## correction, aotto 031105 - 1344 if {$secs > 600} {set secs 600} 1345 set state(afterID) [after [expr {$secs*1000}] \ 1346 [list ::smtp::timer $token]] 1347 } 1348 1349 if {!$state(readable)} { 1350 vwait ${token}(readable) 1351 } 1352 1353 # Wait until socket is readable. 1354 if {$state(readable) != -1} { 1355 catch { after cancel $state(afterID) } 1356 set state(afterID) "" 1357 } 1358 1359 if {$state(readable) < 0} { 1360 array set response [list code 400 diagnostic $state(error)] 1361 break 1362 } 1363 set state(readable) 0 1364 1365 if {$options(-debug)} { 1366 puts stderr "<-- $state(line)" 1367 flush stderr 1368 } 1369 1370 if {[string length $state(line)] < 3} { 1371 array set response \ 1372 [list code 500 \ 1373 diagnostic "response too short: $state(line)"] 1374 break 1375 } 1376 1377 if {$firstP} { 1378 set firstP 0 1379 1380 if {[scan [string range $state(line) 0 2] %d response(code)] \ 1381 != 1} { 1382 array set response \ 1383 [list code 500 \ 1384 diagnostic "unrecognizable code: $state(line)"] 1385 break 1386 } 1387 1388 set response(diagnostic) \ 1389 [string trim [string range $state(line) 4 end]] 1390 } else { 1391 lappend response(args) \ 1392 [string trim [string range $state(line) 4 end]] 1393 } 1394 1395 # When status message line ends in -, it means the message is complete. 1396 1397 if {[string compare [string index $state(line) 3] -]} { 1398 break 1399 } 1400 } 1401 1402 return [array get response] 1403} 1404 1405# ::smtp::readable -- 1406# 1407# Reads a line of data from SMTP server when the socket is readable. This 1408# is the callback of "fileevent readable". 1409# 1410# Arguments: 1411# token SMTP token that has an open connection to the SMTP server. 1412# 1413# Results: 1414# state(line) contains the line of data and state(readable) is reset. 1415# state(readable) gets the following values: 1416# -3 if there's a premature eof, 1417# -2 if reading from socket fails. 1418# 1 if reading from socket was successful 1419 1420proc ::smtp::readable {token} { 1421 # FRINK: nocheck 1422 variable $token 1423 upvar 0 $token state 1424 1425 if {[catch { array set options $state(options) }]} { 1426 return 1427 } 1428 1429 set state(line) "" 1430 if {[catch { gets $state(sd) state(line) } result]} { 1431 set state(readable) -2 1432 set state(error) $result 1433 } elseif {$result == -1} { 1434 if {[eof $state(sd)]} { 1435 set state(readable) -3 1436 set state(error) "premature end-of-file from server" 1437 } 1438 } else { 1439 # If the line ends in \r, remove the \r. 1440 if {![string compare [string index $state(line) end] "\r"]} { 1441 set state(line) [string range $state(line) 0 end-1] 1442 } 1443 set state(readable) 1 1444 } 1445 1446 if {$state(readable) < 0} { 1447 if {$options(-debug)} { 1448 puts stderr " ... $state(error) ..." 1449 flush stderr 1450 } 1451 1452 catch { fileevent $state(sd) readable "" } 1453 } 1454} 1455 1456# ::smtp::timer -- 1457# 1458# Handles timeout condition on any communication with the SMTP server. 1459# 1460# Arguments: 1461# token SMTP token that has an open connection to the SMTP server. 1462# 1463# Results: 1464# Sets state(readable) to -1 and state(error) to an error message. 1465 1466proc ::smtp::timer {token} { 1467 # FRINK: nocheck 1468 variable $token 1469 upvar 0 $token state 1470 1471 array set options $state(options) 1472 1473 set state(afterID) "" 1474 set state(readable) -1 1475 set state(error) "read from server timed out" 1476 1477 if {$options(-debug)} { 1478 puts stderr " ... $state(error) ..." 1479 flush stderr 1480 } 1481} 1482 1483# ::smtp::boolean -- 1484# 1485# Helper function for unifying boolean values to 1 and 0. 1486# 1487# Arguments: 1488# value Some kind of value that represents true or false (i.e. 0, 1, 1489# false, true, no, yes, off, on). 1490# 1491# Results: 1492# Return 1 if the value is true, 0 if false. If the input value is not 1493# one of the above, throw an exception. 1494 1495proc ::smtp::boolean {value} { 1496 switch -- [string tolower $value] { 1497 0 - false - no - off { 1498 return 0 1499 } 1500 1501 1 - true - yes - on { 1502 return 1 1503 } 1504 1505 default { 1506 error "unknown boolean value: $value" 1507 } 1508 } 1509} 1510 1511# ------------------------------------------------------------------------- 1512 1513package provide smtp 1.5 1514 1515# ------------------------------------------------------------------------- 1516# Local variables: 1517# indent-tabs-mode: nil 1518# End: 1519