path: root/tcllib/modules/pop3d/pop3d.test

# -*- 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-2014 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
# All rights reserved.
#
# RCS: @(#) $Id: pop3d.test,v 1.24 2011/11/14 22:33:48 andreas_kupries Exp $

# -------------------------------------------------------------------------

source [file join \
	[file dirname [file dirname [file join [pwd] [info script]]]] \
	devtools testutilities.tcl]

testsNeedTcl     8.5 ;# Required by mime.tcl
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.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
    expr {
	  [string match {deleted {} id <==@%%> logon {} msg 0 name {} remotehost 127.*.*.* remoteport {} server 1 size 0 state auth storage {}} $res] ||
	  [string match {deleted {} id <==@%%> logon {} msg 0 name {} remotehost ::1 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 @ADDR remoteport {} server 1 size 0 state auth storage {}}
    1 {deleted {} id <==@%%> logon {} msg 0 name {} remotehost @ADDR remoteport {} server 1 size 0 state auth storage {}}
    2 {}
    3 {deleted {} id <==@%%> logon {} msg 0 name foo remotehost @ADDR remoteport {} server 1 size 0 state auth storage {}}
    4 {deleted {} id <==@%%> logon {} msg 3 name ak remotehost @ADDR remoteport {} server 1 size 3 state trans storage usr0}
    5 {deleted {} id <==@%%> logon {} msg 0 name ak remotehost @ADDR remoteport {} server 1 size 0 state auth storage {}}
    6 {deleted 1 id <==@%%> logon {} msg 3 name ak remotehost @ADDR 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}
    18 {{+OK message 1 deleted} 1 1}
}

# ======================================================================
# ======================================================================
# AUTHORIZATION state - Initial state, after the greeting.
# Allowed commands: USER, APOP, QUIT, CAPA
# Not permitted:    PASS, STAT, DELE, RETR, TOP, RSET, LIST, NOOP
# 

proc Match {l c res} {
    global log cstate
    foreach addr {127.*.*.* ::1} {
	set cs [string map [list @ADDR $addr] $cstate($c)]
	if {[string match [list $log($l) $cs] $res]} { return 1 }
    }
    return 0
}

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
	Match $lidx $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
    Match 4 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
    Match 5 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
	Match $lidx $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
	Match $lidx $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
	Match $lidx $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
	Match $lidx $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
    Match 13 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]
    set has [file exists [file join __dbox__ usr0 10]]
    delfsrv
    list [Match 18 6 $res] $has
} {1 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
	Match $lidx $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