test/test-sasl-scram.sgl

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.

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))

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))))))

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))))

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.

50(cond

51 ((scram-natives-available?)

53 (test-group "derive-scram-credentials"

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)))))

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))))

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))))))

82 (test-group "SCRAM-SHA-256 end-to-end handshake"

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)