# -*- 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 <andreas_kupries@users.sourceforge.net>
# All rights reserved.
#
# RCS: @(#) $Id: pop3d.test,v 1.6 2003/05/02 07:42:07 andreas_kupries Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

package forget pop3d
catch {namespace delete ::pop3d}
if {[catch {source [file join [file dirname [info script]] pop3d.tcl]} msg]} {
    puts "skipped [file tail [info script]]: $msg"
    return
}
if {[catch {source [file join [file dirname [info script]] pop3d_udb.tcl]} msg]} {
    puts "skipped [file tail [info script]]: $msg"
    return
}
if {[catch {source [file join [file dirname [info script]] pop3d_dbox.tcl]} msg]} {
    puts "skipped [file tail [info script]]: $msg"
    return
}

package require pop3d
package require pop3d::udb
package require pop3d::dbox

puts "- pop3d [package present pop3d]"
puts "- udb  [package present pop3d::udb]"
puts "- dbox [package present pop3d::dbox]"

proc bgerror {message} {
    global errorCode errorInfo
    puts $errorCode
    puts $errorInfo
    return
}

# Reduce output generated by the server objects
::log::lvSuppress info
::log::lvSuppress notice
::log::lvSuppress debug
::log::lvSuppress warning

# ----------------------------------------------------------------------
# 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 {} -state down}

foreach {n opt val} {
    0 -port    110
    1 -state   down
    2 -auth    {}
    3 -storage {}
} {
    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
} {
    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
    set res [$srv configure]
    $srv destroy
    set res
} {-port 2048 -auth p3udb54 -storage p3dbox128 -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
    set    srv [::pop3d::new]
    $srv configure -port 0
    $srv up
    ::log::log debug "$srv @ [$srv cget -port]"
    return
}

proc delsrv {} {
    global srv
    $srv destroy
}

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

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 openpipe {} {
    global tcl_platform
    
    switch -exact $tcl_platform(platform) {
	windows {
	    return [open "|\"[info nameofexecutable]\" __script" r]
	}
	default {
	    return [open "|[info nameofexecutable] __script" r]
	}
    }
}

proc subshell {script args} {
    global pipe auto_path
    removeFile  __script
    makeFile {} __script
    set f [open __script w]

    set     sub_ap $auto_path
    lappend sub_ap [file dirname [file dirname [info script]]]
    lappend args auto_path $sub_ap

    foreach {k v} $args {
	puts $f [list set $k $v]
    }
    puts  $f $script
    puts  $f exit
    close $f

    set ::result [list]
    set        pipe [openpipe]
    fileevent $pipe readable [list subget $pipe]
    vwait ::stop
    if {[catch {close $pipe} msg]} {
	return "$::stop % $msg"
    }
    return $::stop
}

proc subshellpar {script myscript args} {
    global pipe auto_path
    removeFile  __script
    makeFile {} __script
    set f [open __script w]

    set     sub_ap $auto_path
    lappend sub_ap [file dirname [file dirname [info script]]]
    lappend args auto_path $sub_ap

    foreach {k v} $args {
	puts $f [list set $k $v]
    }
    puts  $f "proc wait {} {gets stdin ; return}"
    puts  $f $script
    puts  $f exit
    close $f
    ## global srv ; file copy __script __script.$srv

    set ::result [list]
    set        pipe [openpipe]
    fileevent $pipe readable [list subget $pipe]
    uplevel 1 $myscript
    vwait ::stop
    if {[catch {close $pipe} msg]} {
	return "$::stop % $msg"
    }
    return $::stop
}

proc subgo   {} {global pipe ; puts  $pipe . ; return}
proc subwait {} {vwait ::result ; return}

proc subget {pipe} {
    if {[eof $pipe]} {
	set ::stop [join $::result \n]
	return
    }
    if {[gets $pipe line] < 0} {return}

    # Strip standard variant information out of all responses.
    regsub -all [info hostname] $line {%%} line
    lappend ::result $line
    return
}

proc asort {kv} {
    set tmp [list]
    foreach {k v} $kv {lappend tmp [list $k $v]}
    set kv [list]
    foreach item [lsort -index 0 $tmp] {
	foreach {k v} $item break
	lappend kv $k $v
    }
    return $kv
}

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 [asort [array get tmp]]
}

