AtlatestRepositorysigil-irc

sigil-irc / tree / testtest-sasl.sgl

1;;; Tests for SASL state machines (PLAIN + EXTERNAL).
2;;; SCRAM-SHA-256 has its own test-sasl-scram.sgl once the crypto
3;;; primitives land in sigil-crypto v0.15.
4
5(import (sigil test)
6 (sigil string)
7 (sigil crypto)
8 (sigil irc message)
9 (sigil irc sasl)
10 (sigil irc numerics))
12(test-group "SASL chunked AUTHENTICATE encoding"
14 (test "empty payload produces single + line"
15 (let ((lines (encode-authenticate-payload "")))
16 (assert-equal 1 (length lines))
17 (assert-equal "AUTHENTICATE +\r\n" (car lines))))
19 (test "short payload encodes in single line"
20 (let* ((lines (encode-authenticate-payload "hello"))
21 (joined (apply string-append lines)))
22 (assert-true (string-contains? joined "AUTHENTICATE "))
23 ;; "hello" base64-encodes to "aGVsbG8=" (8 chars; under 400).
24 (assert-equal 1 (length lines))))
26 (test "exact-multiple payload appends + terminator"
27 (let* ((payload (make-string 300 #\a)) ; base64 of 300 'a's = 400 chars
28 (lines (encode-authenticate-payload payload)))
29 (assert-equal 2 (length lines))
30 (assert-equal "AUTHENTICATE +\r\n" (cadr lines))))
32 (test "decode-authenticate-chunks reverses encoding for short payload"
33 (let* ((payload "hello world")
34 (lines (encode-authenticate-payload payload))
35 ;; Strip the AUTHENTICATE prefix + CRLF; keep only the chunk text
36 (chunks (map (lambda (line)
37 (let* ((stripped (substring line 13 (string-length line)))
38 (no-crlf (substring stripped 0 (- (string-length stripped) 2))))
39 no-crlf))
40 lines)))
41 (assert-equal payload (decode-authenticate-chunks chunks))))
43 (test "single + chunk decodes to empty"
44 (assert-equal "" (decode-authenticate-chunks (list "+")))))
47(test-group "SASL PLAIN payload"
49 (test "plain-payload format"
50 ;; authzid \0 authcid \0 password
51 (assert-equal (string-append "" (string #\null) "alice" (string #\null) "secret")
52 (plain-payload #f "alice" "secret")))
54 (test "plain-payload with explicit authzid"
55 (assert-equal (string-append "alice" (string #\null) "alice" (string #\null) "p")
56 (plain-payload "alice" "alice" "p"))))
59(test-group "SASL client state — PLAIN"
61 (test "start emits AUTHENTICATE PLAIN"
62 (let ((s (make-sasl-client-state mechanism: SASL-PLAIN
63 authcid: "alice"
64 password: "secret")))
65 (assert-equal "AUTHENTICATE PLAIN\r\n" (sasl-client-start s))
66 (assert-equal 'awaiting-server-+ (sasl-client-state-phase s))))
68 (test "server + triggers payload send"
69 (let ((s (make-sasl-client-state mechanism: SASL-PLAIN
70 authcid: "alice"
71 password: "secret")))
72 (sasl-client-start s)
73 (let ((out (sasl-client-advance s (parse-irc-message "AUTHENTICATE +"))))
74 (assert-equal 'awaiting-result (sasl-client-state-phase s))
75 (assert-true (>= (length out) 1))
76 ;; First chunk line starts with "AUTHENTICATE "
77 (let ((line (car out)))
78 (assert-true (string-contains? line "AUTHENTICATE "))))))
80 (test "903 RPL-SASLSUCCESS marks success"
81 (let ((s (make-sasl-client-state mechanism: SASL-PLAIN
82 authcid: "alice"
83 password: "secret")))
84 (sasl-client-start s)
85 (sasl-client-advance s (parse-irc-message "AUTHENTICATE +"))
86 (sasl-client-advance s
87 (parse-irc-message ":server 903 mynick :SASL authentication successful"))
88 (assert-equal 'done (sasl-client-state-phase s))
89 (assert-equal 'success (sasl-client-state-result s))))
91 (test "904 ERR-SASLFAIL marks failure"
92 (let ((s (make-sasl-client-state mechanism: SASL-PLAIN
93 authcid: "alice"
94 password: "wrong")))
95 (sasl-client-start s)
96 (sasl-client-advance s (parse-irc-message "AUTHENTICATE +"))
97 (sasl-client-advance s
98 (parse-irc-message ":server 904 mynick :SASL authentication failed"))
99 (assert-equal 'done (sasl-client-state-phase s))
100 (assert-equal 'failure (sasl-client-state-result s))))
102 (test "missing creds produces mech-fail"
103 (let ((s (make-sasl-client-state mechanism: SASL-PLAIN)))
104 (sasl-client-start s)
105 (let ((out (sasl-client-advance s (parse-irc-message "AUTHENTICATE +"))))
106 (assert-equal 'done (sasl-client-state-phase s))
107 (assert-equal 'mech-fail (sasl-client-state-result s))
108 (assert-equal "AUTHENTICATE *\r\n" (car out))))))
111(test-group "SASL client state — EXTERNAL"
113 (test "EXTERNAL with empty authzid sends + terminator only"
114 (let ((s (make-sasl-client-state mechanism: SASL-EXTERNAL)))
115 (sasl-client-start s)
116 (let ((out (sasl-client-advance s (parse-irc-message "AUTHENTICATE +"))))
117 (assert-equal 'awaiting-result (sasl-client-state-phase s))
118 ;; Empty payload encodes to single AUTHENTICATE +\r\n
119 (assert-equal "AUTHENTICATE +\r\n" (car out)))))
121 (test "EXTERNAL with explicit authzid sends base64'd authzid"
122 (let ((s (make-sasl-client-state mechanism: SASL-EXTERNAL authzid: "alice")))
123 (sasl-client-start s)
124 (let ((out (sasl-client-advance s (parse-irc-message "AUTHENTICATE +"))))
125 ;; "alice" base64 = "YWxpY2U="
126 (assert-true (string-contains? (car out) "YWxpY2U="))))))
129(test-group "SASL server state — PLAIN"
131 (define (verify-plain mech authzid authcid password)
132 (cond
133 ((not (string=? mech SASL-PLAIN)) 'failure)
134 ((and (string=? authcid "alice") (string=? password "secret")) 'success)
135 (else 'failure)))
137 (test "rejects unsupported mechanism"
138 (let ((s (make-sasl-server-state supported-mechanisms: '("PLAIN")
139 verify: verify-plain)))
140 (let ((out (sasl-server-advance s (parse-irc-message "AUTHENTICATE BOGUS")
141 client-prefix: "alice")))
142 (assert-equal 'done (sasl-server-state-phase s))
143 (assert-equal 'failure (sasl-server-state-result s))
144 (assert-true (string-contains? (car out) ERR-SASLFAIL)))))
146 (test "accepts PLAIN selection then prompts for payload"
147 (let ((s (make-sasl-server-state supported-mechanisms: '("PLAIN")
148 verify: verify-plain)))
149 (let ((out (sasl-server-advance s (parse-irc-message "AUTHENTICATE PLAIN")
150 client-prefix: "alice")))
151 (assert-equal 'awaiting-payload (sasl-server-state-phase s))
152 (assert-equal "AUTHENTICATE +\r\n" (car out)))))
154 (test "successful PLAIN flow yields RPL-LOGGEDIN + RPL-SASLSUCCESS"
155 (let* ((s (make-sasl-server-state supported-mechanisms: '("PLAIN")
156 verify: verify-plain))
157 (creds (string-append "" (string #\null) "alice" (string #\null) "secret"))
158 (encoded (base64-encode creds)))
159 (sasl-server-advance s (parse-irc-message "AUTHENTICATE PLAIN")
160 client-prefix: "alice")
161 (let ((out (sasl-server-advance s
162 (parse-irc-message
163 (string-append "AUTHENTICATE " encoded))
164 client-prefix: "alice")))
165 (assert-equal 'done (sasl-server-state-phase s))
166 (assert-equal 'success (sasl-server-state-result s))
167 (assert-equal "alice" (sasl-server-state-authcid s))
168 (assert-equal 2 (length out))
169 (assert-true (string-contains? (car out) RPL-LOGGEDIN))
170 (assert-true (string-contains? (cadr out) RPL-SASLSUCCESS)))))
172 (test "failed PLAIN flow emits ERR-SASLFAIL"
173 (let* ((s (make-sasl-server-state supported-mechanisms: '("PLAIN")
174 verify: verify-plain))
175 (creds (string-append "" (string #\null) "alice" (string #\null) "WRONG"))
176 (encoded (base64-encode creds)))
177 (sasl-server-advance s (parse-irc-message "AUTHENTICATE PLAIN")
178 client-prefix: "alice")
179 (let ((out (sasl-server-advance s
180 (parse-irc-message
181 (string-append "AUTHENTICATE " encoded))
182 client-prefix: "alice")))
183 (assert-equal 'failure (sasl-server-state-result s))
184 (assert-true (string-contains? (car out) ERR-SASLFAIL)))))
186 (test "client abort emits ERR-SASLABORTED"
187 (let ((s (make-sasl-server-state supported-mechanisms: '("PLAIN")
188 verify: verify-plain)))
189 (sasl-server-advance s (parse-irc-message "AUTHENTICATE PLAIN")
190 client-prefix: "alice")
191 (let ((out (sasl-server-advance s (parse-irc-message "AUTHENTICATE *")
192 client-prefix: "alice")))
193 (assert-equal 'aborted (sasl-server-state-result s))
194 (assert-true (string-contains? (car out) ERR-SASLABORTED))))))
196(run-tests)