# -*- tcl -*- # pop3.test: tests for the simple pop3 server. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 2002 by Andreas Kupries # All rights reserved. # # RCS: @(#) $Id: pop3d.test,v 1.22 2009/09/29 07:07:15 andreas_kupries Exp $ # ------------------------------------------------------------------------- source [file join \ [file dirname [file dirname [file join [pwd] [info script]]]] \ devtools testutilities.tcl] testsNeedTcl 8.3 testsNeedTcltest 1.0 support { #use comm/comm.tcl comm useTcllibFile devtools/coserv.tcl ; # loads comm too useTcllibFile devtools/dialog.tcl use md5/md5x.tcl md5 use mime/mime.tcl mime useLocal pop3d_udb.tcl pop3d::udb useLocalKeep pop3d_dbox.tcl pop3d::dbox } testing { useLocalKeep pop3d.tcl pop3d } # ------------------------------------------------------------------------- # Server processes. Programmed dialogs, server side. dialog::setup client {Pop3 Fake Client} # ------------------------------------------------------------------------- proc bgerror {message} { global errorCode errorInfo puts $errorCode puts $errorInfo return } # Reduce output generated by the server objects set disable 1 ::log::lvSuppress info $disable ::log::lvSuppress notice $disable ::log::lvSuppress debug $disable ::log::lvSuppress warning $disable if {!$disable} { tcltest::verbose {pass body error skip} } # ---------------------------------------------------------------------- # Basic stuff - Create and destroy servers, # (re)configure and query configuration. test pop3-srv-1.0 {anon create/destroy} { set srv [::pop3d::new] $srv destroy set srv } pop3d1 test pop3-srv-1.1 {named create/destroy} { set srv [::pop3d::new foo] $srv destroy set srv } foo test pop3-srv-1.2 {multiple create} { ::pop3d::new foo catch {::pop3d::new foo} msg foo destroy set msg } {command "foo" already exists, unable to create pop3 server} test pop3-srv-1.3 {correct creation, destruction} { ::pop3d::new foo set res [list [info exists ::pop3d::pop3d::foo::port]] foo destroy lappend res [info exists ::pop3d::pop3d::foo::port] } {1 0} test pop3-srv-1.4 {unknown method} { set srv [::pop3d::new] catch {$srv foo} res $srv destroy set res } {bad option "foo": must be cget, configure, destroy, down, or up} test pop3-srv-2.0 {base configuration} { set srv [::pop3d::new] set res [$srv configure] $srv destroy set res } {-port 110 -auth {} -storage {} -socket ::socket -state down} foreach {n opt val} { 0 -port 110 1 -state down 2 -auth {} 3 -storage {} 4 -socket ::socket } { test pop3-srv-2.1.$n {cget} { set srv [::pop3d::new] set res [$srv cget $opt] $srv destroy set res } $val ; # {} test pop3-srv-2.2.$n {configure get} { set srv [::pop3d::new] set res [$srv configure $opt] $srv destroy set res } $val ; # {} } foreach {n opt val} { 0 -port 2048 2 -auth p3udb54 3 -storage p3dbox128 4 -socket s0ck3t } { test pop3-srv-2.3.$n {configure set/get} { set srv [::pop3d::new] $srv configure $opt $val set res [$srv cget $opt] $srv destroy set res } $val ; # {} } test pop3-srv-2.3.1 {configure set/get} { set srv [::pop3d::new] catch {$srv configure -state exiting} res $srv destroy set res } {Option -state is read-only} test pop3-srv-2.4 {configure set/get} { set srv [::pop3d::new] $srv configure -port 2048 -auth p3udb54 -storage p3dbox128 -socket s0ck3t set res [$srv configure] $srv destroy set res } {-port 2048 -auth p3udb54 -storage p3dbox128 -socket s0ck3t -state down} test pop3-srv-2.5 {configure} { set srv [::pop3d::new] catch {$srv configure -port 2048 -auth} res $srv destroy set res } {wrong # args, expected: -option | (-option value)...} test pop3-srv-2.6 {connection introspection} { set srv [::pop3d::new] set res [$srv conn list] $srv destroy set res } {} test pop3-srv-2.7 {connection introspection} { set srv [::pop3d::new] catch {$srv conn list foo} res $srv destroy regsub $srv $res @ res set res } {wrong # args: should be "@ conn list"} test pop3-srv-2.8 {connection introspection} { set srv [::pop3d::new] catch {$srv conn state} res $srv destroy regsub $srv $res @ res set res } {wrong # args: should be "@ conn state connId"} test pop3-srv-2.9 {connection introspection} { set srv [::pop3d::new] catch {$srv conn state foo bar} res $srv destroy regsub $srv $res @ res set res } {wrong # args: should be "@ conn state connId"} test pop3-srv-2.10 {connection introspection} { set srv [::pop3d::new] catch {$srv conn foo} res $srv destroy regsub $srv $res @ res set res } {bad option "foo": must be list, or state} # ---------------------------------------------------------------------- # Advanced I: Basic server up, down, check for true listening, # check state, port information # # Helper functionality to create and destroy servers proc newsrv {} { global srv log::log debug "/============================================" set srv [::pop3d::new] $srv configure -port 0 $srv up ::log::log debug "..... $srv @ [$srv cget -port]" return } proc delsrv {} { global srv $srv destroy } proc talk {{mode trace+res}} { global srv after 1000 [list dialog::runclient [$srv cget -port]] dialog::waitdone ; # Wait for 'halt.keep.' or general halt. if {[string equal $mode trace+res]} { set trace [dialog::received] regsub -all [info hostname] $trace {%%} trace regsub "\[0-9\]+_${srv}_\[0-9\]+@" $trace {==@} trace set c [lindex [$srv conn list] 0] if {$c != {}} {set res [$srv conn state $c]} else {set res {}} set res [ppcstate $res] return [list $trace $res] } elseif {[string equal $mode resonly]} { set c [lindex [$srv conn list] 0] if {$c != {}} {set res [$srv conn state $c]} else {set res {}} set res [ppcstate $res] return $res } else { # Trace only set trace [dialog::received] regsub -all [info hostname] $trace {%%} trace regsub "\[0-9\]+_${srv}_\[0-9\]+@" $trace {==@} trace return $trace } } # ---------------------------------------------------------------------- test pop3-srv-3.0 {basic up} { newsrv set res [$srv cget -state] delsrv set res } {up} test pop3-srv-3.1 {basic up & down} { newsrv set res [$srv cget -state] $srv down lappend res [$srv cget -state] lappend res [$srv cget -port] delsrv set res } {up down 0} # ---------------------------------------------------------------------- # Advanced II. # # Full interaction with the server. # # First some helper commands to for the mgmt of a subprocess # (Which will be the client), to create a server in a specific # initial state, and to perform specific queries of the state. proc ppcstate {state} { if {$state == {}} {return $state} global srv array set tmp $state regsub -all [info hostname] $tmp(id) {%%} tmp(id) regsub "\[0-9\]+_${srv}_\[0-9\]+@" $tmp(id) {==@} tmp(id) set tmp(server) [string equal $tmp(server) $srv] set tmp(remoteport) "" return [dictsort [array get tmp]] } proc newfsrv {} { global srv udb dbox newsrv $srv configure \ -auth [set udb [::pop3d::udb::new]] \ -storage [set dbox [::pop3d::dbox::new]] makeDirectory __dbox__ $dbox base __dbox__ $dbox add usr0 $udb add ak smash usr0 foreach f {10 20 30} { makeFile {} [file join __dbox__ usr0 $f] } $dbox add usr1 $udb add jh wooof usr1 return } proc delfsrv {} { global udb dbox delsrv $udb destroy foreach m [$dbox list] {$dbox remove $m} $dbox destroy foreach f {10 20 30} { set f [file join __dbox__ usr0 $f] if {![file exists $f]} continue removeFile {} $f } removeDirectory __dbox__ return } # ---------------------------------------------------------------------- test pop3-srv-4.0 {connection introspection} { newsrv dialog::dialog_set { dialog::crlf. ; # Network EOL setting dialog::receive. ; # Greeting dialog::halt.keep. ; # Stop execution, keep socket open } set res [talk resonly] delsrv string match {deleted {} id <==@%%> logon {} msg 0 name {} remotehost 127.*.*.* remoteport {} server 1 size 0 state auth storage {}} $res } 1 test pop3-srv-5.0 {initial contact, greeting} { newsrv dialog::dialog_set { dialog::crlf. ; # Network EOL setting dialog::receive. ; # Greeting dialog::geval. {set received [lindex $received end]} dialog::halt.keep. ; # Stop execution, keep socket open } set res [talk traceonly] delsrv string match {+OK %% tcllib/pop3d-* ready <==@%%>} $res } 1 test pop3-srv-6.0 {unknown command} { newsrv dialog::dialog_set { dialog::crlf. ; # Network EOL setting dialog::receive. ; # Greeting dialog::request. {FOOBAR blub} dialog::geval. {set received [lindex $received end]} dialog::halt.keep. ; # Stop execution, keep socket open } set res [talk traceonly] delsrv set res } {-ERR unknown command 'FOOBAR'} # ---------------------------------------------------------------------- # Database of possible responses and server states. array set cstate { 0 {deleted {} id <==@%%> logon user msg 0 name foo remotehost 127.*.*.* remoteport {} server 1 size 0 state auth storage {}} 1 {deleted {} id <==@%%> logon {} msg 0 name {} remotehost 127.*.*.* remoteport {} server 1 size 0 state auth storage {}} 2 {} 3 {deleted {} id <==@%%> logon {} msg 0 name foo remotehost 127.*.*.* remoteport {} server 1 size 0 state auth storage {}} 4 {deleted {} id <==@%%> logon {} msg 3 name ak remotehost 127.*.*.* remoteport {} server 1 size 3 state trans storage usr0} 5 {deleted {} id <==@%%> logon {} msg 0 name ak remotehost 127.*.*.* remoteport {} server 1 size 0 state auth storage {}} 6 {deleted 1 id <==@%%> logon {} msg 3 name ak remotehost 127.*.*.* remoteport {} server 1 size 3 state trans storage usr0} } array set log { 0 {+OK please send PASS command} 1 {+OK %% tcllib/pop3d-* shutting down} 2 {-ERR client not authenticated} 3 {-ERR authentication failed, sorry} 4 {-ERR login mechanism USER/PASS was chosen} 5 {+OK congratulations -ERR client already authenticated} 6 {+OK congratulations} 7 {-ERR client already authenticated} 8 {+OK 3 3} 9 {+OK message 1 deleted} 10 {+OK 1 octets} 11 {+OK } 12 {+OK 3 messages waiting} 13 {-ERR no such message} 14 {+OK 1 1} 15 {+OK 3 messages 1 1 2 1 3 1} 16 {+OK 0 messages} 17 {+OK Capability list follows} } # ====================================================================== # ====================================================================== # AUTHORIZATION state - Initial state, after the greeting. # Allowed commands: USER, APOP, QUIT, CAPA # Not permitted: PASS, STAT, DELE, RETR, TOP, RSET, LIST, NOOP # foreach {n cmd lidx cidx} { 0 {USER foo} 0 0 1 {APOP foo bar} 3 3 2 {QUIT} 1 2 3 {STAT} 2 1 4 {DELE 1} 2 1 5 {RETR 1} 2 1 6 {TOP 1 10} 2 1 7 {RSET} 2 1 8 {LIST} 2 1 9 {NOOP} 2 1 10 {PASS xxx} 3 1 11 {CAPA} 17 1 } { test pop3-srv-7.0.$n "auth, $cmd" { newfsrv dialog::dialog_set { dialog::crlf. ; # Network EOL setting dialog::receive. ; # Greeting dialog::request. $cmd dialog::geval. {set received [lindex $received end]} dialog::halt.keep. ; # Stop execution, keep socket open } set res [talk trace+res] delfsrv string match [list $log($lidx) $cstate($cidx)] $res } 1 } # ---------------------------------------------------------------------- # Mutual exclusion of the different authentication methods, # block multiple authentication test pop3-srv-7.1 {auth, USER/APOP} { newfsrv dialog::dialog_set { dialog::crlf. ; # Network EOL setting dialog::receive. ; # Greeting dialog::request. {USER foo} dialog::request. {APOP foo barr} dialog::geval. {set received [lindex $received end]} dialog::halt.keep. ; # Stop execution, keep socket open } set res [talk trace+res] delfsrv string match [list $log(4) $cstate(0)] $res } 1 test pop3-srv-7.2 {auth, APOP/USER} { newfsrv dialog::dialog_set { dialog::crlf. ; # Network EOL setting dialog::receive. ; # Greeting dialog::geval. { regexp {(<.*>)} [lindex $received 0] -> id set hash [string tolower [comm::comm send $main [list md5::md5 -hex ${id}smash]]] set vcommand "APOP ak $hash" } dialog::reqgvar. vcommand dialog::request. {USER foo} dialog::geval. {set received [join [lrange $received end-1 end]]} dialog::halt.keep. ; # Stop execution, keep socket open } set res [talk trace+res] delfsrv string match [list $log(5) $cstate(4)] $res } 1 # ---------------------------------------------------------------------- # Checking authentication foreach {n user pass lidx cidx} { 0 foo bar 3 3 1 ak bar 3 5 2 ak smash 6 4 } { test pop3-srv-7.3.$n {USER/PASS} { newfsrv dialog::dialog_set { dialog::crlf. ; # Network EOL setting dialog::receive. ; # Greeting dialog::request. [list USER $user] dialog::request. [list PASS $pass] dialog::geval. {set received [lindex $received end]} dialog::halt.keep. ; # Stop execution, keep socket open } set res [talk trace+res] delfsrv string match [list $log($lidx) $cstate($cidx)] $res } 1 test pop3-srv-7.4.$n {APOP} { newfsrv dialog::dialog_set { dialog::crlf. ; # Network EOL setting dialog::receive. ; # Greeting dialog::geval. [string map [list @@@ $pass !!! $user] { regexp {(<.*>)} [lindex $received 0] -> id set hash [string tolower [comm::comm send $main [list md5::md5 -hex ${id}@@@]]] set vcommand "APOP !!! $hash" }] dialog::sendgvar. vcommand dialog::receive. ; # Apop response dialog::geval. {set received [lindex $received end]} dialog::halt.keep. ; # Stop execution, keep socket open } set res [talk trace+res] delfsrv string match [list $log($lidx) $cstate($cidx)] $res } 1 } # ====================================================================== # ====================================================================== # TRANSACTION state - after successful authentication. # Allowed commands: QUIT, STAT, DELE, RETR, TOP, RSET, LIST, NOOP, CAPA # Not permitted: USER, PASS, APOP # foreach {n cmd lidx cidx} { 0 {USER foo} 7 4 1 {APOP foo bar} 7 4 2 {QUIT} 1 2 3 {STAT} 8 4 4 {DELE 1} 9 6 5 {RETR 1} 10 4 6 {TOP 1 10} 11 4 7 {RSET} 12 4 9 {NOOP} 11 4 10 {PASS xxx} 7 4 11 {CAPA} 17 4 } { test pop3-srv-7.5.$n "trans, $cmd" { newfsrv dialog::dialog_set { dialog::crlf. ; # Network EOL setting dialog::receive. ; # Greeting dialog::request. {USER ak} dialog::request. {PASS smash} dialog::request. $cmd dialog::geval. {set received [lindex $received end]} dialog::halt.keep. ; # Stop execution, keep socket open } set res [talk trace+res] delfsrv string match [list $log($lidx) $cstate($cidx)] $res } 1 } # ====================================================================== # ====================================================================== # Test that deletion of messages is handled correctly (only after QUIT). # (Out of range, actual deletion only after the QUIT ...) foreach {n id lidx cidx} { 0 -1 13 4 1 0 13 4 2 1 9 6 3 4 13 4 } { test pop3-srv-7.6.$n {DELE, out of range message index} { newfsrv dialog::dialog_set { dialog::crlf. ; # Network EOL setting dialog::receive. ; # Greeting dialog::request. {USER ak} dialog::request. {PASS smash} dialog::request. [list DELE $id] dialog::geval. {set received [lindex $received end]} dialog::halt.keep. ; # Stop execution, keep socket open } set res [talk trace+res] delfsrv string match [list $log($lidx) $cstate($cidx)] $res } 1 } test pop3-srv-7.6.4 {DELE, out of range message index} { newfsrv dialog::dialog_set { dialog::crlf. ; # Network EOL setting dialog::receive. ; # Greeting dialog::request. {USER ak} dialog::request. {PASS smash} dialog::request. {DELE 1} dialog::request. {DELE 1} dialog::geval. {set received [lindex $received end]} dialog::halt.keep. ; # Stop execution, keep socket open } set res [talk trace+res] delfsrv string match [list $log(13) $cstate(6)] $res } 1 test pop3-srv-7.7 {DELE, abort} { newfsrv dialog::dialog_set { dialog::geval. { set fex [file exists [file join __dbox__ usr0 10]] } dialog::crlf. ; # Network EOL setting dialog::receive. ; # Greeting dialog::request. {USER ak} dialog::request. {PASS smash} dialog::request. {DELE 1} dialog::geval. { set received [lrange $received end end] lappend received $fex lappend received [file exists [file join __dbox__ usr0 10]] } dialog::halt.keep. ; # Stop execution, keep socket open } set res [talk trace+res] lappend res [file exists [file join __dbox__ usr0 10]] delfsrv string match [list [list $log(9) 1 1] $cstate(6) 1] $res } 1 test pop3-srv-7.8 {DELE, complete} { newfsrv dialog::dialog_set { dialog::geval. { set fex [file exists [file join __dbox__ usr0 10]] } dialog::crlf. ; # Network EOL setting dialog::receive. ; # Greeting dialog::request. {USER ak} dialog::request. {PASS smash} dialog::request. {DELE 1} dialog::geval. { set fexb [file exists [file join __dbox__ usr0 10]] } dialog::request. QUIT dialog::geval. { set received [lrange $received end-1 end-1] lappend received $fex $fexb } dialog::halt.keep. ; # Stop execution, keep socket open } set res [talk traceonly] lappend res [file exists [file join __dbox__ usr0 10]] delfsrv set res } [list $log(9) 1 1 0] ; # {} foreach {n cmd lidx cidx} { 0 {DELE 1} 13 6 1 {RETR 1} 13 6 2 {TOP 1 10} 13 6 } { test pop3-srv-7.10.$n "DELE, $cmd" { newfsrv dialog::dialog_set { dialog::crlf. ; # Network EOL setting dialog::receive. ; # Greeting dialog::request. {USER ak} dialog::request. {PASS smash} dialog::request. {DELE 1} dialog::request. $cmd dialog::geval. {set received [lindex $received end]} dialog::halt.keep. ; # Stop execution, keep socket open } set res [talk trace+res] delfsrv string match [list $log($lidx) $cstate($cidx)] $res } 1 } # ====================================================================== # ====================================================================== # LIST # foreach {n user pass id lidx} { 0 ak smash 0 13 1 ak smash -1 13 2 ak smash 1 14 3 ak smash 4 13 4 ak smash {} 15 5 jh wooof 0 13 6 jh wooof 1 13 7 jh wooof {} 16 } { test pop3-srv-7.11.$n "LIST $id" { newfsrv dialog::dialog_set { dialog::crlf. ; # Network EOL setting dialog::receive. ; # Greeting dialog::request. [list USER $user] dialog::request. [list PASS $pass] dialog::geval. {set received {}} if {$id != {}} { dialog::request. [list LIST $id] } else { dialog::request. LIST dialog::eval. { global received fconfigure $sock -blocking 1 while {![eof $sock]} { gets $sock line if {[string equal $line .]} break lappend received $line } fconfigure $sock -blocking 0 } } dialog::geval. {set received [join $received]} dialog::halt.keep. ; # Stop execution, keep socket open } set res [talk traceonly] delfsrv set res } $log($lidx) ; # {} } # ---------------------------------------------------------------------- dialog::shutdown testsuiteCleanup