# sasl.test - Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net>
#
# Tests for the Tcllib SASL package
#
# -------------------------------------------------------------------------
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# -------------------------------------------------------------------------
# RCS: @(#) $Id: sasl.test,v 1.10 2008/01/29 00:51:39 patthoyts Exp $

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

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

testsNeedTcl     8.2
testsNeedTcltest 1.0

testing {
    useLocal sasl.tcl SASL
}

# -------------------------------------------------------------------------
# Tests
# -------------------------------------------------------------------------

proc SASLCallback {clientblob context command args} {
    upvar #0 $context ctx
    switch -exact -- $command {
        login    { return "" }
        username { return "tester" }
        password { return "secret" }
        realm    { return "tcllib.sourceforge.net" }
        hostname { return [info host] }
        default {
            return -code error "oops: client needs to write $command"
        }
    }
}

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

test SASL-1.0 {Check mechanisms preference sorting} {
    list [catch {
        set M $::SASL::mechanisms
        set ::SASL::mechanisms {}
        SASL::register TEST-1 10 client server
        SASL::register TEST-3 100 client
        SASL::register TEST-2 50 client
        set r [SASL::mechanisms]
        set ::SASL::mechanisms $M
        set r
    } res] $res
} [list 0 [list TEST-3 TEST-2 TEST-1]]

test SASL-1.1 {Check mechanisms type parameter} {
    list [catch {
        set M $::SASL::mechanisms
        set ::SASL::mechanisms {}
        SASL::register TEST-1 10 client server
        SASL::register TEST-3 100 client
        SASL::register TEST-2 50 client
        set r [list [SASL::mechanisms client] [SASL::mechanisms server]]
        set ::SASL::mechanisms $M
        set r
    } res] $res
} [list 0 [list [list TEST-3 TEST-2 TEST-1] [list TEST-1]]]

test SASL-1.2 {Check mechanisms preference minimum} {
    list [catch {
        set M $::SASL::mechanisms
        set ::SASL::mechanisms {}
        SASL::register TEST-1 10 client server
        SASL::register TEST-3 100 client
        SASL::register TEST-2 50 client
        set r [list [SASL::mechanisms client 50] [SASL::mechanisms client 80]]
        set ::SASL::mechanisms $M
        set r
    } res] $res
} [list 0 [list [list TEST-3 TEST-2] [list TEST-3]]]

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

test SASL-PLAIN-1.0 {} {
    list [catch {
        set ctx [SASL::new -mechanism PLAIN \
                     -callback [list SASLCallback 0]]
        SASL::step $ctx ""
        set r [SASL::response $ctx]
        SASL::cleanup $ctx
        set r
    } res] $res
} [list 0 "\x00tester\x00secret"]

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

test SASL-LOGIN-2.0 {Check basic LOGIN operation} {
    list [catch {
        set r {}
        set ctx [SASL::new -mechanism LOGIN \
                     -callback [list SASLCallback 0]]
        SASL::step $ctx "VXNlcm5hbWU6"
        lappend r [SASL::response $ctx]
        SASL::step $ctx "UGFzc3dvcmQ6"
        lappend r [SASL::response $ctx]
        SASL::cleanup $ctx
        set r
    } res] $res
} [list 0 [list tester secret]]

test SASL-LOGIN-2.1 {Check initial NULL challenge is ignored.} {
    list [catch {
        set r {}
        set ctx [SASL::new -mechanism LOGIN \
                     -callback [list SASLCallback 0]]
        SASL::step $ctx ""
        lappend r [SASL::response $ctx]
        SASL::step $ctx "VXNlcm5hbWU6"
        lappend r [SASL::response $ctx]
        SASL::step $ctx "UGFzc3dvcmQ6"
        lappend r [SASL::response $ctx]
        SASL::cleanup $ctx
        set r
    } res] $res
} [list 0 [list {} tester secret]]

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

test SASL-CRAMMD5-3.0 {} {
    list [catch {
        set ctx [SASL::new -mechanism CRAM-MD5 \
                     -callback [list SASLCallback 0]]
        SASL::step $ctx "<1234.987654321@tcllib.sourceforge.net>"
        set r [SASL::response $ctx]
        SASL::cleanup $ctx
        set r
    } res] $res
} [list 0 [list tester c7e3043702b782d70716bd1e21d6e2f7]]

test SASL-CRAMMD5-3.1 {} {
    list [catch {
        set ctx [SASL::new -mechanism CRAM-MD5 \
                     -callback [list SASLCallback 0]]
        SASL::step $ctx ""
        set r1 [SASL::response $ctx]
        SASL::step $ctx ""
        set r2 [SASL::response $ctx]
        SASL::cleanup $ctx
        list $r1 $r2
    } res] $res
} {0 {{} {}}}

test SASL-CRAMMD5-3.2 {} {
    list [catch {
        set ctx [SASL::new -mechanism CRAM-MD5 \
                     -callback [list SASLCallback 0]]
        SASL::step $ctx "<1234.987654321@tcllib.sourceforge.net>"
        set r [SASL::response $ctx]
        SASL::step $ctx ""
        set r2 [SASL::response $ctx]
        SASL::cleanup $ctx
        list $r $r2
    } res] $res
} [list 1 "unexpected state: CRAM-MD5 has only 1 step"]

