Commit4ccf205bRecorded29 Apr 2026Repositorysigil-websocket

v0.10.0: server-side WebSocket support

Message

Adds the listener-side surface paired with the existing client API:

- (sigil websocket server): parse-handshake-request, build-handshake-response, build-handshake-error-response, compute-accept-key. Handshake parsing surfaces ws-handshake-request (method, path, host, key, version, subprotocols, headers, x-forwarded-for) or a structured ws-handshake-error (status + reason) for non-upgrade or malformed requests. - (sigil websocket frame): encode-server-{text,binary,close, ping,pong}-frame variants that omit the client mask per RFC 6455 5.1. - Re-exports from (sigil websocket) so server applications can import a single module. - 14 new tests including the RFC 6455 4.2.2 spec test vector for Sec-WebSocket-Accept ("dGhlIHNhbXBsZSBub25jZQ==" -> "s3pPLMBiTxaQ9kYGzzhZRbK+xOo=").

Also rebases dependencies on the post-monorepo split: sigil-stdlib ^0.14, sigil-socket ^0.14, sigil-tls ^0.14.1, sigil-crypto ^0.15.

Used to power enclave-server's IRCv3-WebSocket transport (Phase 2.1 of the personal comm hub).

Changed
 .gitignore                     |   2 +
 CHANGELOG.md                   |  12 +++++
 dev-redirects.sgl              |  15 +++++--
 package.sgl                    |  21 +++++----
 sigil.lock                     |  31 +++++++------
 src/sigil/websocket.sgl        |  43 +++++++++++++++++-
 src/sigil/websocket/frame.sgl  |  50 ++++++++++++++++++++-
 src/sigil/websocket/server.sgl | 386 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 test/test-server.sgl           | 194 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 9 files changed, 726 insertions(+), 28 deletions(-)
