packages/sigil-irc-websocket/src/sigil/irc/websocket.sgl

1;;; (sigil irc websocket) - IRC-over-WebSocket client/session helper

2;;;

3;;; This module composes the public `(sigil websocket)` client API with the

4;;; protocol-only `(sigil irc message)` layer. IRCv3 WebSocket transports carry

5;;; one IRC line per frame without CRLF. This module intentionally does not

6;;; import the native IRC connection, socket, TLS, crypto, or SASL modules, so

7;;; browser WASM builds can use it as a small Enclave-facing transport adapter.

9(define-library (sigil irc websocket)

10 (import (sigil core)

11 (sigil math)

12 (sigil string)

13 (sigil struct)

14 (sigil websocket connection)

15 (sigil irc message))

17 (export

18 irc-ws-session

19 make-irc-ws-session

20 irc-ws-session?

21 irc-ws-session-url

22 irc-ws-session-nick

23 irc-ws-session-user

24 irc-ws-session-realname

25 irc-ws-session-connect-timeout-ms

26 irc-ws-session-handshake-timeout-ms

27 irc-ws-session-upgrade-timeout-ms

28 irc-ws-session-websocket

29 irc-ws-session-state

30 irc-ws-session-server-caps

31 irc-ws-session-enabled-caps

32 irc-ws-session-sasl-result

34 irc-ws-connect

35 irc-ws-close

36 irc-ws-connected?

37 irc-ws-register

38 irc-ws-negotiate-caps

39 irc-ws-authenticate-plain

40 irc-ws-register-with-caps

41 irc-ws-cap-ls

42 irc-ws-cap-req-from-ls

43 irc-ws-cap-ack

44 irc-ws-cap-end

45 irc-ws-authenticate-plain-start

46 irc-ws-authenticate-plain-payload

47 irc-ws-authenticate-finish

49 irc-ws-send

50 irc-ws-command

51 irc-ws-privmsg

52 irc-ws-notice

53 irc-ws-join

54 irc-ws-part

55 irc-ws-quit

57 irc-ws-receive

58 irc-ws-receive-line)

60 (begin

62 (define-struct irc-ws-session

63 (url)

64 (nick default: #f)

65 (user default: #f)

66 (realname default: "")

67 (connect-timeout-ms default: #f)

68 (handshake-timeout-ms default: #f)

69 (upgrade-timeout-ms default: #f)

70 (websocket default: #f mutable: #t)

71 (state default: 'disconnected mutable: #t)

72 (buffer default: "" mutable: #t)

73 (queue default: '() mutable: #t)

74 (server-caps default: '() mutable: #t)

75 (enabled-caps default: '() mutable: #t)

76 (sasl-result default: #f mutable: #t))

78 (define (make-irc-ws-session (keys: (url #f)

79 (nick #f)

80 (user #f)

81 (realname "")

82 (connect-timeout-ms #f)

83 (handshake-timeout-ms #f)

84 (upgrade-timeout-ms #f)))

85 (: (url: any?) (nick: any?) (user: any?) (realname: string?)

86 (connect-timeout-ms: any?) (handshake-timeout-ms: any?)

87 (upgrade-timeout-ms: any?) -> irc-ws-session?)

88 (unless url

89 (error "make-irc-ws-session: url: is required"))

90 (irc-ws-session

91 url: url

92 nick: nick

93 user: (or user nick)

94 realname: (if (and nick (string=? realname "")) nick realname)

95 connect-timeout-ms: connect-timeout-ms

96 handshake-timeout-ms: handshake-timeout-ms

97 upgrade-timeout-ms: upgrade-timeout-ms))

99 (define (strip-line-ending line)

100 (let ((len (string-length line)))

101 (cond

102 ((and (> len 0)

103 (char=? (string-ref line (- len 1)) #\newline))

104 (let ((end (- len 1)))

105 (if (and (> end 0)

106 (char=? (string-ref line (- end 1)) #\return))

107 (substring line 0 (- end 1))

108 (substring line 0 end))))

109 (else line))))

110

111 (define (contains-line-ending? text)

112 (if (string-index text (lambda (c) (char=? c #\newline)))

113 #t

114 #f))

115

116 (define (enqueue-lines! session text)

117 (let ((combined (string-append (irc-ws-session-buffer session) text)))

118 (let loop ((buffer combined)

119 (lines '()))

120 (let ((newline-pos (string-index buffer (lambda (c) (char=? c #\newline)))))

121 (if newline-pos

122 (let ((line (substring buffer 0 (+ newline-pos 1)))

123 (rest (substring buffer (+ newline-pos 1) (string-length buffer))))

124 (loop rest (cons (strip-line-ending line) lines)))

125 (begin

126 (set-irc-ws-session-buffer! session buffer)

127 (when (pair? lines)

128 (set-irc-ws-session-queue!

129 session

130 (append (irc-ws-session-queue session)

131 (reverse lines))))))))))

132

133 (define (enqueue-message! session text)

134 (if (or (contains-line-ending? text)

135 (not (string=? (irc-ws-session-buffer session) "")))

136 (enqueue-lines! session text)

137 (set-irc-ws-session-queue!

138 session

139 (append (irc-ws-session-queue session)

140 (list text)))))

141

142 (define (pop-message! session)

143 (let ((queue (irc-ws-session-queue session)))

144 (if (null? queue)

145 #f

146 (let ((line (car queue)))

147 (set-irc-ws-session-queue! session (cdr queue))

148 (parse-irc-message line)))))

149

150 (define base64-alphabet

151 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")

152

153 (define (base64-char n)

154 (string (string-ref base64-alphabet n)))

155

156 (define (base64-encode-string input)

157 (let ((len (string-length input)))

158 (let loop ((i 0) (acc '()))

159 (if (>= i len)

160 (apply string-append (reverse acc))

161 (let* ((remaining (- len i))

162 (b1 (char->integer (string-ref input i)))

163 (b2 (if (> remaining 1)

164 (char->integer (string-ref input (+ i 1)))

165 0))

166 (b3 (if (> remaining 2)

167 (char->integer (string-ref input (+ i 2)))

168 0))

169 (n (+ (* b1 65536) (* b2 256) b3))

170 (s1 (quotient n 262144))

171 (s2 (remainder (quotient n 4096) 64))

172 (s3 (remainder (quotient n 64) 64))

173 (s4 (remainder n 64))

174 (chunk

175 (cond

176 ((= remaining 1)

177 (string-append (base64-char s1)

178 (base64-char s2)

179 "=="))

180 ((= remaining 2)

181 (string-append (base64-char s1)

182 (base64-char s2)

183 (base64-char s3)

184 "="))

185 (else

186 (string-append (base64-char s1)

187 (base64-char s2)

188 (base64-char s3)

189 (base64-char s4))))))

190 (loop (+ i 3) (cons chunk acc)))))))

191

192 (define (sasl-plain-payload authcid password . authzid)

193 (base64-encode-string

194 (string-append

195 (if (pair? authzid) (or (car authzid) "") "")

196 (string #\null)

197 authcid

198 (string #\null)

199 password)))

200

201 (define (line-without-crlf line)

202 (strip-line-ending line))

203

204 (define (send-wire-lines session lines)

205 (for-each

206 (lambda (line)

207 (irc-ws-send session (line-without-crlf line)))

208 lines))

209

210 (define (message-command=? msg command)

211 (and (irc-message? msg)

212 (string=? (symbol->string (irc-message-command msg)) command)))

213

214 (define (cap-subcommand msg)

215 (let ((params (irc-message-params msg)))

216 (and (pair? params)

217 (pair? (cdr params))

218 (cadr params))))

219

220 (define (cap-body msg)

221 (or (irc-message-trailing msg)

222 (let ((params (irc-message-params msg)))

223 (if (null? params) "" (car (reverse params))))))

224

225 (define (cap-ls-more? msg)

226 (let ((params (irc-message-params msg)))

227 (and (>= (length params) 3)

228 (string=? (caddr params) "*"))))

229

230 (define (split-caps text)

231 (if (string=? text "")

232 '()

233 (map

234 (lambda (entry)

235 (let ((eq-pos (string-index entry (lambda (c) (char=? c #\=)))))

236 (if eq-pos

237 (substring entry 0 eq-pos)

238 entry)))

239 (string-split text " "))))

240

241 (define (append-new-caps existing names)

242 (let loop ((rest names) (acc existing))

243 (cond

244 ((null? rest) acc)

245 ((member (car rest) acc) (loop (cdr rest) acc))

246 (else (loop (cdr rest) (append acc (list (car rest))))))))

247

248 (define (filter-offered desired offered)

249 (let loop ((rest desired) (acc '()))

250 (cond

251 ((null? rest) (reverse acc))

252 ((member (car rest) offered)

253 (loop (cdr rest) (cons (car rest) acc)))

254 (else (loop (cdr rest) acc)))))

255

256 (define (join-caps caps)

257 (string-join caps " "))

258

259 (define (read-next-irc-message session max-lines)

260 (let loop ((n 0))

261 (if (>= n max-lines)

262 #f

263 (let ((msg (irc-ws-receive session)))

264 (if (irc-message? msg)

265 msg

266 (loop (+ n 1)))))))

267

268 (define (read-until-command session command max-lines)

269 (let loop ((n 0))

270 (if (>= n max-lines)

271 #f

272 (let ((msg (irc-ws-receive session)))

273 (cond

274 ((not (irc-message? msg)) (loop (+ n 1)))

275 ((message-command=? msg command) msg)

276 (else (loop (+ n 1))))))))

277

278 (define (read-cap-ls session max-lines)

279 (let loop ((n 0) (offered '()))

280 (if (>= n max-lines)

281 #f

282 (let ((msg (read-next-irc-message session 1)))

283 (cond

284 ((not msg) (loop (+ n 1) offered))

285 ((and (message-command=? msg "CAP")

286 (equal? (cap-subcommand msg) "LS"))

287 (let ((next (append-new-caps offered (split-caps (cap-body msg)))))

288 (if (cap-ls-more? msg)

289 (loop (+ n 1) next)

290 next)))

291 (else (loop (+ n 1) offered)))))))

292

293 (define (read-cap-ack-or-nak session max-lines)

294 (let loop ((n 0))

295 (if (>= n max-lines)

296 #f

297 (let ((msg (read-next-irc-message session 1)))

298 (cond

299 ((not msg) (loop (+ n 1)))

300 ((and (message-command=? msg "CAP")

301 (or (equal? (cap-subcommand msg) "ACK")

302 (equal? (cap-subcommand msg) "NAK")))

303 msg)

304 (else (loop (+ n 1))))))))

305

306 (define (irc-ws-register session)

307 (: irc-ws-session? -> void?)

308 (let ((nick (irc-ws-session-nick session)))

309 (unless nick

310 (error "irc-ws-register: session has no nick"))

311 (irc-ws-command session "NICK" nick)

312 (irc-ws-command session

313 "USER"

314 (or (irc-ws-session-user session) nick)

315 "0"

316 "*"

317 (or (irc-ws-session-realname session) nick))))

318

319 (define (irc-ws-authenticate-plain session authcid password . authzid)

320 (: irc-ws-session? string? string? any? ... -> boolean?)

321 (irc-ws-authenticate-plain-start session)

322 (if (not (apply irc-ws-authenticate-plain-payload

323 session

324 authcid

325 password

326 authzid))

327 #f

328 (irc-ws-authenticate-finish session)))

329

330 (define (irc-ws-cap-ls session)

331 (: irc-ws-session? -> void?)

332 (irc-ws-command session "CAP" "LS" "302"))

333

334 (define (irc-ws-cap-req-from-ls session desired . opts)

335 (: irc-ws-session? list? any? ... -> list?)

336 (let parse-opts ((rest opts)

337 (include-sasl? #f)

338 (max-lines 80))

339 (cond

340 ((null? rest)

341 (let ((offered (read-cap-ls session max-lines)))

342 (if (not offered)

343 #f

344 (let* ((want (if include-sasl?

345 (append-new-caps desired (list "sasl"))

346 desired))

347 (requested (filter-offered want offered)))

348 (set-irc-ws-session-server-caps! session offered)

349 (if (null? requested)

350 (begin

351 (irc-ws-cap-end session)

352 '())

353 (begin

354 (irc-ws-command session "CAP" "REQ" (join-caps requested))

355 requested))))))

356 ((and (pair? rest) (eq? (car rest) include-sasl?:))

357 (parse-opts (cddr rest) (cadr rest) max-lines))

358 ((and (pair? rest) (eq? (car rest) max-lines:))

359 (parse-opts (cddr rest) include-sasl? (cadr rest)))

360 (else

361 (error "irc-ws-cap-req-from-ls: unknown option")))))

362

363 (define (irc-ws-cap-ack session . opts)

364 (: irc-ws-session? any? ... -> list?)

365 (let parse-opts ((rest opts)

366 (max-lines 80))

367 (cond

368 ((null? rest)

369 (let ((reply (read-cap-ack-or-nak session max-lines)))

370 (if (not reply)

371 #f

372 (let ((acked (if (equal? (cap-subcommand reply) "ACK")

373 (split-caps (cap-body reply))

374 '())))

375 (set-irc-ws-session-enabled-caps! session acked)

376 acked))))

377 ((and (pair? rest) (eq? (car rest) max-lines:))

378 (parse-opts (cddr rest) (cadr rest)))

379 (else

380 (error "irc-ws-cap-ack: unknown option")))))

381

382 (define (irc-ws-cap-end session)

383 (: irc-ws-session? -> void?)

384 (irc-ws-command session "CAP" "END"))

385

386 (define (irc-ws-authenticate-plain-start session)

387 (: irc-ws-session? -> void?)

388 (irc-ws-command session "AUTHENTICATE" "PLAIN"))

389

390 (define (irc-ws-authenticate-plain-payload session authcid password . authzid)

391 (: irc-ws-session? string? string? any? ... -> boolean?)

392 (let ((prompt (read-until-command session "AUTHENTICATE" 40)))

393 (if (not prompt)

394 #f

395 (let ((arg (let ((params (irc-message-params prompt)))

396 (and (pair? params) (car params)))))

397 (if (not (equal? arg "+"))

398 #f

399 (begin

400 (irc-ws-command session

401 "AUTHENTICATE"

402 (apply sasl-plain-payload

403 authcid

404 password

405 authzid))

406 #t))))))

407

408 (define (irc-ws-authenticate-finish session . opts)

409 (: irc-ws-session? any? ... -> boolean?)

410 (let parse-opts ((rest opts)

411 (max-lines 80))

412 (cond

413 ((null? rest)

414 (let ((result

415 (let loop ((n 0))

416 (if (>= n max-lines)

417 #f

418 (let ((msg (read-next-irc-message session 1)))

419 (cond

420 ((not msg) (loop (+ n 1)))

421 ((message-command=? msg "903") msg)

422 ((or (message-command=? msg "904")

423 (message-command=? msg "905")

424 (message-command=? msg "906")

425 (message-command=? msg "907"))

426 msg)

427 (else (loop (+ n 1)))))))))

428 (cond

429 ((and result (message-command=? result "903"))

430 (set-irc-ws-session-sasl-result! session 'success)

431 #t)

432 ((irc-message? result)

433 (set-irc-ws-session-sasl-result!

434 session

435 (irc-message-command result))

436 #f)

437 (else #f))))

438 ((and (pair? rest) (eq? (car rest) max-lines:))

439 (parse-opts (cddr rest) (cadr rest)))

440 (else

441 (error "irc-ws-authenticate-finish: unknown option")))))

442

443 (define (irc-ws-negotiate-caps session desired . opts)

444 (: irc-ws-session? list? any? ... -> list?)

445 (let parse-opts ((rest opts)

446 (sasl-authcid #f)

447 (sasl-password #f)

448 (max-lines 80))

449 (cond

450 ((null? rest)

451 (irc-ws-command session "CAP" "LS" "302")

452 (let ((offered (read-cap-ls session max-lines)))

453 (if (not offered)

454 #f

455 (let* ((want (if sasl-password

456 (append-new-caps desired (list "sasl"))

457 desired))

458 (requested (filter-offered want offered)))

459 (set-irc-ws-session-server-caps! session offered)

460 (if (null? requested)

461 (begin

462 (irc-ws-command session "CAP" "END")

463 '())

464 (begin

465 (irc-ws-command session "CAP" "REQ" (join-caps requested))

466 (let ((reply (read-cap-ack-or-nak session max-lines)))

467 (if (not reply)

468 #f

469 (let ((acked (if (equal? (cap-subcommand reply) "ACK")

470 (split-caps (cap-body reply))

471 '())))

472 (set-irc-ws-session-enabled-caps! session acked)

473 (cond

474 ((and sasl-password (member "sasl" acked))

475 (let ((ok (irc-ws-authenticate-plain

476 session

477 (or sasl-authcid

478 (irc-ws-session-nick session))

479 sasl-password)))

480 (irc-ws-command session "CAP" "END")

481 (if ok acked #f)))

482 (else

483 (irc-ws-command session "CAP" "END")

484 acked)))))))))))

485 ((and (pair? rest) (eq? (car rest) sasl-authcid:))

486 (parse-opts (cddr rest) (cadr rest) sasl-password max-lines))

487 ((and (pair? rest) (eq? (car rest) sasl-password:))

488 (parse-opts (cddr rest) sasl-authcid (cadr rest) max-lines))

489 ((and (pair? rest) (eq? (car rest) max-lines:))

490 (parse-opts (cddr rest) sasl-authcid sasl-password (cadr rest)))

491 (else

492 (error "irc-ws-negotiate-caps: unknown option")))))

493

494 (define (irc-ws-register-with-caps session desired . opts)

495 (: irc-ws-session? list? any? ... -> list?)

496 (let ((acked (apply irc-ws-negotiate-caps session desired opts)))

497 (if (not acked)

498 #f

499 (begin

500 (irc-ws-register session)

501 acked))))

502

503 (define (irc-ws-connect . args)

504 (: any? ... -> any?)

505 (let ((session

506 (if (and (pair? args) (irc-ws-session? (car args)))

507 (car args)

508 (apply make-irc-ws-session args))))

509 (when (not (eq? (irc-ws-session-state session) 'disconnected))

510 (error "irc-ws-connect: already connected or connecting"))

511 (set-irc-ws-session-state! session 'connecting)

512 (let ((websocket

513 (ws-connect (irc-ws-session-url session)

514 connect-timeout-ms: (irc-ws-session-connect-timeout-ms session)

515 handshake-timeout-ms: (irc-ws-session-handshake-timeout-ms session)

516 upgrade-timeout-ms: (irc-ws-session-upgrade-timeout-ms session))))

517 (if (not websocket)

518 (begin

519 (set-irc-ws-session-state! session 'disconnected)

520 #f)

521 (begin

522 (set-irc-ws-session-websocket! session websocket)

523 (set-irc-ws-session-state! session 'connected)

524 session)))))

525

526 (define (irc-ws-connected? session)

527 (: irc-ws-session? -> boolean?)

528 (and (eq? (irc-ws-session-state session) 'connected)

529 (irc-ws-session-websocket session)

530 (ws-connected? (irc-ws-session-websocket session))))

531

532 (define (irc-ws-close session)

533 (: irc-ws-session? -> void?)

534 (when (irc-ws-session-websocket session)

535 (ws-close (irc-ws-session-websocket session)))

536 (set-irc-ws-session-websocket! session #f)

537 (set-irc-ws-session-state! session 'disconnected)

538 (set-irc-ws-session-buffer! session "")

539 (set-irc-ws-session-queue! session '()))

540

541 (define (irc-ws-send session line)

542 (: irc-ws-session? string? -> void?)

543 (unless (irc-ws-connected? session)

544 (error "irc-ws-send: session is not connected"))

545 (ws-send (irc-ws-session-websocket session) line))

546

547 (define (irc-ws-command session command . args)

548 (: irc-ws-session? string? string? ... -> void?)

549 (irc-ws-send session

550 (apply make-irc-command command args)))

551

552 (define (irc-ws-privmsg session target text)

553 (: irc-ws-session? string? string? -> void?)

554 (irc-ws-send session

555 (make-trailing-command "PRIVMSG" target text)))

556

557 (define (irc-ws-notice session target text)

558 (: irc-ws-session? string? string? -> void?)

559 (irc-ws-send session

560 (make-trailing-command "NOTICE" target text)))

561

562 (define (irc-ws-join session channel . key)

563 (: irc-ws-session? string? string? ... -> void?)

564 (if (pair? key)

565 (irc-ws-command session "JOIN" channel (car key))

566 (irc-ws-command session "JOIN" channel)))

567

568 (define (irc-ws-part session channel . message)

569 (: irc-ws-session? string? string? ... -> void?)

570 (if (pair? message)

571 (irc-ws-send session

572 (make-trailing-command "PART" channel (car message)))

573 (irc-ws-command session "PART" channel)))

574

575 (define (irc-ws-quit session . message)

576 (: irc-ws-session? string? ... -> void?)

577 (when (irc-ws-connected? session)

578 (if (pair? message)

579 (irc-ws-send session (make-trailing-command "QUIT" (car message)))

580 (irc-ws-command session "QUIT")))

581 (irc-ws-close session))

582

583 (define (irc-ws-receive-line session)

584 (: irc-ws-session? -> any?)

585 ;; Enclave sends one IRC command per WebSocket text message. Return that

586 ;; transport payload directly: routing it through the parsed IRC queue is

587 ;; both unnecessary and unsafe for opaque stream tickets in native builds.

588 (let ((websocket (irc-ws-session-websocket session)))

589 (if (not websocket)

590 'closed

591 (let ((message (ws-receive websocket)))

592 (cond

593 ;; This is the raw transport API. Preserve the WebSocket text

594 ;; payload exactly; callers that consume IRC lines already own

595 ;; CRLF splitting. Besides avoiding duplicate work, this keeps

596 ;; opaque Enclave stream tickets out of the generic line helper.

597 ;; ws-receive is back on the MESSAGE path (binary frames must

598 ;; flow for the terminal stream relay), so unwrap text here.

599 ((and (ws-message? message)

600 (eq? (ws-message-type message) 'text))

601 (ws-message-data message))

602 ((string? message) message)

603 ;; Latch the session dead ONLY on a genuine close. This relies

604 ;; on ws-receive returning #f while an async socket is opening.

605 ((eq? message 'closed)

606 (set-irc-ws-session-state! session 'disconnected)

607 'closed)

608 (else message))))))

609

610 (define (irc-ws-receive session)

611 (: irc-ws-session? -> any?)

612 (let ((queued (pop-message! session)))

613 (if queued

614 queued

615 (let ((websocket (irc-ws-session-websocket session)))

616 (if (not websocket)

617 'closed

618 (let ((message (ws-receive websocket)))

619 (cond

620 ((ws-message? message)

621 (if (eq? (ws-message-type message) 'text)

622 (begin

623 (enqueue-message! session (ws-message-data message))

624 (pop-message! session))

625 #f))

626 ;; Latch the session dead ONLY on a genuine close. This

627 ;; relies on ws-receive returning #f (not 'closed) while a

628 ;; browser socket is still in its async CONNECTING window

629 ;; — otherwise the first poll during that window would

630 ;; kill a connection that is merely opening slowly (the

631 ;; browser slow-open bug fixed in (sigil websocket)

632 ;; ws-receive). Do not relax that invariant without

633 ;; distinguishing connecting from closed here too.

634 ((eq? message 'closed)

635 (set-irc-ws-session-state! session 'disconnected)

636 'closed)

637 (else message)))))))

638

639 )))