test SASL-CRAMMD5-3.3 {} {
    list [catch {
        set ctx [SASL::new -mechanism CRAM-MD5 \
                     -callback [list SASLCallback 0]]
        SASL::step $ctx "<1234.987654321@tcllib.sourceforge.net>"
        set r1 [SASL::response $ctx]
        SASL::step $ctx ""
        set r2 [SASL::response $ctx]
        SASL::cleanup $ctx
        list $r1 $r2
    } res] $res
} [list 1 "unexpected state: CRAM-MD5 has only 1 step"]

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

test SASL-DIGESTMD5-4.0 {Basic check of DIGEST-MD5 operation} {
    list [catch {
        set ctx [SASL::new -mechanism DIGEST-MD5 \
                     -callback [list SASLCallback 0]]
        SASL::step $ctx "nonce=\"0123456789\",realm=\"tcllib.sourceforge.net\""
        set r [split [SASL::response $ctx] ,]
        SASL::cleanup $ctx
        foreach thing $r { 
            set x [split $thing =]
            set R([lindex $x 0]) [lindex [lindex $x 1] 0]
        }
        set A1 [SASL::md5_bin "tester:tcllib.sourceforge.net:secret"]
        set A2 "AUTHENTICATE:smtp/tcllib.sourceforge.net"
        set A3 [SASL::md5_hex "$A1:$R(nonce):$R(cnonce)"]
        set A4 [SASL::md5_hex $A2]
        set r [SASL::md5_hex "$A3:0123456789:$R(nc):$R(cnonce):auth:$A4"]
        string compare $r $R(response)
    } res] $res
} [list 0 0]

test SASL-DIGESTMD5-4.1 {Check initial empty challenge is accepted.} {
    list [catch {
        set ctx [SASL::new -mechanism DIGEST-MD5 \
                     -callback [list SASLCallback 0]]
        SASL::step $ctx ""
        SASL::step $ctx "nonce=\"0123456789\",realm=\"tcllib.sourceforge.net\""
        set r [split [SASL::response $ctx] ,]
        SASL::cleanup $ctx
        foreach thing $r { 
            set x [split $thing =]
            set R([lindex $x 0]) [lindex [lindex $x 1] 0]
        }
        set A1 [SASL::md5_bin "tester:tcllib.sourceforge.net:secret"]
        set A2 "AUTHENTICATE:smtp/tcllib.sourceforge.net"
        set A3 [SASL::md5_hex "$A1:$R(nonce):$R(cnonce)"]
        set A4 [SASL::md5_hex $A2]
        set r [SASL::md5_hex "$A3:0123456789:$R(nc):$R(cnonce):auth:$A4"]
        string compare $r $R(response)
    } res] $res
} [list 0 0]

test SASL-DIGESTMD5-4.2 "bug #1412021: ensure service used correctly" {
    list [catch {
        set service xmpp
        set ctx [SASL::new -mechanism DIGEST-MD5 -service $service \
                     -callback [list SASLCallback 0]]
        SASL::step $ctx "nonce=\"0123456789\",realm=\"tcllib.sourceforge.net\""
        set r [split [SASL::response $ctx] ,]
        SASL::cleanup $ctx
        foreach thing $r { 
            set x [split $thing =]
            set R([lindex $x 0]) [lindex [lindex $x 1] 0]
        }
        set A1 [SASL::md5_bin "tester:tcllib.sourceforge.net:secret"]
        set A2 "AUTHENTICATE:$service/tcllib.sourceforge.net"
        set A3 [SASL::md5_hex "$A1:$R(nonce):$R(cnonce)"]
        set A4 [SASL::md5_hex $A2]
        set r [SASL::md5_hex "$A3:0123456789:$R(nc):$R(cnonce):auth:$A4"]
        string compare $r $R(response)
    } res] $res
} [list 0 0]

test SASL-DIGESTMD5-4.3 "check for support of charset parameter" {
    list [catch {
        set service xmpp
        set ctx [SASL::new -mechanism DIGEST-MD5 -service $service \
                     -callback [list SASLCallback 0]]
        SASL::step $ctx "nonce=\"0123456789\",realm=\"tcllib.sourceforge.net\",charset=utf-8"
        array set p [SASL::DigestParameters [SASL::response $ctx]]
        SASL::cleanup $ctx
        info exists p(charset)
    } res] $res
} [list 0 1]

test SASL-DIGESTMD5-4.4 "check parsing of spaces in params" {
    list [catch {
        set service xmpp
        set ctx [SASL::new -mechanism DIGEST-MD5 -service $service \
                     -callback [list SASLCallback 0]]
        SASL::step $ctx "nonce=\"0123456789\", realm=\"tcllib.sourceforge.net\", charset=utf-8"
        set r {}
        foreach {k v} [SASL::DigestParameters [SASL::response $ctx]] { lappend r $k }
        SASL::cleanup $ctx
        lsort $r
    } res] $res
} [list 0 {charset cnonce digest-uri nc nonce qop realm response username}]

test SASL-OTP-5.0 {Check basic OTP (otp-md5) operation} {
    list [catch {
        set r {}
        set ctx [SASL::new -mechanism OTP \
                     -callback [list SASLCallback 0]]
        SASL::step $ctx ""
        lappend r [SASL::response $ctx]
        SASL::step $ctx "otp-md5 5 test5 ext"
        lappend r [SASL::response $ctx]
        SASL::cleanup $ctx
        set r
    } res] $res
} [list 0 [list "\x00tester" "word:RIG ACRE TALL CALL OAR NEIL"]]

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

testsuiteCleanup

# Local Variables:
#  mode: tcl
#  indent-tabs-mode: nil
# End: