sshcomm.test

#!/usr/bin/tclsh

#
# Before running this test, you must add ssh host keys of $opts(remote) to
# ~/.ssh/known_hosts because sshcomm runs ssh with StrictHostKeyChecking=true.
#

package require cmdline
array set opts [cmdline::getKnownOptions ::argv {
    {remote.arg "127.0.0.1" "Test target. Must be listed in ~/.ssh/known_hosts prior to run this test."}
    {wait.arg 0 "wait secs before exiting"}
    {para.arg 1 "do parallel connection test"}
    {debuglevel.arg "" "sshcomm debuglevel"}
}]

package require tcltest
namespace import tcltest::*

# package require comm; set ::comm::comm(debug) 1

set P sshcomm

test $P-init load -body {
    source [file rootname [info script]].tcl
} -result ""

#========================================

if {$opts(debuglevel) ne ""} {
    sshcomm::configure -debugchan stderr -debuglevel $opts(debuglevel)
}

#========================================
set i 0
test $P-remote-[incr i] "::sshcomm::remote::cget default" -body {
    ::sshcomm::remote::cget -verbose no
} -result no

test $P-remote-[incr i] "::sshcomm::remote::cget set" -body {
    set ::sshcomm::remote::config(-verbose) yes
    ::sshcomm::remote::cget -verbose no
} -result yes

test $P-cookie-del-unknown "::sshcomm::remote::cookie-del unknown" -body {
    ::sshcomm::remote::cookie-del unknown
} -result 0

test $P-cookie-add-[incr i] "::sshcomm::remote::cookie-add" -body {
    ::sshcomm::remote::cookie-add foo bar
} -result bar

test $P-cookie-del-unknown "::sshcomm::remote::cookie-del known" -body {
    ::sshcomm::remote::cookie-del foo
} -result 1

#========================================

set rconfig {}
if {[info exists ::env(VERBOSE)]} {
    lappend rconfig -verbose $::env(VERBOSE)
}

if {[info exists ::env(DEBUG)]} {
    ::sshcomm::configure -debuglevel 3 -debugchan stdout

    comm::comm hook lost {
        puts lost:chan=$chan,id=$id,reason=$reason
    }
}


#========================================
# Underlying unix sshcmd (without connection)

# Build sshcomm::connection with args and add it to listVar.
set builder [list apply {{listVar args} {
    upvar 1 $listVar list
    set ssh [::sshcomm::connection %AUTO% -autoconnect no\
                 {*}$args]
    lappend sshList $ssh
    set ssh
}} sshList]

test $P-ssh-unix-sshcmd {
    unix sshcmd, default.
} -constraints unix -body {
    set ssh [{*}$builder]
    if {![info exists ::env(DISPLAY)] || $::env(DISPLAY) eq ""} {
        # Fake $DISPLAY to test -forwardx11 option.
        set ::env(DISPLAY) :0.0
    }
    $ssh unix sshcmd localhost
} -result [list ssh -o StrictHostKeyChecking=yes -T -Y localhost]

test $P-ssh-unix-sshcmd {
    unix sshcmd, with configured options.
} -constraints unix -body {
    set ssh [{*}$builder -strict-host-key-checking no -forwardx11 no]
    $ssh unix sshcmd localhost
} -result [list ssh -o StrictHostKeyChecking=no -T -x localhost]

test $P-ssh-unix-sshcmd {
    unix sshcmd with port forwarding
} -constraints unix -body {
    set ssh [{*}$builder -lport 3333 -rport 4444 -localhost foobar]
    $ssh unix sshcmd {*}[$ssh forwarder] localhost
} -result [list ssh -o StrictHostKeyChecking=yes -T -Y \
               -L 3333:foobar:4444 localhost]

test $P-ssh-unix-sshcmd {
    unix sshcmd with host:port
} -constraints unix -body {
    set ssh [{*}$builder]
    $ssh unix sshcmd localhost:4321
} -result [list ssh -o StrictHostKeyChecking=yes -T -Y -p 4321 localhost]

#========================================
# Explicit connection

