1# sasl.test - Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net>
2#
3# Tests for the Tcllib SASL package
4#
5# -------------------------------------------------------------------------
6# See the file "license.terms" for information on usage and redistribution
7# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
8# -------------------------------------------------------------------------
9# RCS: @(#) $Id: sasl.test,v 1.10 2008/01/29 00:51:39 patthoyts Exp $
10
11# -------------------------------------------------------------------------
12
13source [file join \
14	[file dirname [file dirname [file join [pwd] [info script]]]] \
15	devtools testutilities.tcl]
16
17testsNeedTcl     8.2
18testsNeedTcltest 1.0
19
20testing {
21    useLocal sasl.tcl SASL
22}
23
24# -------------------------------------------------------------------------
25# Tests
26# -------------------------------------------------------------------------
27
28proc SASLCallback {clientblob context command args} {
29    upvar #0 $context ctx
30    switch -exact -- $command {
31        login    { return "" }
32        username { return "tester" }
33        password { return "secret" }
34        realm    { return "tcllib.sourceforge.net" }
35        hostname { return [info host] }
36        default {
37            return -code error "oops: client needs to write $command"
38        }
39    }
40}
41
42# -------------------------------------------------------------------------
43
44test SASL-1.0 {Check mechanisms preference sorting} {
45    list [catch {
46        set M $::SASL::mechanisms
47        set ::SASL::mechanisms {}
48        SASL::register TEST-1 10 client server
49        SASL::register TEST-3 100 client
50        SASL::register TEST-2 50 client
51        set r [SASL::mechanisms]
52        set ::SASL::mechanisms $M
53        set r
54    } res] $res
55} [list 0 [list TEST-3 TEST-2 TEST-1]]
56
57test SASL-1.1 {Check mechanisms type parameter} {
58    list [catch {
59        set M $::SASL::mechanisms
60        set ::SASL::mechanisms {}
61        SASL::register TEST-1 10 client server
62        SASL::register TEST-3 100 client
63        SASL::register TEST-2 50 client
64        set r [list [SASL::mechanisms client] [SASL::mechanisms server]]
65        set ::SASL::mechanisms $M
66        set r
67    } res] $res
68} [list 0 [list [list TEST-3 TEST-2 TEST-1] [list TEST-1]]]
69
70test SASL-1.2 {Check mechanisms preference minimum} {
71    list [catch {
72        set M $::SASL::mechanisms
73        set ::SASL::mechanisms {}
74        SASL::register TEST-1 10 client server
75        SASL::register TEST-3 100 client
76        SASL::register TEST-2 50 client
77        set r [list [SASL::mechanisms client 50] [SASL::mechanisms client 80]]
78        set ::SASL::mechanisms $M
79        set r
80    } res] $res
81} [list 0 [list [list TEST-3 TEST-2] [list TEST-3]]]
82
83# -------------------------------------------------------------------------
84
85test SASL-PLAIN-1.0 {} {
86    list [catch {
87        set ctx [SASL::new -mechanism PLAIN \
88                     -callback [list SASLCallback 0]]
89        SASL::step $ctx ""
90        set r [SASL::response $ctx]
91        SASL::cleanup $ctx
92        set r
93    } res] $res
94} [list 0 "\x00tester\x00secret"]
95
96# -------------------------------------------------------------------------
97
98test SASL-LOGIN-2.0 {Check basic LOGIN operation} {
99    list [catch {
100        set r {}
101        set ctx [SASL::new -mechanism LOGIN \
102                     -callback [list SASLCallback 0]]
103        SASL::step $ctx "VXNlcm5hbWU6"
104        lappend r [SASL::response $ctx]
105        SASL::step $ctx "UGFzc3dvcmQ6"
106        lappend r [SASL::response $ctx]
107        SASL::cleanup $ctx
108        set r
109    } res] $res
110} [list 0 [list tester secret]]
111
112test SASL-LOGIN-2.1 {Check initial NULL challenge is ignored.} {
113    list [catch {
114        set r {}
115        set ctx [SASL::new -mechanism LOGIN \
116                     -callback [list SASLCallback 0]]
117        SASL::step $ctx ""
118        lappend r [SASL::response $ctx]
119        SASL::step $ctx "VXNlcm5hbWU6"
120        lappend r [SASL::response $ctx]
121        SASL::step $ctx "UGFzc3dvcmQ6"
122        lappend r [SASL::response $ctx]
123        SASL::cleanup $ctx
124        set r
125    } res] $res
126} [list 0 [list {} tester secret]]
127
128# -------------------------------------------------------------------------
129
130test SASL-CRAMMD5-3.0 {} {
131    list [catch {
132        set ctx [SASL::new -mechanism CRAM-MD5 \
133                     -callback [list SASLCallback 0]]
134        SASL::step $ctx "<1234.987654321@tcllib.sourceforge.net>"
135        set r [SASL::response $ctx]
136        SASL::cleanup $ctx
137        set r
138    } res] $res
139} [list 0 [list tester c7e3043702b782d70716bd1e21d6e2f7]]
140
141test SASL-CRAMMD5-3.1 {} {
142    list [catch {
143        set ctx [SASL::new -mechanism CRAM-MD5 \
144                     -callback [list SASLCallback 0]]
145        SASL::step $ctx ""
146        set r1 [SASL::response $ctx]
147        SASL::step $ctx ""
148        set r2 [SASL::response $ctx]
149        SASL::cleanup $ctx
150        list $r1 $r2
151    } res] $res
152} {0 {{} {}}}
153
154test SASL-CRAMMD5-3.2 {} {
155    list [catch {
156        set ctx [SASL::new -mechanism CRAM-MD5 \
157                     -callback [list SASLCallback 0]]
158        SASL::step $ctx "<1234.987654321@tcllib.sourceforge.net>"
159        set r [SASL::response $ctx]
160        SASL::step $ctx ""
161        set r2 [SASL::response $ctx]
162        SASL::cleanup $ctx
163        list $r $r2
164    } res] $res
165} [list 1 "unexpected state: CRAM-MD5 has only 1 step"]
166
167test SASL-CRAMMD5-3.3 {} {
168    list [catch {
169        set ctx [SASL::new -mechanism CRAM-MD5 \
170                     -callback [list SASLCallback 0]]
171        SASL::step $ctx "<1234.987654321@tcllib.sourceforge.net>"
172        set r1 [SASL::response $ctx]
173        SASL::step $ctx ""
174        set r2 [SASL::response $ctx]
175        SASL::cleanup $ctx
176        list $r1 $r2
177    } res] $res
178} [list 1 "unexpected state: CRAM-MD5 has only 1 step"]
179
180# -------------------------------------------------------------------------
181
182test SASL-DIGESTMD5-4.0 {Basic check of DIGEST-MD5 operation} {
183    list [catch {
184        set ctx [SASL::new -mechanism DIGEST-MD5 \
185                     -callback [list SASLCallback 0]]
186        SASL::step $ctx "nonce=\"0123456789\",realm=\"tcllib.sourceforge.net\""
187        set r [split [SASL::response $ctx] ,]
188        SASL::cleanup $ctx
189        foreach thing $r { 
190            set x [split $thing =]
191            set R([lindex $x 0]) [lindex [lindex $x 1] 0]
192        }
193        set A1 [SASL::md5_bin "tester:tcllib.sourceforge.net:secret"]
194        set A2 "AUTHENTICATE:smtp/tcllib.sourceforge.net"
195        set A3 [SASL::md5_hex "$A1:$R(nonce):$R(cnonce)"]
196        set A4 [SASL::md5_hex $A2]
197        set r [SASL::md5_hex "$A3:0123456789:$R(nc):$R(cnonce):auth:$A4"]
198        string compare $r $R(response)
199    } res] $res
200} [list 0 0]
201
202test SASL-DIGESTMD5-4.1 {Check initial empty challenge is accepted.} {
203    list [catch {
204        set ctx [SASL::new -mechanism DIGEST-MD5 \
205                     -callback [list SASLCallback 0]]
206        SASL::step $ctx ""
207        SASL::step $ctx "nonce=\"0123456789\",realm=\"tcllib.sourceforge.net\""
208        set r [split [SASL::response $ctx] ,]
209        SASL::cleanup $ctx
210        foreach thing $r { 
211            set x [split $thing =]
212            set R([lindex $x 0]) [lindex [lindex $x 1] 0]
213        }
214        set A1 [SASL::md5_bin "tester:tcllib.sourceforge.net:secret"]
215        set A2 "AUTHENTICATE:smtp/tcllib.sourceforge.net"
216        set A3 [SASL::md5_hex "$A1:$R(nonce):$R(cnonce)"]
217        set A4 [SASL::md5_hex $A2]
218        set r [SASL::md5_hex "$A3:0123456789:$R(nc):$R(cnonce):auth:$A4"]
219        string compare $r $R(response)
220    } res] $res
221} [list 0 0]
222
223test SASL-DIGESTMD5-4.2 "bug #1412021: ensure service used correctly" {
224    list [catch {
225        set service xmpp
226        set ctx [SASL::new -mechanism DIGEST-MD5 -service $service \
227                     -callback [list SASLCallback 0]]
228        SASL::step $ctx "nonce=\"0123456789\",realm=\"tcllib.sourceforge.net\""
229        set r [split [SASL::response $ctx] ,]
230        SASL::cleanup $ctx
231        foreach thing $r { 
232            set x [split $thing =]
233            set R([lindex $x 0]) [lindex [lindex $x 1] 0]
234        }
235        set A1 [SASL::md5_bin "tester:tcllib.sourceforge.net:secret"]
236        set A2 "AUTHENTICATE:$service/tcllib.sourceforge.net"
237        set A3 [SASL::md5_hex "$A1:$R(nonce):$R(cnonce)"]
238        set A4 [SASL::md5_hex $A2]
239        set r [SASL::md5_hex "$A3:0123456789:$R(nc):$R(cnonce):auth:$A4"]
240        string compare $r $R(response)
241    } res] $res
242} [list 0 0]
243
244test SASL-DIGESTMD5-4.3 "check for support of charset parameter" {
245    list [catch {
246        set service xmpp
247        set ctx [SASL::new -mechanism DIGEST-MD5 -service $service \
248                     -callback [list SASLCallback 0]]
249        SASL::step $ctx "nonce=\"0123456789\",realm=\"tcllib.sourceforge.net\",charset=utf-8"
250        array set p [SASL::DigestParameters [SASL::response $ctx]]
251        SASL::cleanup $ctx
252        info exists p(charset)
253    } res] $res
254} [list 0 1]
255
256test SASL-DIGESTMD5-4.4 "check parsing of spaces in params" {
257    list [catch {
258        set service xmpp
259        set ctx [SASL::new -mechanism DIGEST-MD5 -service $service \
260                     -callback [list SASLCallback 0]]
261        SASL::step $ctx "nonce=\"0123456789\", realm=\"tcllib.sourceforge.net\", charset=utf-8"
262        set r {}
263        foreach {k v} [SASL::DigestParameters [SASL::response $ctx]] { lappend r $k }
264        SASL::cleanup $ctx
265        lsort $r
266    } res] $res
267} [list 0 {charset cnonce digest-uri nc nonce qop realm response username}]
268
269test SASL-OTP-5.0 {Check basic OTP (otp-md5) operation} {
270    list [catch {
271        set r {}
272        set ctx [SASL::new -mechanism OTP \
273                     -callback [list SASLCallback 0]]
274        SASL::step $ctx ""
275        lappend r [SASL::response $ctx]
276        SASL::step $ctx "otp-md5 5 test5 ext"
277        lappend r [SASL::response $ctx]
278        SASL::cleanup $ctx
279        set r
280    } res] $res
281} [list 0 [list "\x00tester" "word:RIG ACRE TALL CALL OAR NEIL"]]
282
283# -------------------------------------------------------------------------
284
285testsuiteCleanup
286
287# Local Variables:
288#  mode: tcl
289#  indent-tabs-mode: nil
290# End:
291