makeDirectory __dbox__
proc newfsrv {} {
    global srv udb dbox
    newsrv
    $srv configure \
	    -auth    [set udb  [::pop3d::udb::new]] \
	    -storage [set dbox [::pop3d::dbox::new]]

    $dbox base __dbox__

    $dbox add         usr0
    $udb  add ak smash usr0

    makeFile {} [file join __dbox__ usr0 10]
    makeFile {} [file join __dbox__ usr0 20]
    makeFile {} [file join __dbox__ usr0 30]

    $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
    return
}


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

test pop3-srv-4.0 {connection introspection} {
    newsrv

    subshellpar {
	set c [socket localhost $port]
	after 3000
	gets  $c
	close $c
    } {
	after 1000 {set res [$srv conn state [$srv conn list]]}
    } port [$srv cget -port] ; # {}

    # Postprocess state to remove variable data from comparison
    set res [ppcstate $res]
    delsrv
    set res
} {deleted {} id <==@%%> logon {} msg 0 name {} remotehost 127.0.0.1 remoteport {} server 1 size 0 state auth storage {}}


test pop3-srv-5.0 {initial contact, greeting} {
    newsrv

    set res [subshell {
	set c [socket localhost $port]
	puts "greeting: [gets $c]"
	close $c
    } port [$srv cget -port]] ; # {}

    #regsub -all [info hostname]        $res {%%}  res
    regsub "\[0-9\]+_${srv}_\[0-9\]+@" $res {==@} res

    delsrv
    set res
} {greeting: +OK %% tcllib/pop3d-1.0.1 ready <==@%%>}


test pop3-srv-6.0 {unknown command} {
    newsrv

    set res [subshell {
	set c [socket localhost $port]
	gets $c
	puts $c "FOOBAR blub" ; flush $c
	puts [gets $c]
	after 3000
	close $c
    } port [$srv cget -port]] ; # {}

    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.0.0.1 remoteport {} server 1 size 0 state auth storage {}}
    1 {deleted {} id <==@%%> logon {} msg 0 name {} remotehost 127.0.0.1 remoteport {} server 1 size 0 state auth storage {}}
    2 {}
    3 {deleted {} id <==@%%> logon {} msg 0 name foo remotehost 127.0.0.1 remoteport {} server 1 size 0 state auth storage {}}
    4 {deleted {} id <==@%%> logon {} msg 3 name ak remotehost 127.0.0.1 remoteport {} server 1 size 3 state trans storage usr0}
    5 {deleted {} id <==@%%> logon {} msg 0 name ak remotehost 127.0.0.1 remoteport {} server 1 size 0 state auth storage {}}
    6 {deleted 1 id <==@%%> logon {} msg 3 name ak remotehost 127.0.0.1 remoteport {} server 1 size 3 state trans storage usr0}
}
array set log {
    0  {+OK please send PASS command}
    1  {+OK %% tcllib/pop3d-1.0.1 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}
}

# ======================================================================
# ======================================================================
# AUTHORIZATION state - Initial state, after the greeting.
# Allowed commands: USER, APOP, QUIT
# 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
} {
    test pop3-srv-7.0.$n "auth, $cmd" {
	newfsrv
	set res ""
	set trace [subshellpar {
	    set c [socket localhost $port]
	    gets $c line
	    puts $c "$cmd" ; flush $c ; gets $c line
	    after 3000
	    close $c
	    puts $line
	} {
	    after 2000 {
		catch {
		    set res [$srv conn state [$srv conn list]]
		}
	    }
	} port [$srv cget -port] cmd $cmd] ; # {}

	# Postprocess state to remove variable data from comparison
	set res [ppcstate $res]
	delfsrv
	list $trace $res
    } [list $log($lidx) $cstate($cidx)] ; # {}
}

# ----------------------------------------------------------------------
# Mutual exclusion of the different authentication methods,
# block multiple authentication

test pop3-srv-7.1 "auth, USER/APOP" {
    newfsrv
    set res ""
    set trace [subshellpar {
	set c [socket localhost $port]
	gets $c
	puts $c "USER foo" ; flush $c
	gets $c
	puts $c "APOP foo barr" ; flush $c
	puts [gets $c]
	after 3000
	close $c
    } {
	after 2000 {
	    set res [$srv conn state [$srv conn list]]
	}
    } port [$srv cget -port]] ; # {}
    
    # Postprocess state to remove variable data from comparison
    set res [ppcstate $res]
    delfsrv
    list $trace $res
} [list $log(4) $cstate(0)] ; # {}

