Commit503c65ceRecorded27 Apr 2026Repositorysigil-irc
Add SASL state machines (PLAIN, EXTERNAL, SCRAM-SHA-256)
Message
(sigil irc sasl) — chunked AUTHENTICATE wire helpers and pure- value state machines for both client and server sides. Handles the IRCv3 400-byte base64 chunking spec including the empty-+ terminator for exact-multiple payloads.
Mechanism dispatch: PLAIN + EXTERNAL ship complete here.
SCRAM-SHA-256 dispatches to a pluggable driver via the
`scram-driver` slot on the state. Client API:
make-sasl-client-state mechanism: ... authcid: ... password: ...
sasl-client-start -> "AUTHENTICATE <mech>\r\n"
sasl-client-advance state msg -> outbound lines Server API:
make-sasl-server-state supported-mechanisms: ... verify: ...
sasl-server-advance state msg client-prefix: ... -> outbound lines result symbols: 'success / 'failure / 'aborted / 'too-long / 'already(sigil irc sasl-scram) — SCRAM-SHA-256 driver per RFC 5802 + RFC 7677. Both client and server flows.
Server side uses a `fetch` callback that returns a stored
scram-credentials record (salt-b64, iterations, stored-key,
server-key) — never touches plaintext passwords. Plaintext passwords are needed only at user registration
via `derive-scram-credentials password salt iterations`.
Persist the result; the password can then be discarded.Crypto dependencies (sigil-crypto v0.15.0+): hmac-sha256-bytes, pbkdf2-sha256, sha256-bytes, base64-encode, base64-decode, random-bytes.
The SCRAM end-to-end tests guard on crypto-primitive availability via runtime probe and skip gracefully when the running sigil binary doesn't yet bundle sigil-crypto v0.15.0 natives — avoiding a hard dependency on a particular sigil release while keeping the protocol layer ready.
Changed
src/sigil/irc/sasl-scram.sgl | 535 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/sigil/irc/sasl.sgl | 484 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
test/test-sasl-scram.sgl | 178 ++++++++++++++++++++++++++++++++++++++++++++++++++++++
test/test-sasl.sgl | 195 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
4 files changed, 1392 insertions(+)Diff
src/sigil/irc/sasl-scram.sgladded
@@ -0,0 +1,535 @@
+1
;;; (sigil irc sasl-scram) - SCRAM-SHA-256 mechanism for SASL+2
;;;+3
;;; Implements RFC 5802 + RFC 7677 (SCRAM with SHA-256). The wire dance+4
;;; is layered inside SASL's AUTHENTICATE/chunked-base64 envelope:+5
;;;+6
;;; C: AUTHENTICATE SCRAM-SHA-256+7
;;; S: AUTHENTICATE ++8
;;; C: <client-first-message>+9
;;; n,,n=alice,r=<client-nonce>+10
;;; S: <server-first-message>+11
;;; r=<combined-nonce>,s=<base64-salt>,i=<iterations>+12
;;; C: <client-final-message>+13
;;; c=<base64-channel-binding>,r=<combined-nonce>,p=<base64-proof>+14
;;; S: <server-final-message>+15
;;; v=<base64-server-signature>+16
;;; S: 903 <client> :SASL authentication successful+17
;;;+18
;;; Where:+19
;;; SaltedPassword = PBKDF2-SHA-256(password, salt, iterations, 32)+20
;;; ClientKey = HMAC-SHA-256(SaltedPassword, "Client Key")+21
;;; StoredKey = SHA-256(ClientKey)+22
;;; AuthMessage = client-first-bare + "," + server-first+23
;;; + "," + client-final-no-proof+24
;;; ClientSignature = HMAC-SHA-256(StoredKey, AuthMessage)+25
;;; ClientProof = ClientKey XOR ClientSignature+26
;;; ServerKey = HMAC-SHA-256(SaltedPassword, "Server Key")+27
;;; ServerSignature = HMAC-SHA-256(ServerKey, AuthMessage)+28
;;;+29
;;; This module exports two driver functions that plug into the core+30
;;; (sigil irc sasl) state-machine via the `scram-driver` field. The+31
;;; consumer constructs a sasl state with the SCRAM driver attached;+32
;;; the core SASL machinery dispatches into the driver at the right+33
;;; phases.+34
;;;+35
;;; Server-side `scram-fetch` callback:+36
;;; (scram-fetch authcid) -> (list <salt-b64> <iterations> <stored-key-bv> <server-key-bv>)+37
;;; or #f for unknown user+38
;;;+39
;;; A consumer-supplied scram-credentials helper computes those four+40
;;; values from a plaintext password (typically called once at user+41
;;; registration; the salted password is stored, never the plaintext).+42
+43
(define-library (sigil irc sasl-scram)+44
(import (sigil core)+45
(sigil string)+46
(sigil math)+47
(sigil struct)+48
(sigil crypto)+49
(sigil irc message)+50
(sigil irc sasl)+51
(sigil irc numerics))+52
+53
(export+54
;; Drivers — set on a sasl-{client,server}-state via scram-driver:+55
scram-client-driver+56
scram-server-driver+57
+58
;; Make a fully-wired client SASL state for SCRAM-SHA-256+59
make-scram-client-state+60
+61
;; Make a fully-wired server SASL state for SCRAM-SHA-256+62
make-scram-server-state+63
+64
;; Credential derivation helper (server-side / registration)+65
scram-credentials+66
scram-credentials-salt-b64+67
scram-credentials-iterations+68
scram-credentials-stored-key+69
scram-credentials-server-key+70
derive-scram-credentials)+71
+72
(begin+73
+74
;; ============================================================+75
;; Credential record (server-side persistence)+76
;; ============================================================+77
+78
;;; The server-side stored SCRAM verifier for one user. The plaintext+79
;;; password is NOT stored; only these four values, which are+80
;;; sufficient to verify a client's proof without the password.+81
(define-struct scram-credentials+82
(salt-b64) ; string — base64 of the per-user salt+83
(iterations) ; integer — work factor for PBKDF2+84
(stored-key) ; bytevector — H(ClientKey), 32 bytes+85
(server-key)) ; bytevector — HMAC(SaltedPassword, "Server Key"), 32 bytes+86
+87
;;; Derive SCRAM credentials from a plaintext password + per-user+88
;;; salt + iteration count. Call this at user registration; persist+89
;;; the resulting record. The plaintext password is never needed+90
;;; again on the server side.+91
;;;+92
;;; ```scheme+93
;;; (define creds (derive-scram-credentials "alice-password"+94
;;; (random-bytes 16)+95
;;; 4096))+96
;;; ;; persist (scram-credentials-salt-b64 creds), -iterations,+97
;;; ;; -stored-key, -server-key+98
;;; ```+99
(define (derive-scram-credentials password salt-bytes iterations)+100
(: string? bytevector? integer? -> scram-credentials?)+101
(let* ((salted (pbkdf2-sha256 password salt-bytes iterations 32))+102
(client-key (hmac-sha256-bytes salted "Client Key"))+103
(stored-key (sha256-bytes client-key))+104
(server-key (hmac-sha256-bytes salted "Server Key")))+105
(scram-credentials+106
salt-b64: (base64-encode salt-bytes)+107
iterations: iterations+108
stored-key: stored-key+109
server-key: server-key)))+110
+111
+112
;; ============================================================+113
;; Bytewise helpers (raw byte manipulation)+114
;; ============================================================+115
+116
(define (string->bytevector s)+117
(let* ((len (string-length s))+118
(bv (make-bytevector len 0)))+119
(let loop ((i 0))+120
(cond+121
((>= i len) bv)+122
(else+123
(bytevector-u8-set! bv i (char->integer (string-ref s i)))+124
(loop (+ i 1)))))))+125
+126
(define (bytevector=? a b)+127
(let ((la (bytevector-length a))+128
(lb (bytevector-length b)))+129
(and (= la lb)+130
(let loop ((i 0))+131
(cond+132
((>= i la) #t)+133
((= (bytevector-u8-ref a i) (bytevector-u8-ref b i))+134
(loop (+ i 1)))+135
(else #f))))))+136
+137
(define (xor-bytes a b)+138
(let* ((len (min (bytevector-length a) (bytevector-length b)))+139
(out (make-bytevector len 0)))+140
(let loop ((i 0))+141
(cond+142
((>= i len) out)+143
(else+144
(bytevector-u8-set! out i+145
(bitwise-xor (bytevector-u8-ref a i)+146
(bytevector-u8-ref b i)))+147
(loop (+ i 1)))))))+148
+149
+150
;; ============================================================+151
;; SCRAM message-format helpers+152
;; ============================================================+153
+154
;;; Parse an attribute string `k1=v1,k2=v2,...` into an alist.+155
(define (parse-scram-attrs str)+156
(map (lambda (entry)+157
(let ((eq-pos (string-index entry (lambda (c) (char=? c #\=)))))+158
(if eq-pos+159
(cons (substring entry 0 eq-pos)+160
(substring entry (+ eq-pos 1) (string-length entry)))+161
(cons entry ""))))+162
(string-split str ",")))+163
+164
(define (scram-attr-ref attrs key)+165
(let loop ((xs attrs))+166
(cond+167
((null? xs) #f)+168
((equal? (caar xs) key) (cdar xs))+169
(else (loop (cdr xs))))))+170
+171
;; Generate a random nonce: 18 random bytes -> base64 -> strip+172
;; padding. Yields a 24-char URL-safe-ish nonce. Per RFC 5802 the+173
;; nonce should be a printable string excluding the `,` separator.+174
(define (scram-make-nonce)+175
(let* ((bytes (random-bytes 18))+176
(b64 (base64-encode bytes)))+177
;; base64 alphabet excludes ',', so no further sanitation needed.+178
b64))+179
+180
;; Find the end of the gs2-header in a client-first message.+181
;; gs2-header is `n,,` or `n,a=user,` — ends after the second comma.+182
(define (scram-find-gs2-end raw)+183
(let ((len (string-length raw)))+184
(let loop ((i 0) (commas 0))+185
(cond+186
((>= i len) len)+187
((>= commas 2) i)+188
((char=? (string-ref raw i) #\,) (loop (+ i 1) (+ commas 1)))+189
(else (loop (+ i 1) commas))))))+190
+191
;; SASLprep stub: pass-through. Real SASLprep is RFC 4013 stringprep+192
;; (Unicode normalization + case-fold + bidi + prohibited-chars).+193
;; For the practical IRC username space (printable ASCII) the+194
;; identity mapping is sufficient; if Unicode usernames become+195
;; relevant, swap this for a real implementation.+196
(define (scram-saslprep s) s)+197
+198
+199
;; ============================================================+200
;; Client driver+201
;; ============================================================+202
;;+203
;; The driver is invoked by (sigil irc sasl) at SCRAM-relevant+204
;; phases. It receives:+205
;; (driver state msg)+206
;; (driver state 'start) <- when client sends initial+207
;;+208
;; The state's `phase` is one of:+209
;; 'awaiting-server-+ -> we just sent AUTHENTICATE; got + back+210
;; 'awaiting-scram-r1 -> we sent client-first; awaiting server-first+211
;; 'awaiting-scram-r2 -> we sent client-final; awaiting server-final+212
;;+213
;; Returns a list of wire-format strings to send.+214
+215
;;; Build a sasl-client-state pre-wired for SCRAM-SHA-256.+216
(define (make-scram-client-state (keys: (authcid #f)+217
(password #f)+218
(authzid #f)))+219
(: (authcid: string?) (password: string?) (authzid: any?) -> sasl-client-state?)+220
(make-sasl-client-state+221
mechanism: SASL-SCRAM-SHA-256+222
authcid: authcid+223
password: password+224
authzid: authzid+225
scram-driver: scram-client-driver))+226
+227
;; Per-state SCRAM bookkeeping is held in a side table keyed by the+228
;; state object identity. Easier than extending sasl-client-state+229
;; with SCRAM-only fields.+230
(define %client-scram-store '())+231
+232
(define (client-scram-get state)+233
(let loop ((xs %client-scram-store))+234
(cond+235
((null? xs) #f)+236
((eq? (caar xs) state) (cdar xs))+237
(else (loop (cdr xs))))))+238
+239
(define (client-scram-set! state val)+240
(set! %client-scram-store+241
(cons (cons state val)+242
(filter (lambda (e) (not (eq? (car e) state)))+243
%client-scram-store))))+244
+245
(define-struct scram-client-locals+246
(nonce default: #f mutable: #t)+247
(client-first-bare default: #f mutable: #t)+248
(server-first default: #f mutable: #t)+249
(server-signature-b64 default: #f mutable: #t))+250
+251
(define (scram-client-driver state arg . rest)+252
(cond+253
((eq? arg 'start) (client-send-client-first state))+254
((irc-message? arg) (client-handle-message state arg))+255
(else '())))+256
+257
(define (client-send-client-first state)+258
(let* ((authcid (sasl-client-state-authcid state))+259
(nonce (scram-make-nonce))+260
(gs2-header "n,,")+261
(client-first-bare+262
(string-append "n=" (scram-saslprep authcid)+263
",r=" nonce))+264
(client-first (string-append gs2-header client-first-bare))+265
(locals (scram-client-locals+266
nonce: nonce+267
client-first-bare: client-first-bare)))+268
(client-scram-set! state locals)+269
(set-sasl-client-state-phase! state 'awaiting-scram-r1)+270
(encode-authenticate-payload client-first)))+271
+272
(define (client-handle-message state msg)+273
(let ((params (irc-message-params msg)))+274
(cond+275
((eq? (irc-message-command msg) 'AUTHENTICATE)+276
(let ((arg (and (pair? params) (car params))))+277
(cond+278
((eq? (sasl-client-state-phase state) 'awaiting-scram-r1)+279
(client-process-server-first state arg))+280
((eq? (sasl-client-state-phase state) 'awaiting-scram-r2)+281
(client-process-server-final state arg))+282
(else '()))))+283
(else '()))))+284
+285
(define (client-process-server-first state chunk)+286
(let* ((server-first (decode-authenticate-chunks (list chunk)))+287
(attrs (parse-scram-attrs server-first))+288
(server-nonce (scram-attr-ref attrs "r"))+289
(salt-b64 (scram-attr-ref attrs "s"))+290
(iter-str (scram-attr-ref attrs "i"))+291
(iter (and iter-str (string->number iter-str)))+292
(locals (client-scram-get state)))+293
(cond+294
((or (not server-nonce) (not salt-b64) (not iter))+295
(client-fail state)+296
(list "AUTHENTICATE *\r\n"))+297
((not (string-starts-with? server-nonce+298
(scram-client-locals-nonce locals)))+299
(client-fail state)+300
(list "AUTHENTICATE *\r\n"))+301
(else+302
(set-scram-client-locals-server-first! locals server-first)+303
(client-send-client-final state server-nonce salt-b64 iter)))))+304
+305
(define (client-send-client-final state server-nonce salt-b64 iter)+306
(let* ((locals (client-scram-get state))+307
(password (sasl-client-state-password state))+308
(salt-decoded (base64-decode salt-b64))+309
(salt-bv (cond+310
((bytevector? salt-decoded) salt-decoded)+311
((string? salt-decoded) (string->bytevector salt-decoded))+312
(else (make-bytevector 0))))+313
(salted (pbkdf2-sha256 password salt-bv iter 32))+314
(client-key (hmac-sha256-bytes salted "Client Key"))+315
(stored-key (sha256-bytes client-key))+316
(channel-binding-b64 (base64-encode "n,,"))+317
(client-final-no-proof+318
(string-append "c=" channel-binding-b64 ",r=" server-nonce))+319
(auth-message (string-append+320
(scram-client-locals-client-first-bare locals)+321
","+322
(scram-client-locals-server-first locals)+323
","+324
client-final-no-proof))+325
(client-signature (hmac-sha256-bytes stored-key auth-message))+326
(client-proof (xor-bytes client-key client-signature))+327
(server-key (hmac-sha256-bytes salted "Server Key"))+328
(server-signature (hmac-sha256-bytes server-key auth-message))+329
(server-signature-b64 (base64-encode server-signature))+330
(client-final (string-append client-final-no-proof+331
",p=" (base64-encode client-proof))))+332
(set-scram-client-locals-server-signature-b64! locals server-signature-b64)+333
(set-sasl-client-state-phase! state 'awaiting-scram-r2)+334
(encode-authenticate-payload client-final)))+335
+336
(define (client-process-server-final state chunk)+337
(let* ((server-final (decode-authenticate-chunks (list chunk)))+338
(attrs (parse-scram-attrs server-final))+339
(v (scram-attr-ref attrs "v"))+340
(e (scram-attr-ref attrs "e"))+341
(locals (client-scram-get state))+342
(expected (scram-client-locals-server-signature-b64 locals)))+343
(cond+344
(e+345
(client-fail state)+346
'())+347
((and v (equal? v expected))+348
;; Server is authenticated to the client. We're now waiting+349
;; for the IRCv3 numeric reply (903 / 904) to know how the+350
;; server sees us. Submit an empty AUTHENTICATE +.+351
(set-sasl-client-state-phase! state 'awaiting-result)+352
(list "AUTHENTICATE +\r\n"))+353
(else+354
;; Server signature mismatch — server is not who they claim.+355
(client-fail state)+356
(list "AUTHENTICATE *\r\n")))))+357
+358
(define (client-fail state)+359
(set-sasl-client-state-result! state 'failure)+360
(set-sasl-client-state-phase! state 'done))+361
+362
+363
;; ============================================================+364
;; Server driver+365
;; ============================================================+366
;;+367
;; Dispatched as:+368
;; (driver state 'first raw client-prefix) ; got client-first+369
;; (driver state 'chunk chunk client-prefix) ; got client-final+370
;;+371
;; The server side stores per-state locals in a side table keyed by+372
;; state identity, mirroring the client side.+373
+374
(define %server-scram-store '())+375
+376
(define (server-scram-get state)+377
(let loop ((xs %server-scram-store))+378
(cond+379
((null? xs) #f)+380
((eq? (caar xs) state) (cdar xs))+381
(else (loop (cdr xs))))))+382
+383
(define (server-scram-set! state val)+384
(set! %server-scram-store+385
(cons (cons state val)+386
(filter (lambda (e) (not (eq? (car e) state)))+387
%server-scram-store))))+388
+389
(define-struct scram-server-locals+390
(server-nonce default: #f mutable: #t)+391
(client-first-bare default: #f mutable: #t)+392
(server-first default: #f mutable: #t)+393
(stored-key default: #f mutable: #t)+394
(server-key default: #f mutable: #t))+395
+396
;;; Construct a sasl-server-state pre-wired for SCRAM-SHA-256.+397
;;; `fetch` is `(lambda (authcid) -> scram-credentials? or #f)`.+398
(define (make-scram-server-state (keys: (server-name "*")+399
(fetch #f)+400
(additional-mechanisms '())))+401
(: (server-name: string?) (fetch: any?) (additional-mechanisms: list?) -> sasl-server-state?)+402
(unless fetch+403
(error "make-scram-server-state: fetch: callback is required"))+404
(let* ((mechs (cons SASL-SCRAM-SHA-256 additional-mechanisms))+405
(state (make-sasl-server-state+406
supported-mechanisms: mechs+407
server-name: server-name+408
scram-driver: scram-server-driver)))+409
;; Stash the fetch callback on the state via the side table.+410
(server-scram-set! state (scram-server-locals))+411
;; Also stash fetch in a parallel binding — we need it during+412
;; first-message handling.+413
(scram-server-attach-fetch! state fetch)+414
state))+415
+416
(define %server-fetch-store '())+417
(define (scram-server-attach-fetch! state fetch)+418
(set! %server-fetch-store+419
(cons (cons state fetch)+420
(filter (lambda (e) (not (eq? (car e) state)))+421
%server-fetch-store))))+422
(define (scram-server-fetch state)+423
(let loop ((xs %server-fetch-store))+424
(cond+425
((null? xs) #f)+426
((eq? (caar xs) state) (cdar xs))+427
(else (loop (cdr xs))))))+428
+429
(define (scram-server-driver state phase . args)+430
(cond+431
((eq? phase 'first)+432
(let ((raw (car args))+433
(client-prefix (cadr args)))+434
(server-process-client-first state raw client-prefix)))+435
((eq? phase 'chunk)+436
(let ((chunk (car args))+437
(client-prefix (cadr args)))+438
(server-process-client-final state chunk client-prefix)))+439
(else '())))+440
+441
(define (server-process-client-first state raw client-prefix)+442
(let* ((gs2-end (scram-find-gs2-end raw))+443
(client-first-bare (substring raw gs2-end (string-length raw)))+444
(attrs (parse-scram-attrs client-first-bare))+445
(n (scram-attr-ref attrs "n"))+446
(r (scram-attr-ref attrs "r")))+447
(cond+448
((or (not n) (not r))+449
(server-fail state ERR-SASLFAIL "Malformed SCRAM client-first" client-prefix))+450
(else+451
(set-sasl-server-state-authcid! state n)+452
(let* ((fetch (scram-server-fetch state))+453
(creds (and fetch (fetch n))))+454
(cond+455
((not creds)+456
(server-fail state ERR-SASLFAIL "Unknown user" client-prefix))+457
(else+458
(let* ((server-nonce (string-append r (scram-make-nonce)))+459
(server-first (string-append "r=" server-nonce+460
",s=" (scram-credentials-salt-b64 creds)+461
",i=" (number->string (scram-credentials-iterations creds))))+462
(locals (or (server-scram-get state)+463
(scram-server-locals))))+464
(set-scram-server-locals-server-nonce! locals server-nonce)+465
(set-scram-server-locals-client-first-bare! locals client-first-bare)+466
(set-scram-server-locals-server-first! locals server-first)+467
(set-scram-server-locals-stored-key! locals (scram-credentials-stored-key creds))+468
(set-scram-server-locals-server-key! locals (scram-credentials-server-key creds))+469
(server-scram-set! state locals)+470
(set-sasl-server-state-phase! state 'awaiting-mech-step)+471
(encode-authenticate-payload server-first)))))))))+472
+473
(define (server-process-client-final state chunk client-prefix)+474
(let* ((client-final (decode-authenticate-chunks (list chunk)))+475
(attrs (parse-scram-attrs client-final))+476
(proof-b64 (scram-attr-ref attrs "p"))+477
(channel-binding (scram-attr-ref attrs "c"))+478
(r (scram-attr-ref attrs "r"))+479
(locals (server-scram-get state)))+480
(cond+481
((or (not proof-b64) (not r))+482
(server-fail state ERR-SASLFAIL "Malformed SCRAM client-final" client-prefix))+483
((not (equal? r (scram-server-locals-server-nonce locals)))+484
(server-fail state ERR-SASLFAIL "SCRAM nonce mismatch" client-prefix))+485
(else+486
(let* ((client-final-no-proof+487
(string-append "c=" channel-binding ",r=" r))+488
(auth-message (string-append+489
(scram-server-locals-client-first-bare locals)+490
","+491
(scram-server-locals-server-first locals)+492
","+493
client-final-no-proof))+494
(stored-key (scram-server-locals-stored-key locals))+495
(server-key (scram-server-locals-server-key locals))+496
(client-signature (hmac-sha256-bytes stored-key auth-message))+497
(proof-bytes (let ((d (base64-decode proof-b64)))+498
(cond+499
((bytevector? d) d)Showing the first 500 of 536 diff lines for this file. This diff is INCOMPLETE; read the file or clone the repository for the rest.
src/sigil/irc/sasl.sgladded
@@ -0,0 +1,484 @@
+1
;;; (sigil irc sasl) - SASL authentication state machines+2
;;;+3
;;; SASL is the AUTHENTICATE-based authentication protocol used by+4
;;; IRCv3. The on-the-wire pattern, in both directions, is:+5
;;;+6
;;; <- AUTHENTICATE PLAIN (client picks mechanism)+7
;;; -> AUTHENTICATE + (server says: send payload)+8
;;; <- AUTHENTICATE <base64-chunk> (client sends payload, in+9
;;; AUTHENTICATE <next-chunk> 400-byte base64 chunks)+10
;;; ...+11
;;; AUTHENTICATE + (last chunk shorter than 400+12
;;; OR an explicit empty `+`+13
;;; when the payload was an+14
;;; exact multiple of 400)+15
;;; -> 900 / 903 (success — RPL-LOGGEDIN /+16
;;; RPL-SASLSUCCESS)+17
;;; OR 902/904/905/906/907 (failure)+18
;;;+19
;;; Mechanisms supported here:+20
;;;+21
;;; PLAIN base64(authzid \0 authcid \0 password) — ships fully+22
;;; EXTERNAL base64(authzid) (TLS client cert) — ships fully+23
;;; SCRAM-SHA-256 RFC 5802 challenge-response — see (sigil irc sasl-scram)+24
;;;+25
;;; The state machines are pure values: state + `advance` returning+26
;;; outbound wire strings. The consumer owns I/O.+27
+28
(define-library (sigil irc sasl)+29
(import (sigil core)+30
(sigil math)+31
(sigil string)+32
(sigil struct)+33
(sigil crypto)+34
(sigil irc message)+35
(sigil irc numerics))+36
+37
(export+38
;; Mechanism names+39
SASL-PLAIN+40
SASL-EXTERNAL+41
SASL-SCRAM-SHA-256+42
+43
;; Chunked AUTHENTICATE encoding+44
encode-authenticate-payload+45
decode-authenticate-chunks+46
+47
;; PLAIN payload helpers+48
plain-payload+49
parse-plain-payload+50
+51
;; Client SASL state+52
sasl-client-state+53
sasl-client-state?+54
make-sasl-client-state+55
sasl-client-state-mechanism+56
sasl-client-state-phase+57
sasl-client-state-result+58
sasl-client-state-authcid+59
sasl-client-start+60
sasl-client-advance+61
+62
;; Server SASL state+63
sasl-server-state+64
sasl-server-state?+65
make-sasl-server-state+66
sasl-server-state-mechanism+67
sasl-server-state-phase+68
sasl-server-state-result+69
sasl-server-state-authcid+70
sasl-server-advance)+71
+72
(begin+73
+74
(define SASL-PLAIN "PLAIN")+75
(define SASL-EXTERNAL "EXTERNAL")+76
(define SASL-SCRAM-SHA-256 "SCRAM-SHA-256")+77
+78
(define %nul (string #\null))+79
+80
+81
;; ============================================================+82
;; Chunked AUTHENTICATE payload encoding+83
;; ============================================================+84
+85
;;; Encode a raw payload (string) as a list of `AUTHENTICATE` lines+86
;;; per the IRCv3 SASL chunking rules. Each line carries up to 400+87
;;; base64 chars; if the encoded payload length is an exact multiple+88
;;; of 400, an additional `AUTHENTICATE +\r\n` is appended as the+89
;;; explicit terminator. An empty payload produces a single+90
;;; `AUTHENTICATE +\r\n`.+91
;;;+92
;;; Returns a list of complete wire-format lines (each ending in+93
;;; CRLF). The consumer writes them in order.+94
(define (encode-authenticate-payload payload)+95
(: string? -> list?)+96
(let ((encoded (base64-encode payload)))+97
(if (string=? encoded "")+98
(list "AUTHENTICATE +\r\n")+99
(let* ((len (string-length encoded))+100
(chunk-size 400)+101
(rem (remainder len chunk-size)))+102
(let loop ((i 0) (acc '()))+103
(cond+104
((>= i len)+105
(if (= rem 0)+106
(reverse (cons "AUTHENTICATE +\r\n" acc))+107
(reverse acc)))+108
(else+109
(let* ((end (min (+ i chunk-size) len))+110
(chunk (substring encoded i end))+111
(line (string-append "AUTHENTICATE " chunk "\r\n")))+112
(loop end (cons line acc))))))))))+113
+114
;;; Reassemble a list of incoming AUTHENTICATE chunk strings (just the+115
;;; base64 portion of each, without the `AUTHENTICATE` keyword) into+116
;;; the decoded raw payload. A trailing `+` chunk is the terminator+117
;;; and is stripped before decoding. A single `+` chunk by itself is+118
;;; treated as an empty payload signal.+119
;;;+120
;;; Returns a string. (sigil-crypto's `base64-decode` returns a+121
;;; bytevector for arbitrary inputs; we convert here so the payload+122
;;; is consumable by `string-split` etc.)+123
(define (decode-authenticate-chunks chunks)+124
(: list? -> string?)+125
(let* ((stripped (if (and (pair? chunks)+126
(equal? (car (reverse chunks)) "+"))+127
(reverse (cdr (reverse chunks)))+128
chunks))+129
(joined (apply string-append stripped)))+130
(if (string=? joined "")+131
""+132
(let ((decoded (base64-decode joined)))+133
(cond+134
((string? decoded) decoded)+135
((bytevector? decoded) (bytevector->utf8-string decoded))+136
(else ""))))))+137
+138
;; Convert a bytevector to a string, treating each byte as a Unicode+139
;; code point in the 0..255 range (latin-1-ish). For SASL PLAIN /+140
;; EXTERNAL payloads this is correct because the on-wire bytes are+141
;; UTF-8 already; for SCRAM, all interesting bytes are within ASCII.+142
(define (bytevector->utf8-string bv)+143
(let ((len (bytevector-length bv)))+144
(let loop ((i 0) (acc '()))+145
(cond+146
((>= i len) (apply string (reverse acc)))+147
(else+148
(loop (+ i 1)+149
(cons (integer->char (bytevector-u8-ref bv i)) acc)))))))+150
+151
+152
;; ============================================================+153
;; Mechanism payload helpers+154
;; ============================================================+155
+156
;;; Build the raw PLAIN payload (pre-base64): authzid \0 authcid \0 password.+157
;;; `authzid` may be `#f` (empty); `authcid` and `password` are required.+158
(define (plain-payload authzid authcid password)+159
(: any? string? string? -> string?)+160
(string-append (or authzid "") %nul authcid %nul password))+161
+162
;;; Parse a raw PLAIN payload back into (authzid authcid password).+163
;;; Returns three values; if malformed, returns three #f values.+164
(define (parse-plain-payload raw)+165
(: string? -> any?)+166
(let ((parts (string-split raw %nul)))+167
(if (= (length parts) 3)+168
(values (car parts) (cadr parts) (caddr parts))+169
(values #f #f #f))))+170
+171
+172
;; ============================================================+173
;; Client state+174
;; ============================================================+175
;;+176
;; Phases:+177
;; 'init — call sasl-client-start to send mechanism+178
;; 'awaiting-server-+ — sent AUTHENTICATE <mech>; awaiting ++179
;; 'awaiting-result — sent payload; awaiting 900/903/904 etc.+180
;; 'done — terminal; check `result`+181
;;+182
;; `result` after 'done is one of:+183
;; 'success authentication succeeded (903 RPL-SASLSUCCESS)+184
;; 'failure server rejected (904)+185
;; 'aborted server aborted (906)+186
;; 'too-long payload too long (905)+187
;; 'already already authenticated (907)+188
;; 'mech-fail client could not produce payload (e.g. missing creds)+189
+190
(define-struct sasl-client-state+191
(mechanism) ; string+192
(authcid default: #f) ; username (PLAIN/SCRAM)+193
(password default: #f) ; password (PLAIN/SCRAM)+194
(authzid default: #f) ; optional impersonation id+195
(phase default: 'init mutable: #t)+196
(result default: #f mutable: #t)+197
;; Provided by (sigil irc sasl-scram) when SCRAM is in use.+198
;; The protocol layer holds a reference but does not call into it+199
;; directly so this module remains crypto-free for PLAIN/EXTERNAL.+200
(scram-driver default: #f mutable: #t))+201
+202
;;; Construct a client SASL state. `mechanism` must be one of the+203
;;; SASL-* constants. For PLAIN/SCRAM-SHA-256 supply `authcid:` and+204
;;; `password:`; for EXTERNAL supply only `authzid:` if you want to+205
;;; assert a specific identity (otherwise empty = use the cert's CN).+206
(define (make-sasl-client-state (keys: (mechanism #f)+207
(authcid #f)+208
(password #f)+209
(authzid #f)+210
(scram-driver #f)))+211
(: (mechanism: string?) (authcid: any?) (password: any?) (authzid: any?) (scram-driver: any?) -> sasl-client-state?)+212
(unless mechanism+213
(error "make-sasl-client-state: mechanism: is required"))+214
(sasl-client-state mechanism: mechanism+215
authcid: authcid+216
password: password+217
authzid: authzid+218
scram-driver: scram-driver))+219
+220
;;; Begin SASL: returns the `AUTHENTICATE <mech>\r\n` line to send,+221
;;; transitions to the `'awaiting-server-+` phase. The CAP layer is+222
;;; expected to have already negotiated `sasl`.+223
(define (sasl-client-start state)+224
(: sasl-client-state? -> string?)+225
(set-sasl-client-state-phase! state 'awaiting-server-+)+226
(string-append "AUTHENTICATE "+227
(sasl-client-state-mechanism state)+228
"\r\n"))+229
+230
;;; Process one incoming message and advance the state. Returns a+231
;;; list of wire-format strings to send.+232
(define (sasl-client-advance state msg)+233
(: sasl-client-state? irc-message? -> list?)+234
(let ((cmd (irc-message-command msg)))+235
(cond+236
((eq? cmd 'AUTHENTICATE) (client-handle-authenticate state msg))+237
((eq? cmd (string->symbol RPL-LOGGEDIN)) '())+238
((eq? cmd (string->symbol RPL-LOGGEDOUT)) '())+239
((eq? cmd (string->symbol RPL-SASLSUCCESS))+240
(set-sasl-client-state-result! state 'success)+241
(set-sasl-client-state-phase! state 'done)+242
'())+243
((eq? cmd (string->symbol ERR-SASLFAIL))+244
(set-sasl-client-state-result! state 'failure)+245
(set-sasl-client-state-phase! state 'done)+246
'())+247
((eq? cmd (string->symbol ERR-SASLTOOLONG))+248
(set-sasl-client-state-result! state 'too-long)+249
(set-sasl-client-state-phase! state 'done)+250
'())+251
((eq? cmd (string->symbol ERR-SASLABORTED))+252
(set-sasl-client-state-result! state 'aborted)+253
(set-sasl-client-state-phase! state 'done)+254
'())+255
((eq? cmd (string->symbol ERR-SASLALREADY))+256
(set-sasl-client-state-result! state 'already)+257
(set-sasl-client-state-phase! state 'done)+258
'())+259
(else '()))))+260
+261
(define (client-handle-authenticate state msg)+262
(let* ((params (irc-message-params msg))+263
(arg (and (pair? params) (car params))))+264
(cond+265
((equal? arg "+") (client-send-initial-payload state))+266
;; Mechanism-specific challenge handling (e.g. SCRAM):+267
;; delegate to the scram-driver if present.+268
((sasl-client-state-scram-driver state)+269
(let ((handler (sasl-client-state-scram-driver state)))+270
(handler state msg)))+271
(else '()))))+272
+273
(define (client-send-initial-payload state)+274
(let ((mech (sasl-client-state-mechanism state)))+275
(cond+276
((string=? mech SASL-PLAIN)+277
(let ((authcid (sasl-client-state-authcid state))+278
(password (sasl-client-state-password state)))+279
(cond+280
((or (not authcid) (not password))+281
(set-sasl-client-state-result! state 'mech-fail)+282
(set-sasl-client-state-phase! state 'done)+283
(list "AUTHENTICATE *\r\n"))+284
(else+285
(set-sasl-client-state-phase! state 'awaiting-result)+286
(encode-authenticate-payload+287
(plain-payload (sasl-client-state-authzid state)+288
authcid+289
password))))))+290
((string=? mech SASL-EXTERNAL)+291
(set-sasl-client-state-phase! state 'awaiting-result)+292
(encode-authenticate-payload+293
(or (sasl-client-state-authzid state) "")))+294
((string=? mech SASL-SCRAM-SHA-256)+295
(cond+296
((sasl-client-state-scram-driver state)+297
=> (lambda (handler) (handler state 'start)))+298
(else+299
(set-sasl-client-state-result! state 'mech-fail)+300
(set-sasl-client-state-phase! state 'done)+301
(list "AUTHENTICATE *\r\n"))))+302
(else+303
(set-sasl-client-state-result! state 'mech-fail)+304
(set-sasl-client-state-phase! state 'done)+305
(list "AUTHENTICATE *\r\n")))))+306
+307
+308
;; ============================================================+309
;; Server state+310
;; ============================================================+311
;;+312
;; Phases:+313
;; 'init — awaiting AUTHENTICATE <mechanism>+314
;; 'awaiting-payload — sent +; awaiting client's payload chunks+315
;; 'awaiting-mech-step — mechanism-specific intermediate (e.g. SCRAM)+316
;; 'done — terminal; check `result`+317
;;+318
;; The server is constructed with a `verify` callback that takes+319
;; (mechanism authzid authcid password-or-#f) and returns a result+320
;; symbol: 'success or 'failure. For SCRAM, the consumer wires up+321
;; (sigil irc sasl-scram) which provides its own server driver.+322
+323
(define-struct sasl-server-state+324
(supported-mechanisms default: '("PLAIN")) ; list of allowed mechanism names+325
(mechanism default: #f mutable: #t) ; selected by client+326
(phase default: 'init mutable: #t)+327
(result default: #f mutable: #t)+328
(verify default: #f) ; (lambda (mech authzid authcid pw) ...)+329
(chunks default: '() mutable: #t)+330
(authcid default: #f mutable: #t)+331
(server-name default: "*")+332
;; Provided by (sigil irc sasl-scram) when SCRAM is in use.+333
(scram-driver default: #f mutable: #t))+334
+335
(define (make-sasl-server-state (keys: (supported-mechanisms '("PLAIN"))+336
(verify #f)+337
(server-name "*")+338
(scram-driver #f)))+339
(: (supported-mechanisms: list?) (verify: any?) (server-name: string?) (scram-driver: any?) -> sasl-server-state?)+340
(sasl-server-state supported-mechanisms: supported-mechanisms+341
verify: verify+342
server-name: server-name+343
scram-driver: scram-driver))+344
+345
;;; Process one incoming AUTHENTICATE and advance the state.+346
;;; Returns a list of wire-format strings to send back. `client-prefix`+347
;;; is the client's nick (or `*` if unknown) used in numeric prefixes.+348
(define (sasl-server-advance state msg (keys: (client-prefix "*")))+349
(: sasl-server-state? irc-message? (client-prefix: string?) -> list?)+350
(let ((cmd (irc-message-command msg)))+351
(cond+352
((eq? cmd 'AUTHENTICATE)+353
(server-handle-authenticate state msg client-prefix))+354
(else '()))))+355
+356
(define (server-handle-authenticate state msg client-prefix)+357
(let* ((params (irc-message-params msg))+358
(arg (and (pair? params) (car params))))+359
(cond+360
((not arg) '())+361
((equal? arg "*")+362
;; Client abort+363
(set-sasl-server-state-result! state 'aborted)+364
(set-sasl-server-state-phase! state 'done)+365
(list (server-numeric-line client-prefix ERR-SASLABORTED+366
"SASL authentication aborted")))+367
((eq? (sasl-server-state-phase state) 'init)+368
(server-select-mechanism state arg client-prefix))+369
(else+370
(server-receive-chunk state arg client-prefix)))))+371
+372
(define (server-select-mechanism state mech client-prefix)+373
(cond+374
((not (member mech (sasl-server-state-supported-mechanisms state)))+375
(set-sasl-server-state-result! state 'failure)+376
(set-sasl-server-state-phase! state 'done)+377
(list (server-numeric-line client-prefix ERR-SASLFAIL+378
"SASL mechanism not supported")))+379
(else+380
(set-sasl-server-state-mechanism! state mech)+381
(set-sasl-server-state-phase! state 'awaiting-payload)+382
(list "AUTHENTICATE +\r\n"))))+383
+384
(define (server-receive-chunk state chunk client-prefix)+385
(cond+386
((eq? (sasl-server-state-phase state) 'awaiting-payload)+387
(server-collect-and-process state chunk client-prefix))+388
((eq? (sasl-server-state-phase state) 'awaiting-mech-step)+389
;; Delegate mid-flow chunks to the SCRAM driver if present.+390
(cond+391
((sasl-server-state-scram-driver state)+392
=> (lambda (driver)+393
(driver state 'chunk chunk client-prefix)))+394
(else '())))+395
(else '())))+396
+397
(define (server-collect-and-process state chunk client-prefix)+398
(let* ((is-terminator (equal? chunk "+"))+399
(is-final (or is-terminator+400
(< (string-length chunk) 400)))+401
(collected (append (sasl-server-state-chunks state) (list chunk))))+402
(set-sasl-server-state-chunks! state collected)+403
(if (not is-final)+404
'()+405
(let ((raw (decode-authenticate-chunks collected)))+406
(set-sasl-server-state-chunks! state '())+407
(server-process-payload state raw client-prefix)))))+408
+409
(define (server-process-payload state raw client-prefix)+410
(let ((mech (sasl-server-state-mechanism state)))+411
(cond+412
((string=? mech SASL-PLAIN)+413
(server-process-plain state raw client-prefix))+414
((string=? mech SASL-EXTERNAL)+415
(server-process-external state raw client-prefix))+416
((string=? mech SASL-SCRAM-SHA-256)+417
(cond+418
((sasl-server-state-scram-driver state)+419
=> (lambda (driver)+420
(driver state 'first raw client-prefix)))+421
(else+422
(set-sasl-server-state-result! state 'failure)+423
(set-sasl-server-state-phase! state 'done)+424
(list (server-numeric-line client-prefix ERR-SASLFAIL+425
"SCRAM driver not configured")))))+426
(else+427
(set-sasl-server-state-result! state 'failure)+428
(set-sasl-server-state-phase! state 'done)+429
(list (server-numeric-line client-prefix ERR-SASLFAIL+430
"Unsupported SASL mechanism"))))))+431
+432
(define (server-process-plain state raw client-prefix)+433
(let-values (((authzid authcid password) (parse-plain-payload raw)))+434
(cond+435
((not authcid)+436
(set-sasl-server-state-result! state 'failure)+437
(set-sasl-server-state-phase! state 'done)+438
(list (server-numeric-line client-prefix ERR-SASLFAIL+439
"Malformed PLAIN payload")))+440
(else+441
(set-sasl-server-state-authcid! state authcid)+442
(let ((verdict (and (sasl-server-state-verify state)+443
((sasl-server-state-verify state)+444
SASL-PLAIN authzid authcid password))))+445
(server-finish state verdict authcid client-prefix))))))+446
+447
(define (server-process-external state raw client-prefix)+448
;; raw is the asserted authzid (possibly empty). Verifier resolves+449
;; the certificate identity and decides.+450
(let* ((authzid raw))+451
(set-sasl-server-state-authcid! state authzid)+452
(let ((verdict (and (sasl-server-state-verify state)+453
((sasl-server-state-verify state)+454
SASL-EXTERNAL authzid authzid #f))))+455
(server-finish state verdict authzid client-prefix))))+456
+457
(define (server-finish state verdict authcid client-prefix)+458
(cond+459
((eq? verdict 'success)+460
(set-sasl-server-state-result! state 'success)+461
(set-sasl-server-state-phase! state 'done)+462
(list (server-loggedin-line client-prefix authcid)+463
(server-numeric-line client-prefix RPL-SASLSUCCESS+464
"SASL authentication successful")))+465
(else+466
(set-sasl-server-state-result! state 'failure)+467
(set-sasl-server-state-phase! state 'done)+468
(list (server-numeric-line client-prefix ERR-SASLFAIL+469
"SASL authentication failed")))))+470
+471
+472
;; ============================================================+473
;; Wire-line helpers+474
;; ============================================================+475
+476
(define (server-numeric-line client-prefix code text)+477
(string-append code " " client-prefix " :" text "\r\n"))+478
+479
(define (server-loggedin-line client-prefix authcid)+480
(string-append RPL-LOGGEDIN " " client-prefix " " client-prefix " "+481
authcid " :You are now logged in as "+482
authcid "\r\n"))+483
+484
))test/test-sasl-scram.sgladded
@@ -0,0 +1,178 @@
+1
;;; Tests for SCRAM-SHA-256 SASL mechanism (RFC 5802 / RFC 7677).+2
;;;+3
;;; The protocol-layer module loads regardless of crypto-primitive+4
;;; availability. The end-to-end handshake tests require the+5
;;; `pbkdf2-sha256` and `hmac-sha256-bytes` natives shipped in+6
;;; sigil-crypto v0.15.0+; older runtimes skip those tests+7
;;; gracefully. Once a sigil release that bundles sigil-crypto+8
;;; v0.15.0 lands, the tests activate automatically.+9
+10
(import (sigil test)+11
(sigil core)+12
(sigil crypto)+13
(sigil irc message)+14
(sigil irc sasl)+15
(sigil irc sasl-scram)+16
(sigil irc numerics))+17
+18
(define (scram-natives-available?)+19
;; pbkdf2-sha256 + hmac-sha256-bytes are both v0.15.0 additions.+20
;; If either is unbound the bytecode compiler raised at this file's+21
;; load — but if we got here the symbols must be at least addressable.+22
;; Probe by attempting a minimal call inside a guard.+23
(guard (exn (else #f))+24
(let ((bv (hmac-sha256-bytes "k" "m")))+25
(and (bytevector? bv) (= 32 (bytevector-length bv))))))+26
+27
+28
(test-group "sasl-scram module loads"+29
(test "scram-client-driver is a procedure"+30
(assert-true (procedure? scram-client-driver)))+31
(test "scram-server-driver is a procedure"+32
(assert-true (procedure? scram-server-driver)))+33
(test "make-scram-client-state is a procedure"+34
(assert-true (procedure? make-scram-client-state)))+35
(test "make-scram-server-state is a procedure"+36
(assert-true (procedure? make-scram-server-state)))+37
(test "derive-scram-credentials is a procedure"+38
(assert-true (procedure? derive-scram-credentials))))+39
+40
+41
;; ============================================================+42
;; Crypto-dependent tests — guarded+43
;; ============================================================+44
;;+45
;; The remaining tests exercise the actual cryptographic verification+46
;; flow. They require sigil-crypto v0.15.0+ (`pbkdf2-sha256` ++47
;; `hmac-sha256-bytes`). When the running sigil binary doesn't+48
;; bundle those natives, we mark the tests pending.+49
+50
(cond+51
((scram-natives-available?)+52
+53
(test-group "derive-scram-credentials"+54
+55
(test "produces all four fields"+56
(let* ((salt (random-bytes 16))+57
(creds (derive-scram-credentials "password" salt 1000)))+58
(assert-true (string? (scram-credentials-salt-b64 creds)))+59
(assert-equal 1000 (scram-credentials-iterations creds))+60
(assert-true (bytevector? (scram-credentials-stored-key creds)))+61
(assert-equal 32 (bytevector-length (scram-credentials-stored-key creds)))+62
(assert-true (bytevector? (scram-credentials-server-key creds)))+63
(assert-equal 32 (bytevector-length (scram-credentials-server-key creds)))))+64
+65
(test "deterministic for same inputs"+66
(let* ((salt (random-bytes 16))+67
(a (derive-scram-credentials "password" salt 1000))+68
(b (derive-scram-credentials "password" salt 1000)))+69
(assert-equal (scram-credentials-stored-key a)+70
(scram-credentials-stored-key b))+71
(assert-equal (scram-credentials-server-key a)+72
(scram-credentials-server-key b))))+73
+74
(test "different password yields different keys"+75
(let* ((salt (random-bytes 16))+76
(a (derive-scram-credentials "alice-pw" salt 1000))+77
(b (derive-scram-credentials "BAD-pw" salt 1000)))+78
(assert-false (equal? (scram-credentials-stored-key a)+79
(scram-credentials-stored-key b))))))+80
+81
+82
(test-group "SCRAM-SHA-256 end-to-end handshake"+83
+84
(test "correct password → both sides succeed"+85
(let* ((password "correct horse battery staple")+86
(salt (random-bytes 16))+87
(creds (derive-scram-credentials password salt 1000))+88
(fetch (lambda (id)+89
(cond ((equal? id "alice") creds) (else #f))))+90
(client (make-scram-client-state authcid: "alice" password: password))+91
(server (make-scram-server-state server-name: "test" fetch: fetch))+92
(server-inbox (list (sasl-client-start client)))+93
(client-inbox '()))+94
(let loop ((iter 0))+95
(cond+96
((> iter 30) #f)+97
((and (eq? (sasl-client-state-phase client) 'done)+98
(eq? (sasl-server-state-phase server) 'done))+99
#t)+100
((pair? server-inbox)+101
(let* ((line (car server-inbox))+102
(stripped (substring line 0 (- (string-length line) 2)))+103
(msg (parse-irc-message stripped))+104
(out (sasl-server-advance server msg client-prefix: "alice")))+105
(set! server-inbox (cdr server-inbox))+106
(set! client-inbox (append client-inbox out))+107
(loop (+ iter 1))))+108
((pair? client-inbox)+109
(let* ((line (car client-inbox))+110
(stripped (substring line 0 (- (string-length line) 2)))+111
(msg (parse-irc-message stripped))+112
(out (sasl-client-advance client msg)))+113
(set! client-inbox (cdr client-inbox))+114
(set! server-inbox (append server-inbox out))+115
(loop (+ iter 1))))+116
(else #f)))+117
(assert-equal 'success (sasl-client-state-result client))+118
(assert-equal 'success (sasl-server-state-result server))+119
(assert-equal "alice" (sasl-server-state-authcid server))))+120
+121
(test "wrong password → both sides fail"+122
(let* ((salt (random-bytes 16))+123
(creds (derive-scram-credentials "real-pw" salt 1000))+124
(fetch (lambda (id)+125
(cond ((equal? id "alice") creds) (else #f))))+126
(client (make-scram-client-state authcid: "alice" password: "WRONG-pw"))+127
(server (make-scram-server-state server-name: "test" fetch: fetch))+128
(server-inbox (list (sasl-client-start client)))+129
(client-inbox '()))+130
(let loop ((iter 0))+131
(cond+132
((> iter 30) #f)+133
((eq? (sasl-server-state-phase server) 'done) #t)+134
((pair? server-inbox)+135
(let* ((line (car server-inbox))+136
(stripped (substring line 0 (- (string-length line) 2)))+137
(msg (parse-irc-message stripped))+138
(out (sasl-server-advance server msg client-prefix: "alice")))+139
(set! server-inbox (cdr server-inbox))+140
(set! client-inbox (append client-inbox out))+141
(loop (+ iter 1))))+142
((pair? client-inbox)+143
(let* ((line (car client-inbox))+144
(stripped (substring line 0 (- (string-length line) 2)))+145
(msg (parse-irc-message stripped))+146
(out (sasl-client-advance client msg)))+147
(set! client-inbox (cdr client-inbox))+148
(set! server-inbox (append server-inbox out))+149
(loop (+ iter 1))))+150
(else #f)))+151
(assert-equal 'failure (sasl-server-state-result server))))+152
+153
(test "unknown user → server emits failure on first-message"+154
(let* ((fetch (lambda (id) #f))+155
(client (make-scram-client-state authcid: "ghost" password: "x"))+156
(server (make-scram-server-state server-name: "test" fetch: fetch)))+157
;; AUTHENTICATE SCRAM-SHA-256 → server sends ++158
(sasl-server-advance server+159
(parse-irc-message (string-append+160
(substring (sasl-client-start client) 0+161
(- (string-length (sasl-client-start client)) 2))))+162
client-prefix: "ghost")+163
;; Client builds client-first+164
(let* ((client-first-out+165
(sasl-client-advance client (parse-irc-message "AUTHENTICATE +")))+166
(line (car client-first-out))+167
(stripped (substring line 0 (- (string-length line) 2)))+168
(msg (parse-irc-message stripped)))+169
(sasl-server-advance server msg client-prefix: "ghost")+170
(assert-equal 'failure (sasl-server-state-result server))))))+171
+172
)+173
+174
(else+175
(test-group "SCRAM-SHA-256 crypto-dependent tests"+176
(test-pending "skipped: requires sigil-crypto v0.15.0+ natives (pbkdf2-sha256, hmac-sha256-bytes)"))))+177
+178
(run-tests)test/test-sasl.sgladded
@@ -0,0 +1,195 @@
+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 crypto)+7
(sigil irc message)+8
(sigil irc sasl)+9
(sigil irc numerics))+10
+11
(test-group "SASL chunked AUTHENTICATE encoding"+12
+13
(test "empty payload produces single + line"+14
(let ((lines (encode-authenticate-payload "")))+15
(assert-equal 1 (length lines))+16
(assert-equal "AUTHENTICATE +\r\n" (car lines))))+17
+18
(test "short payload encodes in single line"+19
(let* ((lines (encode-authenticate-payload "hello"))+20
(joined (apply string-append lines)))+21
(assert-true (string-contains? joined "AUTHENTICATE "))+22
;; "hello" base64-encodes to "aGVsbG8=" (8 chars; under 400).+23
(assert-equal 1 (length lines))))+24
+25
(test "exact-multiple payload appends + terminator"+26
(let* ((payload (make-string 300 #\a)) ; base64 of 300 'a's = 400 chars+27
(lines (encode-authenticate-payload payload)))+28
(assert-equal 2 (length lines))+29
(assert-equal "AUTHENTICATE +\r\n" (cadr lines))))+30
+31
(test "decode-authenticate-chunks reverses encoding for short payload"+32
(let* ((payload "hello world")+33
(lines (encode-authenticate-payload payload))+34
;; Strip the AUTHENTICATE prefix + CRLF; keep only the chunk text+35
(chunks (map (lambda (line)+36
(let* ((stripped (substring line 13 (string-length line)))+37
(no-crlf (substring stripped 0 (- (string-length stripped) 2))))+38
no-crlf))+39
lines)))+40
(assert-equal payload (decode-authenticate-chunks chunks))))+41
+42
(test "single + chunk decodes to empty"+43
(assert-equal "" (decode-authenticate-chunks (list "+")))))+44
+45
+46
(test-group "SASL PLAIN payload"+47
+48
(test "plain-payload format"+49
;; authzid \0 authcid \0 password+50
(assert-equal (string-append "" (string #\null) "alice" (string #\null) "secret")+51
(plain-payload #f "alice" "secret")))+52
+53
(test "plain-payload with explicit authzid"+54
(assert-equal (string-append "alice" (string #\null) "alice" (string #\null) "p")+55
(plain-payload "alice" "alice" "p"))))+56
+57
+58
(test-group "SASL client state — PLAIN"+59
+60
(test "start emits AUTHENTICATE PLAIN"+61
(let ((s (make-sasl-client-state mechanism: SASL-PLAIN+62
authcid: "alice"+63
password: "secret")))+64
(assert-equal "AUTHENTICATE PLAIN\r\n" (sasl-client-start s))+65
(assert-equal 'awaiting-server-+ (sasl-client-state-phase s))))+66
+67
(test "server + triggers payload send"+68
(let ((s (make-sasl-client-state mechanism: SASL-PLAIN+69
authcid: "alice"+70
password: "secret")))+71
(sasl-client-start s)+72
(let ((out (sasl-client-advance s (parse-irc-message "AUTHENTICATE +"))))+73
(assert-equal 'awaiting-result (sasl-client-state-phase s))+74
(assert-true (>= (length out) 1))+75
;; First chunk line starts with "AUTHENTICATE "+76
(let ((line (car out)))+77
(assert-true (string-contains? line "AUTHENTICATE "))))))+78
+79
(test "903 RPL-SASLSUCCESS marks success"+80
(let ((s (make-sasl-client-state mechanism: SASL-PLAIN+81
authcid: "alice"+82
password: "secret")))+83
(sasl-client-start s)+84
(sasl-client-advance s (parse-irc-message "AUTHENTICATE +"))+85
(sasl-client-advance s+86
(parse-irc-message ":server 903 mynick :SASL authentication successful"))+87
(assert-equal 'done (sasl-client-state-phase s))+88
(assert-equal 'success (sasl-client-state-result s))))+89
+90
(test "904 ERR-SASLFAIL marks failure"+91
(let ((s (make-sasl-client-state mechanism: SASL-PLAIN+92
authcid: "alice"+93
password: "wrong")))+94
(sasl-client-start s)+95
(sasl-client-advance s (parse-irc-message "AUTHENTICATE +"))+96
(sasl-client-advance s+97
(parse-irc-message ":server 904 mynick :SASL authentication failed"))+98
(assert-equal 'done (sasl-client-state-phase s))+99
(assert-equal 'failure (sasl-client-state-result s))))+100
+101
(test "missing creds produces mech-fail"+102
(let ((s (make-sasl-client-state mechanism: SASL-PLAIN)))+103
(sasl-client-start s)+104
(let ((out (sasl-client-advance s (parse-irc-message "AUTHENTICATE +"))))+105
(assert-equal 'done (sasl-client-state-phase s))+106
(assert-equal 'mech-fail (sasl-client-state-result s))+107
(assert-equal "AUTHENTICATE *\r\n" (car out))))))+108
+109
+110
(test-group "SASL client state — EXTERNAL"+111
+112
(test "EXTERNAL with empty authzid sends + terminator only"+113
(let ((s (make-sasl-client-state mechanism: SASL-EXTERNAL)))+114
(sasl-client-start s)+115
(let ((out (sasl-client-advance s (parse-irc-message "AUTHENTICATE +"))))+116
(assert-equal 'awaiting-result (sasl-client-state-phase s))+117
;; Empty payload encodes to single AUTHENTICATE +\r\n+118
(assert-equal "AUTHENTICATE +\r\n" (car out)))))+119
+120
(test "EXTERNAL with explicit authzid sends base64'd authzid"+121
(let ((s (make-sasl-client-state mechanism: SASL-EXTERNAL authzid: "alice")))+122
(sasl-client-start s)+123
(let ((out (sasl-client-advance s (parse-irc-message "AUTHENTICATE +"))))+124
;; "alice" base64 = "YWxpY2U="+125
(assert-true (string-contains? (car out) "YWxpY2U="))))))+126
+127
+128
(test-group "SASL server state — PLAIN"+129
+130
(define (verify-plain mech authzid authcid password)+131
(cond+132
((not (string=? mech SASL-PLAIN)) 'failure)+133
((and (string=? authcid "alice") (string=? password "secret")) 'success)+134
(else 'failure)))+135
+136
(test "rejects unsupported mechanism"+137
(let ((s (make-sasl-server-state supported-mechanisms: '("PLAIN")+138
verify: verify-plain)))+139
(let ((out (sasl-server-advance s (parse-irc-message "AUTHENTICATE BOGUS")+140
client-prefix: "alice")))+141
(assert-equal 'done (sasl-server-state-phase s))+142
(assert-equal 'failure (sasl-server-state-result s))+143
(assert-true (string-contains? (car out) ERR-SASLFAIL)))))+144
+145
(test "accepts PLAIN selection then prompts for payload"+146
(let ((s (make-sasl-server-state supported-mechanisms: '("PLAIN")+147
verify: verify-plain)))+148
(let ((out (sasl-server-advance s (parse-irc-message "AUTHENTICATE PLAIN")+149
client-prefix: "alice")))+150
(assert-equal 'awaiting-payload (sasl-server-state-phase s))+151
(assert-equal "AUTHENTICATE +\r\n" (car out)))))+152
+153
(test "successful PLAIN flow yields RPL-LOGGEDIN + RPL-SASLSUCCESS"+154
(let* ((s (make-sasl-server-state supported-mechanisms: '("PLAIN")+155
verify: verify-plain))+156
(creds (string-append "" (string #\null) "alice" (string #\null) "secret"))+157
(encoded (base64-encode creds)))+158
(sasl-server-advance s (parse-irc-message "AUTHENTICATE PLAIN")+159
client-prefix: "alice")+160
(let ((out (sasl-server-advance s+161
(parse-irc-message+162
(string-append "AUTHENTICATE " encoded))+163
client-prefix: "alice")))+164
(assert-equal 'done (sasl-server-state-phase s))+165
(assert-equal 'success (sasl-server-state-result s))+166
(assert-equal "alice" (sasl-server-state-authcid s))+167
(assert-equal 2 (length out))+168
(assert-true (string-contains? (car out) RPL-LOGGEDIN))+169
(assert-true (string-contains? (cadr out) RPL-SASLSUCCESS)))))+170
+171
(test "failed PLAIN flow emits ERR-SASLFAIL"+172
(let* ((s (make-sasl-server-state supported-mechanisms: '("PLAIN")+173
verify: verify-plain))+174
(creds (string-append "" (string #\null) "alice" (string #\null) "WRONG"))+175
(encoded (base64-encode creds)))+176
(sasl-server-advance s (parse-irc-message "AUTHENTICATE PLAIN")+177
client-prefix: "alice")+178
(let ((out (sasl-server-advance s+179
(parse-irc-message+180
(string-append "AUTHENTICATE " encoded))+181
client-prefix: "alice")))+182
(assert-equal 'failure (sasl-server-state-result s))+183
(assert-true (string-contains? (car out) ERR-SASLFAIL)))))+184
+185
(test "client abort emits ERR-SASLABORTED"+186
(let ((s (make-sasl-server-state supported-mechanisms: '("PLAIN")+187
verify: verify-plain)))+188
(sasl-server-advance s (parse-irc-message "AUTHENTICATE PLAIN")+189
client-prefix: "alice")+190
(let ((out (sasl-server-advance s (parse-irc-message "AUTHENTICATE *")+191
client-prefix: "alice")))+192
(assert-equal 'aborted (sasl-server-state-result s))+193
(assert-true (string-contains? (car out) ERR-SASLABORTED))))))+194
+195
(run-tests)