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)

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

26 irc-ws-session-state

27 irc-ws-session-server-caps

28 irc-ws-session-enabled-caps

29 irc-ws-session-sasl-result

31 irc-ws-connect

32 irc-ws-close

33 irc-ws-connected?

34 irc-ws-register

35 irc-ws-negotiate-caps

36 irc-ws-authenticate-plain

37 irc-ws-register-with-caps

38 irc-ws-cap-ls

39 irc-ws-cap-req-from-ls

40 irc-ws-cap-ack

41 irc-ws-cap-end

42 irc-ws-authenticate-plain-start

43 irc-ws-authenticate-plain-payload

44 irc-ws-authenticate-finish

46 irc-ws-send

47 irc-ws-command

48 irc-ws-privmsg

49 irc-ws-notice

50 irc-ws-join

51 irc-ws-part

52 irc-ws-quit

54 irc-ws-receive)

56 (begin

58 (define-struct irc-ws-session

59 (url)

60 (nick default: #f)

61 (user default: #f)

62 (realname default: "")

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

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

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

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

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

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

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

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

72 (nick #f)

73 (user #f)

74 (realname "")))

75 (: (url: any?) (nick: any?) (user: any?) (realname: string?) -> irc-ws-session?)

76 (unless url

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

78 (irc-ws-session

79 url: url

80 nick: nick

81 user: (or user nick)

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

84 (define (strip-line-ending line)

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

86 (cond

87 ((and (> len 0)

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

89 (let ((end (- len 1)))

90 (if (and (> end 0)

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

92 (substring line 0 (- end 1))

93 (substring line 0 end))))

94 (else line))))

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

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

98 #t

99 #f))

100

101 (define (enqueue-lines! session text)

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

103 (let loop ((buffer combined)

104 (lines '()))

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

106 (if newline-pos

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

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

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

110 (begin

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

112 (when (pair? lines)

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

114 session

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

116 (reverse lines))))))))))

117

118 (define (enqueue-message! session text)

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

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

121 (enqueue-lines! session text)

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

123 session

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

125 (list text)))))

126

127 (define (pop-message! session)

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

129 (if (null? queue)

130 #f

131 (let ((line (car queue)))

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

133 (parse-irc-message line)))))

134

135 (define base64-alphabet

136 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")

137

138 (define (base64-char n)

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

140

141 (define (base64-encode-string input)

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

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

144 (if (>= i len)

145 (apply string-append (reverse acc))

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

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

148 (b2 (if (> remaining 1)

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

150 0))

151 (b3 (if (> remaining 2)

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

153 0))

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

155 (s1 (quotient n 262144))

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

157 (s3 (remainder (quotient n 64) 64))

158 (s4 (remainder n 64))

159 (chunk

160 (cond

161 ((= remaining 1)

162 (string-append (base64-char s1)

163 (base64-char s2)

164 "=="))

165 ((= remaining 2)

166 (string-append (base64-char s1)

167 (base64-char s2)

168 (base64-char s3)

169 "="))

170 (else

171 (string-append (base64-char s1)

172 (base64-char s2)

173 (base64-char s3)

174 (base64-char s4))))))

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

176

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

178 (base64-encode-string

179 (string-append

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

181 (string #\null)

182 authcid

183 (string #\null)

184 password)))

185

186 (define (line-without-crlf line)

187 (strip-line-ending line))

188

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

190 (for-each

191 (lambda (line)

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

193 lines))

194

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

196 (and (irc-message? msg)

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

198

199 (define (cap-subcommand msg)

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

201 (and (pair? params)

202 (pair? (cdr params))

203 (cadr params))))

204

205 (define (cap-body msg)

206 (or (irc-message-trailing msg)

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

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

209

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

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

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

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

214

215 (define (split-caps text)

216 (if (string=? text "")

217 '()

218 (map

219 (lambda (entry)

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

221 (if eq-pos

222 (substring entry 0 eq-pos)

223 entry)))

224 (string-split text " "))))

225

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

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

228 (cond

229 ((null? rest) acc)

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

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

232

233 (define (filter-offered desired offered)

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

235 (cond

236 ((null? rest) (reverse acc))

237 ((member (car rest) offered)

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

239 (else (loop (cdr rest) acc)))))

240

241 (define (join-caps caps)

242 (string-join caps " "))

243

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

245 (let loop ((n 0))

246 (if (>= n max-lines)

247 #f

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

249 (if (irc-message? msg)

250 msg

251 (loop (+ n 1)))))))

252

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

254 (let loop ((n 0))

255 (if (>= n max-lines)

256 #f

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

258 (cond

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

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

261 (else (loop (+ n 1))))))))

262

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

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

265 (if (>= n max-lines)

266 #f

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

268 (cond

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

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

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

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

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

274 (loop (+ n 1) next)

275 next)))

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

277

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

279 (let loop ((n 0))

280 (if (>= n max-lines)

281 #f

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

283 (cond

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

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

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

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

288 msg)

289 (else (loop (+ n 1))))))))