test pop3-srv-7.2 "auth, APOP/USER" {
    newfsrv
    set res ""
    set trace [subshellpar {
	package require md5
	set c [socket localhost $port]
	regexp {(<.*>)} [gets $c] -> id
	set hash [md5::md5 ${id}smash]
	puts $c "APOP ak $hash" ; flush $c
	set line [gets $c]
	puts $c "USER foo" ; flush $c
	puts "$line [gets $c]"
	after 5000
	close $c
    } {
	after 3000 {
	    set res [$srv conn state [$srv conn list]]
	}
    } port [$srv cget -port]] ; # {}
    
    # Postprocess state to remove variable data from comparison
    set res [ppcstate $res]
    delfsrv
    list $trace $res
} [list $log(5) $cstate(4)] ; # {}

# ----------------------------------------------------------------------
# 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
	set res ""
	set trace [subshellpar {
	    set c [socket localhost $port]
	    gets $c line
	    puts $c "USER $user" ; flush $c ; gets $c line
	    puts $c "PASS $pass" ; flush $c ; gets $c line
	    after 3000
	    close $c
	    puts $line
	} {
	    after 2000 {
		set res [$srv conn state [$srv conn list]]
	    }
	} port [$srv cget -port] user $user pass $pass] ; # {}

	# Postprocess state to remove variable data from comparison
	set res [ppcstate $res]
	delfsrv
	list $trace $res
    } [list $log($lidx) $cstate($cidx)] ; # {}

    test pop3-srv-7.4.$n {APOP} {
	newfsrv
	set res ""
	set trace [subshellpar {
	    package require md5
	    set c [socket localhost $port]
	    gets $c line ; regexp {(<.*>)} $line -> id
	    set hash [md5::md5 ${id}$pass]
	    puts $c "APOP $user $hash" ; flush $c ; gets $c line
	    after 3000
	    close $c
	    puts $line
	} {
	    after 2000 {
		set res [$srv conn state [$srv conn list]]
	    }
	} port [$srv cget -port] user $user pass $pass] ; # {}

	# Postprocess state to remove variable data from comparison
	set res [ppcstate $res]
	delfsrv
	list $trace $res
    } [list $log($lidx) $cstate($cidx)] ; # {}
}


# ======================================================================
# ======================================================================
# TRANSACTION state - after successful authentication.
# Allowed commands: QUIT, STAT, DELE, RETR, TOP, RSET, LIST, NOOP
# 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
} {
    test pop3-srv-7.5.$n "trans, $cmd" {
	newfsrv
	set res ""
	set trace [subshellpar {
	    set   c [socket localhost $port]
	    gets $c
	    puts $c "USER ak"    ; flush $c ; gets $c
	    puts $c "PASS smash" ; flush $c ; gets $c
	    puts $c "$cmd"       ; flush $c
	    puts [gets $c]
	    after 3000
	    close $c
	} {
	    after 2000 {
		catch {
		    set res [$srv conn state [$srv conn list]]
		}
	    }
	} port [$srv cget -port] cmd $cmd] ; # {}

	# Postprocess state to remove variable data from comparison
	set res [ppcstate $res]
	delfsrv
	list $trace $res
    } [list $log($lidx) $cstate($cidx)] ; # {}
}

# ======================================================================
# ======================================================================
# 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" {
	newfsrv
	set res ""
	set trace [subshellpar {
	    set c [socket localhost $port]
	    gets $c
	    puts $c "USER ak"    ; flush $c ; gets $c
	    puts $c "PASS smash" ; flush $c ; gets $c
	    puts $c "DELE $mid"  ; flush $c
	    puts [gets $c]
	    after 3000
	    close $c
	} {
	    after 2000 {
		set res [$srv conn state [$srv conn list]]
	    }
	} port [$srv cget -port] mid $id] ; # {}
	
	# Postprocess state to remove variable data from comparison
	set res [ppcstate $res]
	delfsrv
	list $trace $res
    } [list $log($lidx) $cstate($cidx)] ; # {}
}