Diff
.gitignoremodified
@@ -1 +1,3 @@
1
build/
+2
.sigil/
+3
*.sgb
CHANGELOG.mdmodified
@@ -7,6 +7,18 @@ All notable changes to this project will be documented in this file.
7
The format is based on [Keep a Changelog](https://keepachangelog.com/),
8
and this project adheres to [Semantic Versioning](https://semver.org/).
9
+10
## [0.10.0] - 2026-04-29
+11
+12
### Added
+13
+14
- Server-side WebSocket support: new `(sigil websocket server)` module with `parse-handshake-request`, `build-handshake-response`, `build-handshake-error-response`, and `compute-accept-key` for accepting WebSocket upgrades on a TCP listener.
+15
- Server-side frame encoders that omit the client mask per RFC 6455 §5.1: `encode-server-text-frame`, `encode-server-binary-frame`, `encode-server-close-frame`, `encode-server-ping-frame`, `encode-server-pong-frame`.
+16
- Re-exported frame primitives (`encode-frame`, `decode-frame`, `ws-frame*`) and handshake helpers from the top-level `(sigil websocket)` module so server applications can use one import.
+17
+18
### Changed
+19
+20
- Rebased dependencies on the post-monorepo split: `sigil-stdlib` `^0.14`, `sigil-socket` `^0.14`, `sigil-tls` `^0.14.1`, `sigil-crypto` `^0.15`. Top-level `sigil: "^0.14"` declared so the resolver picks a compatible compiler.
+21
22
## [0.7.0] - 2026-03-01
23
24
### Added
dev-redirects.sglmodified
@@ -1,6 +1,15 @@
−1
;; Development redirects — point dependencies at local checkouts
+1
;; Development redirects — point dependencies at local sibling checkouts.
2
(redirects
3
repos: (list
4
(for-repo
−5
url: "codeberg:sigil/sigil"
−6
use: (from-path dir: "../sigil"))))
+5
url: "codeberg:sigil/sigil-lang"
+6
use: (from-path dir: "../sigil-lang"))
+7
(for-repo
+8
url: "codeberg:sigil/sigil-socket"
+9
use: (from-path dir: "../sigil-socket"))
+10
(for-repo
+11
url: "codeberg:sigil/sigil-tls"
+12
use: (from-path dir: "../sigil-tls"))
+13
(for-repo
+14
url: "codeberg:sigil/sigil-crypto"
+15
use: (from-path dir: "../sigil-crypto"))))
package.sglmodified
@@ -1,12 +1,16 @@
−1
;;; sigil-websocket - WebSocket client library
+1
;;; sigil-websocket - WebSocket protocol library
2
;;;
−3
;;; Provides WebSocket client functionality for real-time bidirectional
−4
;;; communication. Supports both ws:// and wss:// (TLS) connections.
+3
;;; Provides RFC 6455 framing plus both client and server surfaces.
+4
;;; Client side: ws-connect for ws:// or wss:// connections. Server
+5
;;; side: HTTP-Upgrade handshake helpers + unmasked frame encoders so
+6
;;; a listener can accept WebSocket connections and relay text/binary
+7
;;; messages to its own connection-loop.
8
9
(package
10
name: "sigil-websocket"
−8
version: "0.9.1"
−9
description: "WebSocket client library with TLS support"
+11
version: "0.10.0"
+12
sigil: "^0.14"
+13
description: "WebSocket protocol library — client + server, with TLS"
14
url: "https://codeberg.org/sigil/sigil-websocket"
15
license: "BSD-3-Clause"
16
authors: (list "David Wilson <[email protected]>")
@@ -24,9 +28,10 @@
28
optimize: 2))
29
30
dependencies: (list
−27
(from-git url: "codeberg:sigil/sigil" package: "sigil-stdlib" version: "^0.9.0")
−28
(from-git url: "codeberg:sigil/sigil" package: "sigil-socket" version: "^0.9.0")
−29
(from-git url: "codeberg:sigil/sigil" package: "sigil-crypto" version: "^0.9.0"))
+31
(from-git url: "codeberg:sigil/sigil-lang" package: "sigil-stdlib" version: "^0.14")
+32
(from-git url: "codeberg:sigil/sigil-socket" version: "^0.14.0")
+33
(from-git url: "codeberg:sigil/sigil-tls" version: "^0.14.1")
+34
(from-git url: "codeberg:sigil/sigil-crypto" version: "^0.15.0"))
35
36
tasks: (list
37
(task
sigil.lockmodified
@@ -1,21 +1,24 @@
1
;; Auto-generated by sigil deps install. Do not edit.
2
(lock
3
(package name: "sigil-stdlib"
−4
url: "codeberg:sigil/sigil"
−5
ref: "^0.9.0"
−6
sha: "54f66e8ec446b65b75ab6f12454d2c0aa269f2c0"
+4
url: "codeberg:sigil/sigil-lang"
+5
ref: "^0.14"
+6
sha: "152ea26c05b73c5d003b246a008d0a79ed0c42d0"
7
package-selector: "sigil-stdlib"
−8
version: "0.9.1")
+8
version: "0.14.17")
9
(package name: "sigil-socket"
−10
url: "codeberg:sigil/sigil"
−11
ref: "^0.9.0"
−12
sha: "54f66e8ec446b65b75ab6f12454d2c0aa269f2c0"
−13
package-selector: "sigil-socket"
−14
version: "0.9.1")
+10
url: "codeberg:sigil/sigil-socket"
+11
ref: "^0.14.0"
+12
sha: "cfc8005ebf26b8234f933be11514a78b96c325e0"
+13
version: "0.14.0")
+14
(package name: "sigil-tls"
+15
url: "codeberg:sigil/sigil-tls"
+16
ref: "^0.14.1"
+17
sha: "722f1ae58644ffe2d129f78fabbbe1e517cdf29a"
+18
version: "0.14.1")
19
(package name: "sigil-crypto"
−16
url: "codeberg:sigil/sigil"
−17
ref: "^0.9.0"
−18
sha: "54f66e8ec446b65b75ab6f12454d2c0aa269f2c0"
−19
package-selector: "sigil-crypto"
−20
version: "0.9.1")
+20
url: "codeberg:sigil/sigil-crypto"
+21
ref: "^0.15.0"
+22
sha: "71e41e7320566bf057828a586f1239041d08d525"
+23
version: "0.15.0")
24
)
src/sigil/websocket.sglmodified
@@ -40,7 +40,8 @@
40
41
(define-library (sigil websocket)
42
(import (sigil websocket frame)
−43
(sigil websocket connection))
+43
(sigil websocket connection)
+44
(sigil websocket server))
45
46
(export
47
;; Connection management
@@ -70,4 +71,42 @@
71
opcode-binary
72
opcode-close
73
opcode-ping
−73
opcode-pong))
+74
opcode-pong
+75
+76
;; Frame encoding / decoding (re-exported for server use)
+77
ws-frame
+78
ws-frame?
+79
ws-frame-fin?
+80
ws-frame-opcode
+81
ws-frame-payload
+82
encode-frame
+83
decode-frame
+84
frame-decode-result?
+85
frame-decode-result-frame
+86
frame-decode-result-bytes-consumed
+87
encode-server-text-frame
+88
encode-server-binary-frame
+89
encode-server-close-frame
+90
encode-server-ping-frame
+91
encode-server-pong-frame
+92
+93
;; Server handshake
+94
ws-handshake-request
+95
ws-handshake-request?
+96
ws-handshake-request-method
+97
ws-handshake-request-path
+98
ws-handshake-request-host
+99
ws-handshake-request-key
+100
ws-handshake-request-version
+101
ws-handshake-request-subprotocols
+102
ws-handshake-request-headers
+103
ws-handshake-request-x-forwarded-for
+104
ws-handshake-error
+105
ws-handshake-error?
+106
ws-handshake-error-status
+107
ws-handshake-error-reason
+108
parse-handshake-request
+109
handshake-request-bytes-needed?
+110
build-handshake-response
+111
build-handshake-error-response
+112
compute-accept-key))
src/sigil/websocket/frame.sglmodified
@@ -28,7 +28,7 @@
28
ws-frame-opcode
29
ws-frame-payload
30
−31
;; Encoding
+31
;; Encoding (client-side: masked per RFC 6455 §5.3)
32
encode-frame
33
encode-text-frame
34
encode-binary-frame
@@ -36,6 +36,14 @@
36
encode-ping-frame
37
encode-pong-frame
38
+39
;; Encoding (server-side: unmasked per RFC 6455 §5.1 — server-to-
+40
;; client frames MUST NOT be masked)
+41
encode-server-text-frame
+42
encode-server-binary-frame
+43
encode-server-close-frame
+44
encode-server-ping-frame
+45
encode-server-pong-frame
+46
47
;; Decoding
48
decode-frame
49
frame-decode-result?
@@ -199,6 +207,46 @@
207
(: bytevector? -> bytevector?)
208
(encode-frame opcode-pong payload #t #t))
209
+210
;; ============================================================
+211
;; Server-side encoders (no masking — server-to-client frames
+212
;; MUST NOT be masked per RFC 6455 §5.1)
+213
;; ============================================================
+214
+215
;;; Encode a text frame for server-to-client delivery (unmasked).
+216
(define (encode-server-text-frame text)
+217
(: string? -> bytevector?)
+218
(encode-frame opcode-text text #t #f))
+219
+220
;;; Encode a binary frame for server-to-client delivery (unmasked).
+221
(define (encode-server-binary-frame data)
+222
(: bytevector? -> bytevector?)
+223
(encode-frame opcode-binary data #t #f))
+224
+225
;;; Encode a close frame from the server (unmasked). Optional
+226
;;; close code per RFC 6455 §7.4.
+227
(define (encode-server-close-frame . args)
+228
(: integer? ... -> bytevector?)
+229
(let ((payload
+230
(if (null? args)
+231
(empty-bytevector)
+232
(let ((code (car args)))
+233
(bytes->bytevector
+234
(list (bitwise-and (arithmetic-shift code -8) #xFF)
+235
(bitwise-and code #xFF)))))))
+236
(encode-frame opcode-close payload #t #f)))
+237
+238
;;; Encode a ping frame from the server (unmasked).
+239
(define (encode-server-ping-frame . args)
+240
(: bytevector? ... -> bytevector?)
+241
(let ((payload (if (null? args) (empty-bytevector) (car args))))
+242
(encode-frame opcode-ping payload #t #f)))
+243
+244
;;; Encode a pong frame from the server (unmasked). Pong payload
+245
;;; must equal the originating ping's payload.
+246
(define (encode-server-pong-frame payload)
+247
(: bytevector? -> bytevector?)
+248
(encode-frame opcode-pong payload #t #f))
+249
250
;; ============================================================
251
;; Frame Decoding
252
;; ============================================================
src/sigil/websocket/server.sgladded
@@ -0,0 +1,386 @@
+1
;;; (sigil websocket server) - Server-side WebSocket handshake helpers.
+2
;;;
+3
;;; Pairs with `(sigil websocket frame)` for full server support.
+4
;;; The handshake flow on the listener:
+5
;;;
+6
;;; 1. Read bytes from the client until you have the full HTTP
+7
;;; request header block (terminated by CRLF CRLF).
+8
;;; 2. Pass the header block to `parse-handshake-request`. It
+9
;;; returns either a `ws-handshake-request` record or a
+10
;;; `ws-handshake-error` record describing what was wrong
+11
;;; (which the listener turns into a 400/426 response).
+12
;;; 3. Pass the request to `build-handshake-response` to obtain
+13
;;; the 101 Switching Protocols response. Optionally pass a
+14
;;; chosen subprotocol (one of the values from
+15
;;; `ws-handshake-request-subprotocols`).
+16
;;; 4. Write the response to the socket. Subsequent reads are
+17
;;; raw WebSocket frames; pass them to `decode-frame` and
+18
;;; reply with the unmasked `encode-server-*-frame` encoders.
+19
;;;
+20
;;; This module deliberately does not own a connection record or a
+21
;;; read loop — every server has its own per-connection abstractions.
+22
;;; What this module owns is the wire-format-correct handshake.
+23
+24
(define-library (sigil websocket server)
+25
(import (sigil core)
+26
(sigil string)
+27
(sigil math)
+28
(sigil struct)
+29
(sigil crypto))
+30
+31
(export
+32
ws-guid
+33
compute-accept-key
+34
+35
ws-handshake-request
+36
ws-handshake-request?
+37
ws-handshake-request-method
+38
ws-handshake-request-path
+39
ws-handshake-request-host
+40
ws-handshake-request-key
+41
ws-handshake-request-version
+42
ws-handshake-request-subprotocols
+43
ws-handshake-request-headers
+44
ws-handshake-request-x-forwarded-for
+45
+46
ws-handshake-error
+47
ws-handshake-error?
+48
ws-handshake-error-status
+49
ws-handshake-error-reason
+50
+51
parse-handshake-request
+52
handshake-request-bytes-needed?
+53
build-handshake-response
+54
build-handshake-error-response)
+55
+56
(begin
+57
+58
;; ============================================================
+59
;; WebSocket GUID (RFC 6455 §1.3)
+60
;; ============================================================
+61
+62
(define ws-guid "258EAFA5-E914-47DA-95CA-C5AB0DC85B11")
+63
+64
;;; Compute the Sec-WebSocket-Accept value from the client's
+65
;;; Sec-WebSocket-Key per RFC 6455 §4.2.2:
+66
;;; base64(SHA-1(key ++ guid))
+67
;;;
+68
;;; sigil-crypto's `sha1` already returns the raw 20-byte digest
+69
;;; as a bytevector (despite the older docstring suggesting hex —
+70
;;; the runtime returns a bytevector for SHA family hashes that
+71
;;; `base64-encode` accepts directly).
+72
(define (compute-accept-key key)
+73
(: string? -> string?)
+74
(base64-encode (sha1 (string-append key ws-guid))))
+75
+76
+77
;; ============================================================
+78
;; Handshake records
+79
;; ============================================================
+80
+81
(define-struct ws-handshake-request
+82
(method) ;; string, e.g. "GET"
+83
(path) ;; string, e.g. "/ws"
+84
(host) ;; string from Host: header
+85
(key) ;; raw Sec-WebSocket-Key value
+86
(version) ;; integer (Sec-WebSocket-Version)
+87
(subprotocols) ;; list of strings (Sec-WebSocket-Protocol values)
+88
(headers) ;; alist of (lowercase-name . raw-value)
+89
(x-forwarded-for)) ;; string or #f — first value of XFF if present
+90
+91
(define-struct ws-handshake-error
+92
(status) ;; integer HTTP status
+93
(reason)) ;; string reason phrase / message body
+94
+95
+96
;; ============================================================
+97
;; Request parsing
+98
;; ============================================================
+99
+100
;;; Has the client sent a complete header block yet?
+101
;;; Looks for CRLF CRLF or LF LF in the buffer.
+102
(define (handshake-request-bytes-needed? buffer)
+103
(: string? -> boolean?)
+104
(not (header-end-index buffer)))
+105
+106
(define (header-end-index buffer)
+107
;; Returns the index of the first byte AFTER the header block,
+108
;; or #f if the block is not yet complete.
+109
(let ((len (string-length buffer)))
+110
(or (find-substring buffer 0 len "\r\n\r\n" 4)
+111
(find-substring buffer 0 len "\n\n" 2))))
+112
+113
(define (find-substring str start end needle nlen)
+114
(let loop ((i start))
+115
(cond
+116
((> (+ i nlen) end) #f)
+117
((string-substring=? str i needle nlen) (+ i nlen))
+118
(else (loop (+ i 1))))))
+119
+120
(define (string-substring=? haystack pos needle nlen)
+121
(let loop ((i 0))
+122
(cond
+123
((>= i nlen) #t)
+124
((char=? (string-ref haystack (+ pos i))
+125
(string-ref needle i))
+126
(loop (+ i 1)))
+127
(else #f))))
+128
+129
;;; Parse a complete handshake request. Returns either a
+130
;;; ws-handshake-request or a ws-handshake-error.
+131
;;;
+132
;;; Caller is responsible for first checking that the header
+133
;;; block is complete with `handshake-request-bytes-needed?`.
+134
(define (parse-handshake-request buffer)
+135
(: string? -> any?)
+136
(let* ((len (string-length buffer))
+137
(end (header-end-index buffer)))
+138
(cond
+139
((not end)
+140
(ws-handshake-error status: 400
+141
reason: "incomplete handshake header"))
+142
(else
+143
(let* ((header-block
+144
(substring buffer 0 (header-block-end-trim buffer end)))
+145
(lines (split-header-lines header-block)))
+146
(cond
+147
((null? lines)
+148
(ws-handshake-error status: 400 reason: "empty request"))
+149
(else
+150
(parse-request-from-lines lines))))))))
+151
+152
(define (header-block-end-trim buffer end)
+153
;; `end` is the index after the terminator. Strip the
+154
;; terminator itself so it doesn't end up in the parsed line.
+155
(cond
+156
((and (>= end 4)
+157
(char=? (string-ref buffer (- end 4)) #\return))
+158
(- end 4))
+159
(else (- end 2))))
+160
+161
(define (split-header-lines block)
+162
(let* ((len (string-length block))
+163
(lines '()))
+164
(let loop ((start 0) (acc '()))
+165
(let ((nl (find-newline-from block start len)))
+166
(cond
+167
((not nl)
+168
(reverse (cond
+169
((< start len)
+170
(cons (trim-cr (substring block start len)) acc))
+171
(else acc))))
+172
(else
+173
(loop (+ nl 1)
+174
(cons (trim-cr (substring block start nl)) acc))))))))
+175
+176
(define (find-newline-from str start end)
+177
(let loop ((i start))
+178
(cond
+179
((>= i end) #f)
+180
((char=? (string-ref str i) #\newline) i)
+181
(else (loop (+ i 1))))))
+182
+183
(define (trim-cr s)
+184
(let ((len (string-length s)))
+185
(cond
+186
((and (> len 0)
+187
(char=? (string-ref s (- len 1)) #\return))
+188
(substring s 0 (- len 1)))
+189
(else s))))
+190
+191
+192
(define (parse-request-from-lines lines)
+193
(let* ((request-line (car lines))
+194
(parts (split-by-space request-line))
+195
(method (car parts))
+196
(path (and (pair? (cdr parts)) (cadr parts)))
+197
(proto (and (pair? (cdr parts)) (pair? (cddr parts))
+198
(caddr parts))))
+199
(cond
+200
((not (and method path proto))
+201
(ws-handshake-error status: 400
+202
reason: "malformed request line"))
+203
((not (string=? method "GET"))
+204
(ws-handshake-error status: 405
+205
reason: "method not allowed; expected GET"))
+206
((not (or (string=? proto "HTTP/1.1")
+207
(string=? proto "HTTP/1.0")))
+208
(ws-handshake-error status: 505
+209
reason: "HTTP version not supported"))
+210
(else
+211
(let ((headers (parse-headers (cdr lines) '())))
+212
(validate-and-build method path headers))))))
+213
+214
(define (parse-headers lines acc)
+215
(cond
+216
((null? lines) (reverse acc))
+217
(else
+218
(let* ((line (car lines))
+219
(colon (find-char line 0 (string-length line) #\:)))
+220
(cond
+221
((not colon) (parse-headers (cdr lines) acc))
+222
(else
+223
(let* ((name (string-downcase
+224
(string-trim (substring line 0 colon))))
+225
(value (string-trim
+226
(substring line (+ colon 1)
+227
(string-length line)))))
+228
(parse-headers (cdr lines)
+229
(cons (cons name value) acc)))))))))
+230
+231
(define (find-char s start end ch)
+232
(let loop ((i start))
+233
(cond
+234
((>= i end) #f)
+235
((char=? (string-ref s i) ch) i)
+236
(else (loop (+ i 1))))))
+237
+238
(define (split-by-space s)
+239
(let* ((len (string-length s))
+240
(acc '()))
+241
(let loop ((start 0) (i 0) (acc acc))
+242
(cond
+243
((>= i len)
+244
(reverse
+245
(if (> i start)
+246
(cons (substring s start i) acc)
+247
acc)))
+248
((char=? (string-ref s i) #\space)
+249
(loop (+ i 1) (+ i 1)
+250
(if (> i start)
+251
(cons (substring s start i) acc)
+252
acc)))
+253
(else (loop start (+ i 1) acc))))))
+254
+255
(define (split-by-comma s)
+256
(let* ((len (string-length s))
+257
(acc '()))
+258
(let loop ((start 0) (i 0) (acc acc))
+259
(cond
+260
((>= i len)
+261
(reverse
+262
(cond
+263
((> i start)
+264
(cons (string-trim (substring s start i)) acc))
+265
(else acc))))
+266
((char=? (string-ref s i) #\,)
+267
(loop (+ i 1) (+ i 1)
+268
(cond
+269
((> i start)
+270
(cons (string-trim (substring s start i)) acc))
+271
(else acc))))
+272
(else (loop start (+ i 1) acc))))))
+273
+274
(define (header-value headers name)
+275
(cond
+276
((null? headers) #f)
+277
((string=? (caar headers) name) (cdar headers))
+278
(else (header-value (cdr headers) name))))
+279
+280
(define (string-contains-ci? haystack needle)
+281
;; Case-insensitive substring check.
+282
(let* ((hlow (string-downcase haystack))
+283
(nlow (string-downcase needle))
+284
(hlen (string-length hlow))
+285
(nlen (string-length nlow)))
+286
(and (find-substring hlow 0 hlen nlow nlen) #t)))
+287
+288
+289
(define (validate-and-build method path headers)
+290
(let ((host (header-value headers "host"))
+291
(upgrade (header-value headers "upgrade"))
+292
(connection (header-value headers "connection"))
+293
(key (header-value headers "sec-websocket-key"))
+294
(version-str (header-value headers "sec-websocket-version"))
+295
(proto-str (header-value headers "sec-websocket-protocol"))
+296
(xff (header-value headers "x-forwarded-for")))
+297
(cond
+298
((not (and upgrade
+299
(string=? (string-downcase upgrade) "websocket")))
+300
(ws-handshake-error status: 426
+301
reason: "upgrade required: websocket"))
+302
((not (and connection
+303
(string-contains-ci? connection "upgrade")))
+304
(ws-handshake-error status: 400
+305
reason: "missing Connection: Upgrade"))
+306
((not key)
+307
(ws-handshake-error status: 400
+308
reason: "missing Sec-WebSocket-Key"))
+309
((or (not version-str)
+310
(not (string=? (string-trim version-str) "13")))
+311
(ws-handshake-error status: 426
+312
reason: "unsupported Sec-WebSocket-Version (need 13)"))
+313
(else
+314
(ws-handshake-request
+315
method: method
+316
path: path
+317
host: (or host "")
+318
key: (string-trim key)
+319
version: 13
+320
subprotocols: (cond
+321
(proto-str (split-by-comma proto-str))
+322
(else '()))
+323
headers: headers
+324
x-forwarded-for: (cond
+325
(xff (xff-first xff))
+326
(else #f)))))))
+327
+328
(define (xff-first value)
+329
;; Take the first hop in a comma-separated XFF chain.
+330
(let* ((commas (split-by-comma value)))
+331
(cond
+332
((null? commas) value)
+333
(else (car commas)))))
+334
+335
+336
;; ============================================================
+337
;; Response building
+338
;; ============================================================
+339
+340
;;; Build the 101 Switching Protocols response for a successfully-
+341
;;; validated handshake. `subprotocol`, when supplied, is echoed
+342
;;; back in the Sec-WebSocket-Protocol header.
+343
(define (build-handshake-response request (keys: (subprotocol #f)))
+344
(: ws-handshake-request? (subprotocol: any?) -> string?)
+345
(let ((accept (compute-accept-key (ws-handshake-request-key request))))
+346
(string-append
+347
"HTTP/1.1 101 Switching Protocols\r\n"
+348
"Upgrade: websocket\r\n"
+349
"Connection: Upgrade\r\n"
+350
"Sec-WebSocket-Accept: " accept "\r\n"
+351
(cond
+352
(subprotocol
+353
(string-append "Sec-WebSocket-Protocol: " subprotocol "\r\n"))
+354
(else ""))
+355
"\r\n")))
+356
+357
;;; Build a short HTTP error response. Used when the request
+358
;;; isn't a valid WebSocket upgrade — listeners should send the
+359
;;; corresponding status (e.g. 400, 426) and close.
+360
(define (build-handshake-error-response error)
+361
(: ws-handshake-error? -> string?)
+362
(let* ((status (ws-handshake-error-status error))
+363
(reason (ws-handshake-error-reason error))
+364
(status-str (number->string status))
+365
(body (string-append reason "\n")))
+366
(string-append
+367
"HTTP/1.1 " status-str " " (status-phrase status) "\r\n"
+368
"Content-Type: text/plain; charset=utf-8\r\n"
+369
"Content-Length: " (number->string (string-length body)) "\r\n"
+370
"Connection: close\r\n"
+371
(cond
+372
((= status 426)
+373
"Upgrade: websocket\r\nSec-WebSocket-Version: 13\r\n")
+374
(else ""))
+375
"\r\n"
+376
body)))
+377
+378
(define (status-phrase status)
+379
(cond
+380
((= status 400) "Bad Request")
+381
((= status 405) "Method Not Allowed")
+382
((= status 426) "Upgrade Required")
+383
((= status 505) "HTTP Version Not Supported")
+384
(else "Error")))
+385
+386
))
test/test-server.sgladded
@@ -0,0 +1,194 @@
+1
(import (sigil test)
+2
(sigil string)
+3
(sigil math)
+4
(sigil websocket frame)
+5
(sigil websocket server))
+6
+7
;; ============================================================
+8
;; compute-accept-key — RFC 6455 §1.3 test vector
+9
;; ============================================================
+10
+11
(test-group "compute-accept-key"
+12
(test "matches RFC 6455 example"
+13
;; Spec test vector: key "dGhlIHNhbXBsZSBub25jZQ==" produces
+14
;; accept "s3pPLMBiTxaQ9kYGzzhZRbK+xOo="
+15
(assert-equal "s3pPLMBiTxaQ9kYGzzhZRbK+xOo="
+16
(compute-accept-key "dGhlIHNhbXBsZSBub25jZQ=="))))
+17
+18
;; ============================================================
+19
;; handshake-request-bytes-needed?
+20
;; ============================================================
+21
+22
(test-group "handshake-request-bytes-needed?"
+23
(test "incomplete request needs more bytes"
+24
(assert-true (handshake-request-bytes-needed? "GET /ws HTTP/1.1\r\n"))
+25
(assert-true (handshake-request-bytes-needed?
+26
"GET /ws HTTP/1.1\r\nHost: x\r\n")))
+27
+28
(test "complete request does not need more"
+29
(assert-false (handshake-request-bytes-needed?
+30
(string-append
+31
"GET /ws HTTP/1.1\r\n"
+32
"Host: x\r\n"
+33
"Upgrade: websocket\r\n"
+34
"Connection: Upgrade\r\n"
+35
"Sec-WebSocket-Key: dGhlIHNhbXBsZSBub25jZQ==\r\n"
+36
"Sec-WebSocket-Version: 13\r\n"
+37
"\r\n")))))
+38
+39
;; ============================================================
+40
;; parse-handshake-request
+41
;; ============================================================
+42
+43
(define (good-request)
+44
(string-append
+45
"GET /ws HTTP/1.1\r\n"
+46
"Host: enclave.example\r\n"
+47
"Upgrade: websocket\r\n"
+48
"Connection: Upgrade\r\n"
+49
"Sec-WebSocket-Key: dGhlIHNhbXBsZSBub25jZQ==\r\n"
+50
"Sec-WebSocket-Version: 13\r\n"
+51
"Sec-WebSocket-Protocol: text.ircv3.net, binary.ircv3.net\r\n"
+52
"X-Forwarded-For: 198.51.100.7, 10.0.0.1\r\n"
+53
"\r\n"))
+54
+55
(test-group "parse-handshake-request"
+56
(test "parses a valid request"
+57
(let ((req (parse-handshake-request (good-request))))
+58
(assert-true (ws-handshake-request? req))
+59
(assert-equal "GET" (ws-handshake-request-method req))
+60
(assert-equal "/ws" (ws-handshake-request-path req))
+61
(assert-equal "enclave.example" (ws-handshake-request-host req))
+62
(assert-equal "dGhlIHNhbXBsZSBub25jZQ==" (ws-handshake-request-key req))
+63
(assert-equal 13 (ws-handshake-request-version req))
+64
(assert-equal '("text.ircv3.net" "binary.ircv3.net")
+65
(ws-handshake-request-subprotocols req))
+66
(assert-equal "198.51.100.7"
+67
(ws-handshake-request-x-forwarded-for req))))
+68
+69
(test "missing Upgrade -> 426"
+70
(let ((req (parse-handshake-request
+71
(string-append
+72
"GET / HTTP/1.1\r\n"
+73
"Host: x\r\n"
+74
"Connection: Upgrade\r\n"
+75
"Sec-WebSocket-Key: dGhlIHNhbXBsZSBub25jZQ==\r\n"
+76
"Sec-WebSocket-Version: 13\r\n"
+77
"\r\n"))))
+78
(assert-true (ws-handshake-error? req))
+79
(assert-equal 426 (ws-handshake-error-status req))))
+80
+81
(test "wrong version -> 426"
+82
(let ((req (parse-handshake-request
+83
(string-append
+84
"GET / HTTP/1.1\r\n"
+85
"Host: x\r\n"
+86
"Upgrade: websocket\r\n"
+87
"Connection: Upgrade\r\n"
+88
"Sec-WebSocket-Key: dGhlIHNhbXBsZSBub25jZQ==\r\n"
+89
"Sec-WebSocket-Version: 8\r\n"
+90
"\r\n"))))
+91
(assert-true (ws-handshake-error? req))
+92
(assert-equal 426 (ws-handshake-error-status req))))
+93
+94
(test "POST -> 405"
+95
(let ((req (parse-handshake-request
+96
(string-append
+97
"POST /ws HTTP/1.1\r\n"
+98
"Host: x\r\n"
+99
"Upgrade: websocket\r\n"
+100
"Connection: Upgrade\r\n"
+101
"Sec-WebSocket-Key: dGhlIHNhbXBsZSBub25jZQ==\r\n"
+102
"Sec-WebSocket-Version: 13\r\n"
+103
"\r\n"))))
+104
(assert-true (ws-handshake-error? req))
+105
(assert-equal 405 (ws-handshake-error-status req))))
+106
+107
(test "missing key -> 400"
+108
(let ((req (parse-handshake-request
+109
(string-append
+110
"GET / HTTP/1.1\r\n"
+111
"Host: x\r\n"
+112
"Upgrade: websocket\r\n"
+113
"Connection: Upgrade\r\n"
+114
"Sec-WebSocket-Version: 13\r\n"
+115
"\r\n"))))
+116
(assert-true (ws-handshake-error? req))
+117
(assert-equal 400 (ws-handshake-error-status req)))))
+118
+119
;; ============================================================
+120
;; build-handshake-response
+121
;; ============================================================
+122
+123
(test-group "build-handshake-response"
+124
(test "writes 101 with correct accept"
+125
(let* ((req (parse-handshake-request (good-request)))
+126
(resp (build-handshake-response req)))
+127
(assert-true
+128
(string-contains? resp "HTTP/1.1 101 Switching Protocols\r\n"))
+129
(assert-true
+130
(string-contains? resp
+131
"Sec-WebSocket-Accept: s3pPLMBiTxaQ9kYGzzhZRbK+xOo=\r\n"))
+132
(assert-true
+133
(string-contains? resp "Upgrade: websocket\r\n"))
+134
(assert-true
+135
(string-contains? resp "Connection: Upgrade\r\n"))))
+136
+137
(test "echoes negotiated subprotocol"
+138
(let* ((req (parse-handshake-request (good-request)))
+139
(resp (build-handshake-response req
+140
subprotocol: "text.ircv3.net")))
+141
(assert-true
+142
(string-contains? resp
+143
"Sec-WebSocket-Protocol: text.ircv3.net\r\n")))))
+144
+145
;; ============================================================
+146
;; build-handshake-error-response
+147
;; ============================================================
+148
+149
(test-group "build-handshake-error-response"
+150
(test "426 includes Upgrade hint"
+151
(let* ((err (parse-handshake-request
+152
(string-append
+153
"GET / HTTP/1.1\r\n"
+154
"Host: x\r\n"
+155
"Connection: Upgrade\r\n"
+156
"Sec-WebSocket-Key: dGhlIHNhbXBsZSBub25jZQ==\r\n"
+157
"Sec-WebSocket-Version: 13\r\n"
+158
"\r\n")))
+159
(resp (build-handshake-error-response err)))
+160
(assert-true (string-contains? resp "HTTP/1.1 426"))
+161
(assert-true (string-contains? resp "Upgrade: websocket\r\n"))
+162
(assert-true (string-contains? resp "Sec-WebSocket-Version: 13\r\n")))))
+163
+164
;; ============================================================
+165
;; Server-side frame encoders are unmasked
+166
;; ============================================================
+167
+168
(test-group "server-side frame encoders"
+169
(test "encode-server-text-frame is unmasked and round-trips"
+170
(let* ((encoded (encode-server-text-frame "PRIVMSG #hive :hi"))
+171
(result (decode-frame encoded))
+172
(frame (frame-decode-result-frame result)))
+173
(assert-true (ws-frame? frame))
+174
(assert-equal opcode-text (ws-frame-opcode frame))
+175
(assert-true (ws-frame-fin? frame))
+176
;; Mask bit must be 0 — verify by checking byte 1's high bit.
+177
(assert-equal 0 (bitwise-and (bytevector-u8-ref encoded 1) #x80))))
+178
+179
(test "encode-server-pong-frame is unmasked"
+180
(let ((encoded (encode-server-pong-frame (make-bytevector 0))))
+181
(assert-equal opcode-pong (bitwise-and (bytevector-u8-ref encoded 0) #x0F))
+182
(assert-equal 0 (bitwise-and (bytevector-u8-ref encoded 1) #x80))))
+183
+184
(test "encode-server-close-frame includes status code"
+185
(let* ((encoded (encode-server-close-frame 1000))
+186
(result (decode-frame encoded))
+187
(frame (frame-decode-result-frame result))
+188
(payload (ws-frame-payload frame)))
+189
(assert-equal opcode-close (ws-frame-opcode frame))
+190
(assert-equal 2 (bytevector-length payload))
+191
(assert-equal #x03 (bytevector-u8-ref payload 0)) ; 1000 >> 8
+192
(assert-equal #xE8 (bytevector-u8-ref payload 1))))) ; 1000 & 0xFF
+193
+194
(run-tests)