290

291 (define (irc-ws-register session)

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

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

294 (unless nick

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

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

297 (irc-ws-command session

298 "USER"

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

300 "0"

301 "*"

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

303

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

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

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

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

308 session

309 authcid

310 password

311 authzid))

312 #f

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

314

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

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

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

318

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

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

321 (let parse-opts ((rest opts)

322 (include-sasl? #f)

323 (max-lines 80))

324 (cond

325 ((null? rest)

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

327 (if (not offered)

328 #f

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

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

331 desired))

332 (requested (filter-offered want offered)))

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

334 (if (null? requested)

335 (begin

336 (irc-ws-cap-end session)

337 '())

338 (begin

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

340 requested))))))

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

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

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

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

345 (else

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

347

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

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

350 (let parse-opts ((rest opts)

351 (max-lines 80))

352 (cond

353 ((null? rest)

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

355 (if (not reply)

356 #f

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

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

359 '())))

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

361 acked))))

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

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

364 (else

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

366

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

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

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

370

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

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

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

374

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

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

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

378 (if (not prompt)

379 #f

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

381 (and (pair? params) (car params)))))

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

383 #f

384 (begin

385 (irc-ws-command session

386 "AUTHENTICATE"

387 (apply sasl-plain-payload

388 authcid

389 password

390 authzid))

391 #t))))))

392

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

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

395 (let parse-opts ((rest opts)

396 (max-lines 80))

397 (cond

398 ((null? rest)

399 (let ((result

400 (let loop ((n 0))

401 (if (>= n max-lines)

402 #f

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

404 (cond

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

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

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

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

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

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

411 msg)

412 (else (loop (+ n 1)))))))))

413 (cond

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

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

416 #t)

417 ((irc-message? result)

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

419 session

420 (irc-message-command result))

421 #f)

422 (else #f))))

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

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

425 (else

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

427

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

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

430 (let parse-opts ((rest opts)

431 (sasl-authcid #f)

432 (sasl-password #f)

433 (max-lines 80))

434 (cond

435 ((null? rest)

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

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

438 (if (not offered)

439 #f

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

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

442 desired))

443 (requested (filter-offered want offered)))

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

445 (if (null? requested)

446 (begin

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

448 '())

449 (begin

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

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

452 (if (not reply)

453 #f

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

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

456 '())))

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

458 (cond

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

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

461 session

462 (or sasl-authcid

463 (irc-ws-session-nick session))

464 sasl-password)))

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

466 (if ok acked #f)))

467 (else

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

469 acked)))))))))))

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

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

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

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

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

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

476 (else

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

478

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

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

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

482 (if (not acked)

483 #f

484 (begin

485 (irc-ws-register session)

486 acked))))

487

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

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

490 (let ((session

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

492 (car args)

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

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

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

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

497 (let ((websocket (ws-connect (irc-ws-session-url session))))

498 (if (not websocket)

499 (begin

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

501 #f)

502 (begin

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

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

505 session)))))

506

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

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

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

510 (irc-ws-session-websocket session)

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

512

513 (define (irc-ws-close session)

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

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

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

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

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

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

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

521

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

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

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

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

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

527

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

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

530 (irc-ws-send session

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

532

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

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

535 (irc-ws-send session

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

537

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

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

540 (irc-ws-send session

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

542

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

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

545 (if (pair? key)

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

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

548

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

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

551 (if (pair? message)

552 (irc-ws-send session

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

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

555

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

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

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

559 (if (pair? message)

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

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

562 (irc-ws-close session))

563

564 (define (irc-ws-receive session)

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

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

567 (if queued

568 queued

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

570 (if (not websocket)

571 'closed

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

573 (cond

574 ((ws-message? message)

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

576 (begin

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

578 (pop-message! session))

579 #f))

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

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

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

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

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

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

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

587 ;; distinguishing connecting from closed here too.

588 ((eq? message 'closed)

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

590 'closed)

591 (else message)))))))

592

593 )))