test pop3-srv-7.6.4 "DELE, out of range" {
    newfsrv
    set res ""
    set trace [subshellpar {
	set c [socket localhost $port]
	gets $c
	puts $c "USER ak"    ; flush $c ; gets $c
	puts $c "PASS smash" ; flush $c ; gets $c
	puts $c "DELE 1"     ; flush $c ; gets $c
	puts $c "DELE 1"     ; flush $c
	puts [gets $c]
	after 3000
	close $c
    } {
	after 2000 {
	    set res [$srv conn state [$srv conn list]]
	}
    } port [$srv cget -port] mid $id] ; # {}
    
    # Postprocess state to remove variable data from comparison
    set res [ppcstate $res]
    delfsrv
    list $trace $res
} [list $log(13) $cstate(6)] ; # {}


test pop3-srv-7.7 "DELE, abort" {
    newfsrv
    set res ""
    set trace [subshellpar {
	set res [list]

	lappend res [file exists [file join __dbox__ usr0 10]]

	set c [socket localhost $port]
	gets $c
	puts $c "USER ak"    ; flush $c ; gets $c
	puts $c "PASS smash" ; flush $c ; gets $c
	puts $c "DELE 1"     ; flush $c ; gets $c line
	lappend res [file exists [file join __dbox__ usr0 10]]
	after 3000
	close $c
	lappend res [file exists [file join __dbox__ usr0 10]]
	lappend res $line
	puts $res
    } {
	after 2000 {
	    set res [$srv conn state [$srv conn list]]
	}
    } port [$srv cget -port]] ; # {}
    
    # Postprocess state to remove variable data from comparison
    set res [ppcstate $res]
    delfsrv
    list $trace $res
} [list [list 1 1 1 $log(9)] $cstate(6)] ; # {}

test pop3-srv-7.8 "DELE, complete" {
    newfsrv
    set trace [subshell {
	set res [list]

	lappend res [file exists [file join __dbox__ usr0 10]]

	set c [socket localhost $port]
	gets $c
	puts $c "USER ak"    ; flush $c ; gets $c
	puts $c "PASS smash" ; flush $c ; gets $c
	puts $c "DELE 1"     ; flush $c ; gets $c line
	lappend res [file exists [file join __dbox__ usr0 10]]
	puts $c "QUIT"       ; flush $c ; gets $c
	after 3000
	close $c
	lappend res [file exists [file join __dbox__ usr0 10]]
	lappend res $line
	puts $res
    } port [$srv cget -port]] ; # {}
    
    delfsrv
    set trace
} [list 1 1 0 $log(9)] ; # {}

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
	set res ""
	set trace [subshellpar {
	    set   c [socket localhost $port]
	    gets $c
	    puts $c "USER ak"    ; flush $c ; gets $c
	    puts $c "PASS smash" ; flush $c ; gets $c
	    puts $c "DELE 1"     ; flush $c ; gets $c
	    puts $c "$cmd"       ; flush $c
	    puts [gets $c]
	    after 3000
	    close $c
	} {
	    after 2000 {
		set res [$srv conn state [$srv conn list]]
	    }
	} port [$srv cget -port] cmd $cmd] ; # {}

	# Postprocess state to remove variable data from comparison
	set res [ppcstate $res]
	delfsrv
	list $trace $res
    } [list $log($lidx) $cstate($cidx)] ; # {}
}

# ======================================================================
# ======================================================================
# 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
	set trace [subshell {
	    set res [list]
	    set c [socket localhost $port]
	    gets $c
	    puts $c "USER $user" ; flush $c ; gets $c
	    puts $c "PASS $pass" ; flush $c ; gets $c
	    puts $c "LIST $id"   ; flush $c ; gets $c line
	    lappend res $line
	    if {$id == {}} {
		while {![eof $c]} {
		    gets $c line
		    if {[string equal $line .]} {break}
		    lappend res $line
		}
	    }
	    close $c
	    puts [join $res]
	} port [$srv cget -port] id $id user $user pass $pass] ; # {}
	
	delfsrv
	set trace
    } $log($lidx) ; # {}
}

# ----------------------------------------------------------------------
::tcltest::cleanupTests