1# pop3d.tcl -- 2# 3# Implementation of a pop3 server for Tcl. 4# 5# Copyright (c) 2002-2009 by Andreas Kupries 6# Copyright (c) 2005 by Reinhard Max (-socket option) 7# 8# See the file "license.terms" for information on usage and redistribution 9# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 10# 11# RCS: @(#) $Id: pop3d.tcl,v 1.23 2009/04/14 20:35:43 andreas_kupries Exp $ 12 13package require md5 ; # tcllib | APOP 14package require mime ; # tcllib | storage callback 15package require log ; # tcllib | tracing 16 17namespace eval ::pop3d { 18 # Data storage in the pop3d module 19 # ------------------------------- 20 # 21 # There's a number of bits to keep track of for each server and 22 # connection managed by it. 23 # 24 # port 25 # callbacks 26 # connections 27 # connection state 28 # server state 29 # 30 # It would quickly become unwieldy to try to keep these in arrays or lists 31 # within the pop3d namespace itself. Instead, each pop3 server will 32 # get its own namespace. Each namespace contains: 33 # 34 # port - port to listen on 35 # sock - listening socket 36 # authCmd - authentication callback 37 # storCmd - storage callback 38 # sockCmd - command prefix for opening the server socket 39 # state - state of the server (up, down, exiting) 40 # conn - map : sock -> state array 41 # counter - counter for state arrays 42 # 43 # Per connection in a server its own state array 'connXXX'. 44 # 45 # id - unique id for the connection (APOP) 46 # state - state of connection (auth, trans, update, fail) 47 # name - user for that connection 48 # storage - storage ref for that user 49 # logon - authentication method (empty, apop, user) 50 # deleted - list of deleted messages 51 # msg - number of messages in storage 52 # remotehost - name of remote host for connection 53 # remoteport - remote port for connection 54 55 # counter is used to give a unique name for unnamed server 56 variable counter 0 57 58 # commands is the list of subcommands recognized by the server 59 variable commands [list \ 60 "cget" \ 61 "configure" \ 62 "destroy" \ 63 "down" \ 64 "up" \ 65 ] 66 67 variable version ; set version 1.1.0 68 variable server "tcllib/pop3d-$version" 69 70 variable cmdMap ; array set cmdMap { 71 CAPA H_capa 72 USER H_user 73 PASS H_pass 74 APOP H_apop 75 STAT H_stat 76 DELE H_dele 77 RETR H_retr 78 TOP H_top 79 QUIT H_quit 80 NOOP H_noop 81 RSET H_rset 82 LIST H_list 83 } 84 85 # Capabilities to be reported by the CAPA command. The list 86 # contains pairs of capability strings and the connection state in 87 # which they are reported. The state can be "auth", "trans", or 88 # "both". 89 variable capabilities \ 90 [list \ 91 USER both \ 92 PIPELINING both \ 93 "IMPLEMENTATION $server" trans \ 94 ] 95 96 # -- UIDL -- not implemented -- 97 98 # Only export one command, the one used to instantiate a new server 99 namespace export new 100} 101 102# ::pop3d::new -- 103# 104# Create a new pop3 server with a given name; if no name is given, use 105# pop3dX, where X is a number. 106# 107# Arguments: 108# name name of the pop3 server; if null, generate one. 109# 110# Results: 111# name name of the pop3 server created 112 113proc ::pop3d::new {{name ""}} { 114 variable counter 115 116 if { [llength [info level 0]] == 1 } { 117 incr counter 118 set name "pop3d${counter}" 119 } 120 121 if { ![string equal [info commands ::$name] ""] } { 122 return -code error "command \"$name\" already exists, unable to create pop3 server" 123 } 124 125 # Set up the namespace 126 namespace eval ::pop3d::pop3d::$name { 127 variable port 110 128 variable trueport 110 129 variable sock {} 130 variable sockCmd ::socket 131 variable authCmd {} 132 variable storCmd {} 133 variable state down 134 variable conn ; array set conn {} 135 variable counter 0 136 } 137 138 # Create the command to manipulate the pop3 server 139 interp alias {} ::$name {} ::pop3d::Pop3dProc $name 140 141 return $name 142} 143 144########################## 145# Private functions follow 146 147# ::pop3d::Pop3dProc -- 148# 149# Command that processes all pop3 server object commands. 150# 151# Arguments: 152# name name of the pop3 server object to manipulate. 153# args command name and args for the command 154# 155# Results: 156# Varies based on command to perform 157 158proc ::pop3d::Pop3dProc {name {cmd ""} args} { 159 # Do minimal args checks here 160 if { [llength [info level 0]] == 2 } { 161 return -code error "wrong # args: should be \"$name option ?arg arg ...?\"" 162 } 163 164 # Split the args into command and args components 165 if { [llength [info commands ::pop3d::_$cmd]] == 0 } { 166 variable commands 167 set optlist [join $commands ", "] 168 set optlist [linsert $optlist "end-1" "or"] 169 return -code error "bad option \"$cmd\": must be $optlist" 170 } 171 eval [list ::pop3d::_$cmd $name] $args 172} 173 174# ::pop3d::_up -- 175# 176# Start listening on the configured port. 177# 178# Arguments: 179# name name of the pop3 server. 180# 181# Results: 182# None. 183 184proc ::pop3d::_up {name} { 185 upvar ::pop3d::pop3d::${name}::port port 186 upvar ::pop3d::pop3d::${name}::trueport trueport 187 upvar ::pop3d::pop3d::${name}::state state 188 upvar ::pop3d::pop3d::${name}::sockCmd sockCmd 189 upvar ::pop3d::pop3d::${name}::sock sock 190 191 log::log debug "pop3d $name up" 192 if {[string equal $state up]} {return} 193 194 log::log debug "pop3d $name listening, requested port $port" 195 196 set cmd $sockCmd 197 lappend cmd -server [list ::pop3d::HandleNewConnection $name] $port 198 #puts $cmd 199 set s [eval $cmd] 200 set trueport [lindex [fconfigure $s -sockname] 2] 201 202 ::log::log debug "pop3d $name listening on $trueport, socket $s ([fconfigure $s -sockname])" 203 204 set state up 205 set sock $s 206 return 207} 208 209# ::pop3d::_down -- 210# 211# Stop listening on the configured port. 212# 213# Arguments: 214# name name of the pop3 server. 215# 216# Results: 217# None. 218 219proc ::pop3d::_down {name} { 220 upvar ::pop3d::pop3d::${name}::state state 221 upvar ::pop3d::pop3d::${name}::sock sock 222 upvar ::pop3d::pop3d::${name}::trueport trueport 223 upvar ::pop3d::pop3d::${name}::port port 224 225 # Ignore if server is down or exiting 226 if {![string equal $state up]} {return} 227 228 close $sock 229 set state down 230 set sock {} 231 232 set trueport $port 233 return 234} 235 236# ::pop3d::_destroy -- 237# 238# Destroy a pop3 server. 239# 240# Arguments: 241# name name of the pop3 server. 242# mode destruction mode 243# 244# Results: 245# None. 246 247proc ::pop3d::_destroy {name {mode kill}} { 248 upvar ::pop3d::pop3d::${name}::conn conn 249 250 switch -exact -- $mode { 251 kill { 252 _down $name 253 foreach c [array names conn] { 254 CloseConnection $name $c 255 } 256 257 namespace delete ::pop3d::pop3d::$name 258 interp alias {} ::$name {} 259 } 260 defer { 261 if {[array size conn] > 0} { 262 upvar ::pop3d::pop3d::${name}::state state 263 264 _down $name 265 set state exiting 266 return 267 } 268 _destroy $name kill 269 return 270 } 271 default { 272 return -code error \ 273 "Illegal destruction mode \"$mode\":\ 274 Expected \"kill\", or \"defer\"" 275 } 276 } 277 return 278} 279 280# ::pop3d::_cget -- 281# 282# Query option value 283# 284# Arguments: 285# name name of the pop3 server. 286# 287# Results: 288# None. 289 290proc ::pop3d::_cget {name anoption} { 291 switch -exact -- $anoption { 292 -state { 293 upvar ::pop3d::pop3d::${name}::state state 294 return $state 295 } 296 -port { 297 upvar ::pop3d::pop3d::${name}::trueport trueport 298 return $trueport 299 } 300 -auth { 301 upvar ::pop3d::pop3d::${name}::authCmd authCmd 302 return $authCmd 303 } 304 -storage { 305 upvar ::pop3d::pop3d::${name}::storCmd storCmd 306 return $storCmd 307 } 308 -socket { 309 upvar ::pop3d::pop3d::${name}::sockCmd sockCmd 310 return $sockCmd 311 } 312 default { 313 return -code error \ 314 "Unknown option \"$anoption\":\ 315 Expected \"-state\", \"-port\", \"-auth\", \"-socket\", or \"-storage\"" 316 } 317 } 318 # return - in all branches 319} 320 321# ::pop3d::_configure -- 322# 323# Query and set option values 324# 325# Arguments: 326# name name of the pop3 server. 327# args options and option values 328# 329# Results: 330# None. 331 332proc ::pop3d::_configure {name args} { 333 set argc [llength $args] 334 if {($argc > 1) && (($argc % 2) == 1)} { 335 return -code error \ 336 "wrong # args, expected: -option | (-option value)..." 337 } 338 if {$argc == 1} { 339 return [_cget $name [lindex $args 0]] 340 } 341 342 upvar ::pop3d::pop3d::${name}::trueport trueport 343 upvar ::pop3d::pop3d::${name}::port port 344 upvar ::pop3d::pop3d::${name}::authCmd authCmd 345 upvar ::pop3d::pop3d::${name}::storCmd storCmd 346 upvar ::pop3d::pop3d::${name}::sockCmd sockCmd 347 upvar ::pop3d::pop3d::${name}::state state 348 349 if {$argc == 0} { 350 # Return the full configuration. 351 return [list \ 352 -port $trueport \ 353 -auth $authCmd \ 354 -storage $storCmd \ 355 -socket $sockCmd \ 356 -state $state \ 357 ] 358 } 359 360 while {[llength $args] > 0} { 361 set option [lindex $args 0] 362 set value [lindex $args 1] 363 switch -exact -- $option { 364 -auth {set authCmd $value} 365 -storage {set storCmd $value} 366 -socket {set sockCmd $value} 367 -port { 368 set port $value 369 370 # Propagate to the queried value if the server is down 371 # and thus has no real true port. 372 373 if {[string equal $state down]} { 374 set trueport $value 375 } 376 } 377 -state { 378 return -code error "Option -state is read-only" 379 } 380 default { 381 return -code error \ 382 "Unknown option \"$option\":\ 383 Expected \"-port\", \"-auth\", \"-socket\", or \"-storage\"" 384 } 385 } 386 set args [lrange $args 2 end] 387 } 388 return "" 389} 390 391 392# ::pop3d::_conn -- 393# 394# Query connection state. 395# 396# Arguments: 397# name name of the pop3 server. 398# cmd subcommand to perform 399# args arguments for subcommand 400# 401# Results: 402# Specific to subcommand 403 404proc ::pop3d::_conn {name cmd args} { 405 upvar ::pop3d::pop3d::${name}::conn conn 406 switch -exact -- $cmd { 407 list { 408 if {[llength $args] > 0} { 409 return -code error "wrong # args: should be \"$name conn list\"" 410 } 411 return [array names conn] 412 } 413 state { 414 if {[llength $args] != 1} { 415 return -code error "wrong # args: should be \"$name conn state connId\"" 416 } 417 set sock [lindex $args 0] 418 upvar $conn($sock) cstate 419 return [array get cstate] 420 } 421 default { 422 return -code error "bad option \"$cmd\": must be list, or state" 423 } 424 } 425} 426 427########################## 428########################## 429# Server implementation. 430 431proc ::pop3d::HandleNewConnection {name sock rHost rPort} { 432 upvar ::pop3d::pop3d::${name}::conn conn 433 upvar ::pop3d::pop3d::${name}::counter counter 434 435 set csa ::pop3d::pop3d::${name}::conn[incr counter] 436 set conn($sock) $csa 437 upvar $csa cstate 438 439 set cstate(remotehost) $rHost 440 set cstate(remoteport) $rPort 441 set cstate(server) $name 442 set cstate(id) "<[string map {- {}} [clock clicks]]_${name}_[pid]@[::info hostname]>" 443 set cstate(state) "auth" 444 set cstate(name) "" 445 set cstate(logon) "" 446 set cstate(storage) "" 447 set cstate(deleted) "" 448 set cstate(msg) 0 449 set cstate(size) 0 450 451 ::log::log notice "pop3d $name $sock state auth, waiting for logon" 452 453 fconfigure $sock -buffering line -translation crlf -blocking 0 454 455 if {[catch {::pop3d::GreetPeer $name $sock} errmsg]} { 456 close $sock 457 log::log error "pop3d $name $sock greeting $errmsg" 458 unset cstate 459 unset conn($sock) 460 return 461 } 462 463 fileevent $sock readable [list ::pop3d::HandleCommand $name $sock] 464 return 465} 466 467proc ::pop3d::CloseConnection {name sock} { 468 upvar ::pop3d::pop3d::${name}::storCmd storCmd 469 upvar ::pop3d::pop3d::${name}::state state 470 upvar ::pop3d::pop3d::${name}::conn conn 471 472 upvar $conn($sock) cstate 473 474 # Kill a pending idle event for CloseConnection, we are closing now. 475 catch {after cancel $cstate(idlepending)} 476 477 ::log::log debug "pop3d $name $sock closing connection" 478 479 if {[catch {close $sock} msg]} { 480 ::log::log error "pop3d $name $sock close: $msg" 481 } 482 if {$storCmd != {}} { 483 # remove possible lock set in storage facility. 484 if {[catch { 485 uplevel #0 [linsert $storCmd end unlock $cstate(storage)] 486 } msg]} { 487 ::log::log error "pop3d $name $sock storage unlock: $msg" 488 # -W- future ? kill all connections, execute clean up of storage 489 # -W- facility. 490 } 491 } 492 493 unset cstate 494 unset conn($sock) 495 496 ::log::log notice "pop3d $name $sock closed" 497 498 if {[string equal $state existing] && ([array size conn] == 0)} { 499 _destroy $name 500 } 501 return 502} 503 504proc ::pop3d::HandleCommand {name sock} { 505 # @c Called by the event system after arrival of a new command for 506 # @c connection. 507 508 # @a sock: Direct access to the channel representing the connection. 509 510 # Client closed connection, bye bye 511 if {[eof $sock]} { 512 CloseConnection $name $sock 513 return 514 } 515 516 # line was incomplete, wait for more 517 if {[gets $sock line] < 0} { 518 return 519 } 520 521 upvar ::pop3d::pop3d::${name}::conn conn 522 upvar $conn($sock) cstate 523 variable cmdMap 524 525 ::log::log info "pop3d $name $sock < $line" 526 527 set fail [catch { 528 set cmd [string toupper [lindex $line 0]] 529 530 if {![::info exists cmdMap($cmd)]} { 531 # unknown command, use unknown handler 532 533 HandleUnknownCmd $name $sock $cmd $line 534 } else { 535 $cmdMap($cmd) $name $sock $cmd $line 536 } 537 } errmsg] ;#{} 538 539 if {$fail} { 540 # Had an error during handling of 'cmd'. 541 # Handled by closing the connection. 542 # (We do not know how to relay the internal error to the client) 543 544 ::log::log error "pop3d $name $sock $cmd: $errmsg" 545 CloseConnection $name $sock 546 } 547 return 548} 549 550proc ::pop3d::GreetPeer {name sock} { 551 # @c Called after the initialization of a new connection. Writes the 552 # @c greeting to the new client. Overides the baseclass definition 553 # @c (<m server:GreetPeer>). 554 # 555 # @a conn: Descriptor of connection to write to. 556 557 upvar cstate cstate 558 variable server 559 560 log::log debug "pop3d $name $sock _ Greeting" 561 562 Respond2Client $name $sock +OK \ 563 "[::info hostname] $server ready $cstate(id)" 564 return 565} 566 567proc ::pop3d::HandleUnknownCmd {name sock cmd line} { 568 Respond2Client $name $sock -ERR "unknown command '$cmd'" 569 return 570} 571 572proc ::pop3d::Respond2Client {name sock ok wtext} { 573 ::log::log info "pop3d $name $sock > $ok $wtext" 574 puts $sock "$ok $wtext" 575 return 576} 577 578########################## 579########################## 580# Command implementations. 581 582proc ::pop3d::H_capa {name sock cmd line} { 583 # @c Handle CAPA command. 584 585 # Capabilities should better be configurable and handled per 586 # server object, so that e.g. USER/PASS authentication can be 587 # turned off. 588 589 upvar cstate cstate 590 variable capabilities 591 592 Respond2Client $name $sock +OK "Capability list follows" 593 foreach {capability state} $capabilities { 594 if { 595 [string equal $state "both"] || 596 [string equal $state $cstate(state)] 597 } { 598 puts $sock $capability 599 } 600 } 601 puts $sock . 602 return 603} 604 605proc ::pop3d::H_user {name sock cmd line} { 606 # @c Handle USER command. 607 # 608 # @a conn: Descriptor of connection to write to. 609 # @a cmd: The sent command 610 # @a line: The sent line, with <a cmd> as first word. 611 612 # Called only in places where cstate is known! 613 upvar cstate cstate 614 615 if {[string equal $cstate(logon) apop]} { 616 Respond2Client $name $sock -ERR "login mechanism APOP was chosen" 617 } elseif {[string equal $cstate(state) trans]} { 618 Respond2Client $name $sock -ERR "client already authenticated" 619 } else { 620 # The user name is the first argument to the command 621 622 set cstate(name) [lindex [split $line] 1] 623 set cstate(logon) user 624 625 Respond2Client $name $sock +OK "please send PASS command" 626 } 627 return 628} 629 630 631proc ::pop3d::H_pass {name sock cmd line} { 632 # @c Handle PASS command. 633 # 634 # @a conn: Descriptor of connection to write to. 635 # @a cmd: The sent command 636 # @a line: The sent line, with <a cmd> as first word. 637 638 # Called only in places where cstate is known! 639 upvar cstate cstate 640 641 if {[string equal $cstate(logon) apop]} { 642 Respond2Client $name $sock -ERR "login mechanism APOP was chosen" 643 } elseif {[string equal $cstate(state) trans]} { 644 Respond2Client $name $sock -ERR "client already authenticated" 645 } else { 646 upvar ::pop3d::pop3d::${name}::authCmd authCmd 647 648 if {$authCmd == {}} { 649 # No authentication is possible. Reject all users. 650 CheckLogin $name $sock "" "" "" 651 return 652 } 653 654 # The password is given as the first argument of the command 655 656 set pwd [lindex [split $line] 1] 657 658 if {![uplevel #0 [linsert $authCmd end exists $cstate(name)]]} { 659 ::log::log warning "pop3d $name $sock $authCmd lookup $cstate(name) : user does not exist" 660 CheckLogin $name $sock "" "" "" 661 return 662 } 663 if {[catch { 664 set info [uplevel #0 [linsert $authCmd end lookup $cstate(name)]] 665 } msg]} { 666 ::log::log error "pop3d $name $sock $authCmd lookup $cstate(name) : $msg" 667 CheckLogin $name $sock "" "" "" 668 return 669 } 670 CheckLogin $name $sock $pwd [lindex $info 0] [lindex $info 1] 671 } 672 return 673} 674 675 676proc ::pop3d::H_apop {name sock cmd line} { 677 # @c Handle APOP command. 678 # 679 # @a conn: Descriptor of connection to write to. 680 # @a cmd: The sent command 681 # @a line: The sent line, with <a cmd> as first word. 682 683 # Called only in places where cstate is known! 684 upvar cstate cstate 685 686 if {[string equal $cstate(logon) user]} { 687 Respond2Client $name $sock -ERR "login mechanism USER/PASS was chosen" 688 return 689 } elseif {[string equal $cstate(state) trans]} { 690 Respond2Client $name $sock -ERR "client already authenticated" 691 return 692 } 693 694 # The first two arguments to the command are user name and its 695 # response to the challenge set by the server. 696 697 set cstate(name) [lindex $line 1] 698 set cstate(logon) apop 699 700 upvar ::pop3d::pop3d::${name}::authCmd authCmd 701 702 #log::log debug "authCmd|$authCmd|" 703 704 if {$authCmd == {}} { 705 # No authentication is possible. Reject all users. 706 CheckLogin $name $sock "" "" "" 707 return 708 } 709 710 set digest [lindex $line 2] 711 712 if {![uplevel #0 [linsert $authCmd end exists $cstate(name)]]} { 713 ::log::log warning "pop3d $name $sock $authCmd lookup $cstate(name) : user does not exist" 714 CheckLogin $name $sock "" "" "" 715 return 716 } 717 if {[catch { 718 set info [uplevel #0 [linsert $authCmd end lookup $cstate(name)]] 719 } msg]} { 720 ::log::log error "pop3d $name $sock $authCmd lookup $cstate(name) : $msg" 721 CheckLogin $name $sock "" "" "" 722 return 723 } 724 725 set pwd [lindex $info 0] 726 set storage [lindex $info 1] 727 728 ::log::log debug "pop3d $name $sock info = <$info>" 729 730 if {$storage == {}} { 731 # user does not exist, skip over digest computation 732 CheckLogin $name $sock "" "" $storage 733 return 734 } 735 736 # Do the same algorithm as the client to generate a digest, then 737 # compare our data with information sent by the client. As we are 738 # using tcl 8.x there is need to use channels, an immediate 739 # computation is possible. 740 741 set ourDigest [Md5 "$cstate(id)$pwd"] 742 743 ::log::log debug "pop3d $name $sock digest input <$cstate(id)$pwd>" 744 ::log::log debug "pop3d $name $sock digest outpt <$ourDigest>" 745 ::log::log debug "pop3d $name $sock digest given <$digest>" 746 747 CheckLogin $name $sock $digest $ourDigest $storage 748 return 749} 750 751 752proc ::pop3d::H_stat {name sock cmd line} { 753 # @c Handle STAT command. 754 # 755 # @a conn: Descriptor of connection to write to. 756 # @a cmd: The sent command 757 # @a line: The sent line, with <a cmd> as first word. 758 759 # Called only in places where cstate is known! 760 upvar cstate cstate 761 762 if {[string equal $cstate(state) auth]} { 763 Respond2Client $name $sock -ERR "client not authenticated" 764 } else { 765 # Return number of messages waiting and size of the contents 766 # of the chosen maildrop in octects. 767 Respond2Client $name $sock +OK "$cstate(msg) $cstate(size)" 768 } 769 770 return 771} 772 773 774proc ::pop3d::H_dele {name sock cmd line} { 775 # @c Handle DELE command. 776 # 777 # @a conn: Descriptor of connection to write to. 778 # @a cmd: The sent command 779 # @a line: The sent line, with <a cmd> as first word. 780 781 # Called only in places where cstate is known! 782 upvar cstate cstate 783 784 if {[string equal $cstate(state) auth]} { 785 Respond2Client $name $sock -ERR "client not authenticated" 786 return 787 } 788 789 set msgid [lindex $line 1] 790 791 if { 792 ($msgid < 1) || 793 ($msgid > $cstate(msg)) || 794 ([lsearch $msgid $cstate(deleted)] >= 0) 795 } { 796 Respond2Client $name $sock -ERR "no such message" 797 } else { 798 lappend cstate(deleted) $msgid 799 Respond2Client $name $sock +OK "message $msgid deleted" 800 } 801 return 802} 803 804 805proc ::pop3d::H_retr {name sock cmd line} { 806 # @c Handle RETR command. 807 # 808 # @a conn: Descriptor of connection to write to. 809 # @a cmd: The sent command 810 # @a line: The sent line, with <a cmd> as first word. 811 812 # Called only in places where cstate is known! 813 upvar cstate cstate 814 815 if {[string equal $cstate(state) auth]} { 816 Respond2Client $name $sock -ERR "client not authenticated" 817 return 818 } 819 820 set msgid [lindex $line 1] 821 822 if { 823 ($msgid > $cstate(msg)) || 824 ([lsearch $msgid $cstate(deleted)] >= 0) 825 } { 826 Respond2Client $name $sock -ERR "no such message" 827 } else { 828 Transfer $name $sock $msgid 829 } 830 return 831} 832 833 834proc ::pop3d::H_top {name sock cmd line} { 835 # @c Handle RETR command. 836 # 837 # @a conn: Descriptor of connection to write to. 838 # @a cmd: The sent command 839 # @a line: The sent line, with <a cmd> as first word. 840 841 # Called only in places where cstate is known! 842 upvar cstate cstate 843 844 if {[string equal $cstate(state) auth]} { 845 Respond2Client $name $sock -ERR "client not authenticated" 846 return 847 } 848 849 set msgid [lindex $line 1] 850 set nlines [lindex $line 2] 851 852 if { 853 ($msgid > $cstate(msg)) || 854 ([lsearch $msgid $cstate(deleted)] >= 0) 855 } { 856 Respond2Client $name $sock -ERR "no such message" 857 } elseif {$nlines == {}} { 858 Respond2Client $name $sock -ERR "missing argument: #lines to read" 859 } elseif {$nlines < 0} { 860 Respond2Client $name $sock -ERR \ 861 "number of lines has to be greater than or equal to zero." 862 } elseif {$nlines == 0} { 863 # nlines == 0, no limit, same as H_retr 864 Transfer $name $sock $msgid 865 } else { 866 # nlines > 0 867 Transfer $name $sock $msgid $nlines 868 } 869 return 870} 871 872 873proc ::pop3d::H_quit {name sock cmd line} { 874 # @c Handle QUIT command. 875 # 876 # @a conn: Descriptor of connection to write to. 877 # @a cmd: The sent command 878 # @a line: The sent line, with <a cmd> as first word. 879 880 # Called only in places where cstate is known! 881 upvar cstate cstate 882 variable server 883 884 set cstate(state) update 885 886 if {$cstate(deleted) != {}} { 887 upvar ::pop3d::pop3d::${name}::storCmd storCmd 888 if {$storCmd != {}} { 889 uplevel #0 [linsert $storCmd end \ 890 dele $cstate(storage) $cstate(deleted)] 891 } 892 } 893 894 set cstate(idlepending) [after idle [list ::pop3d::CloseConnection $name $sock]] 895 896 Respond2Client $name $sock +OK \ 897 "[::info hostname] $server shutting down" 898 return 899} 900 901 902proc ::pop3d::H_noop {name sock cmd line} { 903 # @c Handle NOOP command. 904 # 905 # @a conn: Descriptor of connection to write to. 906 # @a cmd: The sent command 907 # @a line: The sent line, with <a cmd> as first word. 908 909 # Called only in places where cstate is known! 910 upvar cstate cstate 911 912 if {[string equal $cstate(state) fail]} { 913 Respond2Client $name $sock -ERR "login failed, no actions possible" 914 } elseif {[string equal $cstate(state) auth]} { 915 Respond2Client $name $sock -ERR "client not authenticated" 916 } else { 917 Respond2Client $name $sock +OK "" 918 } 919 return 920} 921 922 923proc ::pop3d::H_rset {name sock cmd line} { 924 # @c Handle RSET command. 925 # 926 # @a conn: Descriptor of connection to write to. 927 # @a cmd: The sent command 928 # @a line: The sent line, with <a cmd> as first word. 929 930 # Called only in places where cstate is known! 931 upvar cstate cstate 932 933 if {[string equal $cstate(state) fail]} { 934 Respond2Client $name $sock -ERR "login failed, no actions possible" 935 } elseif {[string equal $cstate(state) auth]} { 936 Respond2Client $name $sock -ERR "client not authenticated" 937 } else { 938 set cstate(deleted) "" 939 940 Respond2Client $name $sock +OK "$cstate(msg) messages waiting" 941 } 942 return 943} 944 945 946proc ::pop3d::H_list {name sock cmd line} { 947 # @c Handle LIST command. Generates scan listing 948 # 949 # @a conn: Descriptor of connection to write to. 950 # @a cmd: The sent command 951 # @a line: The sent line, with <a cmd> as first word. 952 953 # Called only in places where cstate is known! 954 upvar cstate cstate 955 956 if {[string equal $cstate(state) fail]} { 957 Respond2Client $name $sock -ERR "login failed, no actions possible" 958 return 959 } elseif {[string equal $cstate(state) auth]} { 960 Respond2Client $name $sock -ERR "client not authenticated" 961 return 962 } 963 964 set msgid [lindex $line 1] 965 966 upvar ::pop3d::pop3d::${name}::storCmd storCmd 967 968 if {$msgid == {}} { 969 # full listing 970 Respond2Client $name $sock +OK "$cstate(msg) messages" 971 972 set n $cstate(msg) 973 974 for {set i 1} {$i <= $n} {incr i} { 975 Respond2Client $name $sock $i \ 976 [uplevel #0 [linsert $storCmd end \ 977 size $cstate(storage) $i]] 978 } 979 puts $sock "." 980 981 } else { 982 # listing for specified message 983 984 if { 985 ($msgid < 1) || 986 ($msgid > $cstate(msg)) || 987 ([lsearch $msgid $cstate(deleted)] >= 0) 988 } { 989 Respond2Client $name $sock -ERR "no such message" 990 return 991 } 992 993 Respond2Client $name $sock +OK \ 994 "$msgid [uplevel #0 [linsert $storCmd end \ 995 size $cstate(storage) $msgid]]" 996 return 997 } 998} 999 1000########################## 1001########################## 1002# Command helper commands. 1003 1004proc ::pop3d::CheckLogin {name sock clientid serverid storage} { 1005 # @c Internal procedure. General code used by USER/PASS and 1006 # @c APOP login mechanisms to verify the given user-id. 1007 # @c Locks the mailbox in case of a match. 1008 # 1009 # @a conn: Descriptor of connection to write to. 1010 # @a clientid: Authentication code transmitted by client 1011 # @a serverid: Authentication code calculated here. 1012 # @a storage: Handle of mailbox requested by client. 1013 1014 #log::log debug "CheckLogin|$name|$sock|$clientid|$serverid|$storage|" 1015 1016 upvar cstate cstate 1017 upvar ::pop3d::pop3d::${name}::storCmd storCmd 1018 1019 set noStorage [expr {$storCmd == {}}] 1020 1021 if {$storage == {}} { 1022 # The user given by the client has no storage, therefore it does 1023 # not exist. React as if wrong password was given. 1024 1025 set cstate(state) auth 1026 set cstate(logon) "" 1027 1028 ::log::log notice "pop3d $name $sock state auth, no maildrop" 1029 Respond2Client $name $sock -ERR "authentication failed, sorry" 1030 1031 } elseif {[string compare $clientid $serverid] != 0} { 1032 # password/digest given by client dos not match 1033 1034 set cstate(state) auth 1035 set cstate(logon) "" 1036 1037 ::log::log notice "pop3d $name $sock state auth, secret does not match" 1038 Respond2Client $name $sock -ERR "authentication failed, sorry" 1039 1040 } elseif { 1041 !$noStorage && 1042 ! [uplevel #0 [linsert $storCmd end lock $storage]] 1043 } { 1044 # maildrop is locked already (by someone else). 1045 1046 set cstate(state) auth 1047 set cstate(logon) "" 1048 1049 ::log::log notice "pop3d $name $sock state auth, maildrop already locked" 1050 Respond2Client $name $sock -ERR \ 1051 "could not aquire lock for maildrop $cstate(name)" 1052 } else { 1053 # everything went fine. allow to proceed in session. 1054 1055 set cstate(storage) $storage 1056 set cstate(state) trans 1057 set cstate(logon) "" 1058 1059 set cstate(msg) 0 1060 if {!$noStorage} { 1061 set cstate(msg) [uplevel #0 [linsert $storCmd end \ 1062 stat $cstate(storage)]] 1063 set cstate(size) [uplevel #0 [linsert $storCmd end \ 1064 size $cstate(storage)]] 1065 } 1066 1067 ::log::log notice \ 1068 "pop3d $name $sock login $cstate(name) $storage $cstate(msg)" 1069 ::log::log notice "pop3d $name $sock state trans" 1070 1071 Respond2Client $name $sock +OK "congratulations" 1072 } 1073 return 1074} 1075 1076proc ::pop3d::Transfer {name sock msgid {limit -1}} { 1077 # We ask the storage for the mime token of the mail and use 1078 # that to generate and copy the mail to the requestor. 1079 1080 upvar cstate cstate 1081 upvar ::pop3d::pop3d::${name}::storCmd storCmd 1082 1083 if {$limit < 0} { 1084 Respond2Client $name $sock +OK \ 1085 "[uplevel #0 [linsert $storCmd end \ 1086 size $cstate(storage) $msgid]] octets" 1087 } else { 1088 Respond2Client $name $sock +OK "" 1089 } 1090 1091 set token [uplevel #0 [linsert $storCmd end get $cstate(storage) $msgid]] 1092 1093 ::log::log debug "pop3d $name $sock transfering data ($token)" 1094 1095 if {$limit < 0} { 1096 # Full transfer, we can use "copymessage" and avoid 1097 # construction in memory (depending on source of token). 1098 1099 log::log debug "pop3d $name Transfer $msgid /full" 1100 1101 # We do "."-stuffing here. This is not in the scope of the 1102 # MIME library we use, but a transport dependent thing. 1103 1104 set msg [string trimright [string map [list "\n." "\n.."] \ 1105 [mime::buildmessage $token]] \n] 1106 log::log debug "($msg)" 1107 puts $sock $msg 1108 puts $sock . 1109 1110 } else { 1111 # As long as FR #531541 is not implemented we have to build 1112 # the entire message in memory and then cut it down to the 1113 # requested size. If limit was greater than the number of 1114 # lines in the message we will get the terminating "." 1115 # too. Using regsub we make sure that it is not present and 1116 # reattach during the transfer. Otherwise we would have to use 1117 # a regexp/if combo to decide wether to attach the terminator 1118 # not. 1119 1120 set msg [split [mime::buildmessage $token] \n] 1121 set i 0 1122 incr limit -1 1123 while {[lindex $msg $i] != {}} { 1124 incr i 1125 incr limit 1126 } 1127 # i now refers to the line separating header and body 1128 1129 regsub -- "\n\\.\n$" [string map [list "\n." "\n.."] [join [lrange $msg 0 $limit] \n]] {} data 1130 puts $sock ${data}\n. 1131 } 1132 ::log::log debug "pop3d $name $sock transfer complete" 1133 # response already sent. 1134 return 1135} 1136 1137set major [lindex [split [package require md5] .] 0] 1138if {$::major < 2} { 1139 proc ::pop3d::Md5 {text} {md5::md5 $text} 1140} else { 1141 proc ::pop3d::Md5 {text} {string tolower [md5::md5 -hex $text]} 1142} 1143unset major 1144 1145########################## 1146# Module initialization 1147 1148package provide pop3d $::pop3d::version 1149