set sshList ""
set i 0
foreach remote [split $opts(remote) ,] {
    test $P-ssh-[incr i]-pre-$remote-[pid] "sshcomm::connection" -body {
	lappend sshList [set ssh [::sshcomm::connection %AUTO% -host $remote \
				      -autoconnect no \
				      -strict-host-key-checking no \
				      -forwardx11 no \
				      -remote-config $rconfig]]
    } -result ::connection* -match glob

    test $P-ssh-[incr i]-pre-$remote-[pid] "\$ssh connect" -body {
	$ssh connect
    } -result file* -match glob

    test $P-ssh-[incr i]-pre-$remote-[pid] "\$ssh comm new" -body {
	set cid [$ssh comm new]
    } -result [list 1 $remote]
    #     comm::comm send $NUM [list list a b c]

    #========================================
    # Basic [comm::comm send].

    test $P-ssh-[incr i]-send-$remote-[pid] "then comm send list" -body {
	comm::comm send $cid list a b c
    } -result [list a b c]

    test $P-ssh-[incr i]-send-$remote-[pid] "hostname,pid" -body {
	set host [info hostname]
	set pid [pid]

	# Caution! outer most [list] is required! Lack of [list] will cause:
	#|  invalid bareword "www"
	#|  in expression "www.example.com ne loca...";
	#|  should be "$www" or "{www}" or "www(...)" or ...
	#|      (parsing expression "www.example.com ne...")
	#|      invoked from within
	#|  "expr [info hostname] ne "www.example.com" || [pid] != 11308"

	comm::comm send $cid expr [list [subst -nocommand {
	    [info hostname] ne "$host" || [pid] != $pid
	}]]
    } -result 1

    test $P-ssh-[incr i]-send-$remote-[pid] "then comm send list" -body {
	comm::comm send $cid list a b c
    } -result [list a b c]
    
    set data [clock seconds]
    test $P-ssh-[incr i]-rchan-open-$remote "\$ssh rchan open" -body {
        
        comm::comm send $cid [list set data $data]
        set tmpFn [comm::comm send $cid {
            package require fileutil
            set tmpFn [fileutil::tempfile sshcomm-test]
            fileutil::writeFile $tmpFn $data
            set tmpFn
        }]
        
        set localCh [$ssh rchan open $cid $tmpFn]
        set got [read $localCh]
        close $localCh
        set got

    } -result $data
    
    test $P-ssh-[incr i]-rchan-socketpair-$remote "\$ssh rchan socketpair" -body {
        lassign [$ssh rchan socketpair] localSock remoteSock

        comm::comm send $cid [list apply {remoteSock {
            puts $remoteSock [list foo bar baz]
            close $remoteSock
        }} $remoteSock]
        
        set data [read $localSock]
        close $localSock
        set data
    } -result "foo bar baz\n"
}

#========================================
# Deprecated API.

test $P-pooled-deprecated-1-[pid] "deprecated" -body {
    set NUM [::sshcomm::client::create $remote]
    comm::comm send $NUM [list list a b c]
} -result {a b c}

#========================================
# cleanup

set i 0
foreach ssh $sshList {
    test $P-cleanup-[incr i] "cleanup $ssh" -body {
	$ssh destroy
    } -result {}
}

#========================================
# Pooled API.

set i 0
foreach remote [split $opts(remote) ,] {
    set cid [sshcomm::comm $remote]

    test $P-pooled-ssh-[incr i]-send-$remote-[pid] "then comm send list" -body {
	comm::comm send $cid list a b c
    } -result [list a b c]

    test $P-pooled-ssh-[incr i]-send-$remote-[pid] "hostname,pid" -body {
	set host [info hostname]
	set pid [pid]
	comm::comm send $cid expr [list [subst -nocommand {
	    [info hostname] ne "$host" || [pid] != $pid
	}]]
    } -result 1
}

#========================================
# Parallel connection test

if {$opts(para)} {
    set sshList ""
    set commList ""
    for {set i 0} {$i < $opts(para)} {incr i} {
	test $P-para-init-$i "pararell connection (create)" -body {
	    lappend sshList [set ssh [sshcomm::connection %AUTO% \
					  -host localhost]]
	    lappend commList [$ssh comm new]
	    list ok
	} -result ok
    }

    set i 0
    foreach cid $commList {
	test $P-para-send-$i "para connection alive?" -body {
	    comm::comm send $cid list yes
	} -result yes
	incr i
    }
    set i 0
    foreach ssh $sshList {
	test $P-para-destroy-$i "para destroy" -body {
	    $ssh destroy
	} -result ""
	incr i
    }
}

#========================================
# Cleanup of connection pool.

set i 0
test $P-pool-cleanup-[pid]-[incr i] "before cleanup " -body {
    llength [sshcomm::list-connections]
} -result [llength [split $opts(remote) ,]]

test $P-pool-cleanup-[pid]-[incr i] "cleanup" -body {
    sshcomm::forget-all
} -result {}

test $P-pool-cleanup-[pid]-[incr i] "after cleanup " -body {
    sshcomm::list-connections
} -result {}


if {$opts(wait)} {
    #========================================
    # Following [vwait 3sec] is not for this test itself, but for
    # multiple parallel connection test.
    #
    # Invoking multiple ssh simultaneously to single host may cause
    # connection error and/or xauth error.
    #
    # Currently, these errors are not handled. I still need time
    # to understand what is undergo. This $opts(wait) is to help it.
    # With this wait, I can read error from ssh.

    after [expr {$opts(wait) * 1000}] [list set ::any ""]
    vwait ::any
}