src/sigil/xmpp/connection.sgl

1;;; (sigil xmpp connection) - XMPP Connection Lifecycle

2;;;

3;;; Manages XMPP connections with STARTTLS, SASL authentication,

4;;; resource binding, stanza dispatch, and cooperative I/O.

6(define-library (sigil xmpp connection)

7 (import (sigil core)

8 (sigil string)

9 (sigil struct)

10 (sigil socket)

11 (sigil tls)

12 (sigil crypto)

13 (sigil channels)

14 (sigil async)

15 (sigil sxml)

16 (sigil sxml reader)

17 (sigil xmpp stanza)

18 (sigil xmpp sasl)

19 (scheme base))

21 (export

22 ;; Connection record

23 xmpp-connection

24 make-xmpp-connection

25 xmpp-connection?

26 xmpp-connection-server

27 xmpp-connection-port

28 xmpp-connection-jid

29 xmpp-connection-password

30 xmpp-connection-state

31 xmpp-connection-bound-jid

33 ;; Connection lifecycle

34 xmpp-connect

35 xmpp-disconnect

36 xmpp-connected?

38 ;; Event handling (callback interface)

39 xmpp-on-stanza

40 xmpp-on

41 xmpp-send-iq

43 ;; Channel interface

44 xmpp-channel

46 ;; I/O

47 xmpp-send

48 xmpp-send-raw

49 xmpp-process-input

51 ;; Event loop

52 xmpp-run

53 xmpp-tick

55 ;; Presence

56 xmpp-send-presence

58 ;; Internal (for feature modules)

59 xmpp-connection-event-handlers

60 set-xmpp-connection-event-handlers!

61 xmpp-connection-iq-callbacks

62 set-xmpp-connection-iq-callbacks!)

64 (begin

66 ;; ============================================================

67 ;; Connection Record

68 ;; ============================================================

70 (define-struct xmpp-connection

71 ;; Configuration (immutable)

72 (server)

73 (port default: 5222)

74 (jid)

75 (password)

76 (resource default: "sigil")

78 ;; State (mutable)

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

80 (socket default: #f mutable: #t)

81 (tls-conn default: #f mutable: #t)

82 (reader default: #f mutable: #t)

83 (bound-jid default: #f mutable: #t)

84 (sasl-state default: #f mutable: #t)

86 ;; Handlers (mutable)

87 (stanza-handlers default: '() mutable: #t)

88 (event-handlers default: #{} mutable: #t)

89 (iq-callbacks default: #{} mutable: #t)

91 ;; Channels (mutable)

92 (broadcasts default: #{} mutable: #t))

95 ;; ============================================================

96 ;; Connection Constructor

97 ;; ============================================================

99 ;;; Create a new XMPP connection (does not connect yet).

100 ;;;

101 ;;; ```scheme

102 ;;; (make-xmpp-connection

103 ;;; server: "example.com"

104 ;;; jid: "[email protected]"

105 ;;; password: "secret"

106 ;;; resource: "bot")

107 ;;; ```

108 (define (make-xmpp-connection (keys: (server #f)

109 (port 5222)

110 (jid #f)

111 (password #f)

112 (resource "sigil")))

113 (: (server: any?) (port: integer?) (jid: any?) (password: any?) (resource: string?) -> xmpp-connection?)

114 (unless server

115 (error "make-xmpp-connection: server: is required"))

116 (unless jid

117 (error "make-xmpp-connection: jid: is required"))

118 (unless password

119 (error "make-xmpp-connection: password: is required"))

120 (xmpp-connection

121 server: server

122 port: port

123 jid: jid

124 password: password

125 resource: resource))

126

127 ;;; Check if connection is in connected state.

128 (define (xmpp-connected? conn)

129 (: xmpp-connection? -> boolean?)

130 (eq? (xmpp-connection-state conn) 'connected))

131

132

133 ;; ============================================================

134 ;; I/O Abstraction

135 ;; ============================================================

136

137 ;; Write to the connection (dispatches to socket or TLS)

138 (define (conn-write conn data)

139 (let ((tls (xmpp-connection-tls-conn conn))

140 (sock (xmpp-connection-socket conn)))

141 (if tls

142 (tls-write tls data)

143 (when sock (socket-write sock data)))))

144

145 ;; Read from the connection

146 (define (conn-read conn)

147 (let ((tls (xmpp-connection-tls-conn conn))

148 (sock (xmpp-connection-socket conn)))

149 (if tls

150 (tls-read tls)

151 (when sock (socket-read sock)))))

152

153 ;; Get the socket object for select/await (even after TLS upgrade)

154 (define (conn-socket conn)

155 (or (xmpp-connection-tls-conn conn)

156 (xmpp-connection-socket conn)))

157

158

159 ;; ============================================================

160 ;; Stream Management

161 ;; ============================================================

162

163 ;; Open an XML stream to the server

164 (define (open-stream conn)

165 (let ((jid-obj (parse-jid (xmpp-connection-jid conn))))

166 (conn-write conn

167 (string-append

168 "<?xml version='1.0'?>"

169 "<stream:stream"

170 " xmlns='jabber:client'"

171 " xmlns:stream='http://etherx.jabber.org/streams'"

172 " to='" (jid-domain jid-obj) "'"

173 " version='1.0'>"))))

174

175 ;; Reset the stanza reader for a new stream

176 (define (reset-stream conn)

177 (let ((reader (xmpp-connection-reader conn)))

178 (when reader

179 (stanza-reader-reset! reader)))

180 (set-xmpp-connection-reader! conn (make-stanza-reader)))

181

182

183 ;; ============================================================

184 ;; Event Handling

185 ;; ============================================================

186

187 ;;; Register a handler for all incoming stanzas.

188 (define (xmpp-on-stanza conn handler)

189 (: xmpp-connection? procedure? -> void?)

190 (set-xmpp-connection-stanza-handlers!

191 conn

192 (cons handler (xmpp-connection-stanza-handlers conn))))

193

194 ;;; Register a handler for a specific event type.

195 ;;;

196 ;;; Event types: 'message, 'presence, 'iq, 'connected,

197 ;;; 'disconnected, 'error

198 (define (xmpp-on conn event handler)

199 (: xmpp-connection? symbol? procedure? -> void?)

200 (let* ((handlers (xmpp-connection-event-handlers conn))

201 (existing (dict-ref handlers event '())))

202 (set-xmpp-connection-event-handlers!

203 conn

204 (dict-set handlers event (cons handler existing)))))

205

206 ;; Fire an event to registered handlers

207 (define (fire-event conn event . args)

208 (let ((handlers (dict-ref (xmpp-connection-event-handlers conn) event '())))

209 (for-each (lambda (handler) (apply handler args))

210 handlers))

211 ;; Also send to broadcast channel if one exists

212 (let ((bc (dict-ref (xmpp-connection-broadcasts conn) event #f)))

213 (when (and bc (pair? args))

214 (broadcast-send bc (car args)))))

215

216 ;;; Get a channel for receiving events of a given type.

217 ;;;

218 ;;; Creates a broadcast subscription. Use with `channel-receive`

219 ;;; or `for-channel`.

220 ;;;

221 ;;; ```scheme

222 ;;; (let ((msgs (xmpp-channel conn 'message)))

223 ;;; (for-channel msgs

224 ;;; (lambda (stanza)

225 ;;; (display (message-body stanza)))))

226 ;;; ```

227 (define (xmpp-channel conn event)

228 (: xmpp-connection? symbol? -> any?)

229 (let* ((broadcasts (xmpp-connection-broadcasts conn))

230 (bc (dict-ref broadcasts event #f)))

231 ;; Create broadcast if it doesn't exist yet

232 (let ((bc (or bc (let ((new-bc (make-broadcast)))

233 (set-xmpp-connection-broadcasts!

234 conn

235 (dict-set broadcasts event new-bc))

236 new-bc))))

237 (broadcast-subscribe bc))))

238

239 ;; Dispatch a stanza to handlers

240 (define (dispatch-stanza conn stanza)

241 ;; Call general stanza handlers

242 (for-each (lambda (handler) (handler stanza))

243 (xmpp-connection-stanza-handlers conn))

244

245 ;; Fire event based on stanza type

246 (let ((type (stanza-type stanza)))

247 (when type

248 (fire-event conn type stanza)

249 (fire-event conn 'stanza stanza)))

250

251 ;; Handle IQ callbacks

252 (when (eq? (stanza-type stanza) 'iq)

253 (let* ((id (stanza-id stanza))

254 (callbacks (xmpp-connection-iq-callbacks conn))

255 (cb (and id (dict-ref callbacks id #f))))

256 (when cb

257 (set-xmpp-connection-iq-callbacks!

258 conn

259 (dict-remove callbacks id))

260 (cb stanza)))))

261

262

263 ;; ============================================================

264 ;; Sending

265 ;; ============================================================

266

267 ;;; Send a stanza (SXML) to the server.

268 ;;;

269 ;;; ```scheme

270 ;;; (xmpp-send conn (xmpp-message to: "[email protected]" body: "Hi"))

271 ;;; ```

272 (define (xmpp-send conn stanza)

273 (: xmpp-connection? list? -> void?)

274 (conn-write conn (stanza->xml stanza)))

275

276 ;;; Send raw XML string to the server.

277 (define (xmpp-send-raw conn data)

278 (: xmpp-connection? string? -> void?)

279 (conn-write conn data))

280

281 ;;; Send an IQ stanza and register a callback for the response.

282 ;;;

283 ;;; The callback receives the response stanza.

284 ;;;

285 ;;; ```scheme

286 ;;; (xmpp-send-iq conn

287 ;;; (xmpp-iq type: "get" children: '((query (@ (xmlns "jabber:iq:roster")))))

288 ;;; (lambda (response) (display "Got roster\n")))

289 ;;; ```

290 (define (xmpp-send-iq conn stanza callback)

291 (: xmpp-connection? list? procedure? -> void?)

292 (let ((id (stanza-id stanza)))

293 (when id

294 (set-xmpp-connection-iq-callbacks!

295 conn

296 (dict-set (xmpp-connection-iq-callbacks conn)

297 id callback)))

298 (xmpp-send conn stanza)))

299

300 ;;; Send initial presence to indicate availability.

301 (define (xmpp-send-presence conn . args)

302 (: xmpp-connection? any? ... -> void?)

303 (xmpp-send conn (apply xmpp-presence args)))

304

305

306 ;; ============================================================

307 ;; Connection Flow

308 ;; ============================================================

309

310 ;;; Connect to the XMPP server.

311 ;;;

312 ;;; Performs the full XMPP connection sequence:

313 ;;; TCP connect -> stream open -> STARTTLS -> SASL auth -> bind

314 ;;;

315 ;;; Returns #t on success, #f on failure.

316 (define (xmpp-connect conn)

317 (: xmpp-connection? -> boolean?)

318 (when (not (eq? (xmpp-connection-state conn) 'disconnected))

319 (error "xmpp-connect: already connected or connecting"))

320

321 (set-xmpp-connection-state! conn 'connecting)

322

323 ;; TCP connect

324 (let ((sock (tcp-connect (xmpp-connection-server conn)

325 (xmpp-connection-port conn))))

326 (if (not sock)

327 (begin

328 (set-xmpp-connection-state! conn 'disconnected)

329 #f)

330 (begin

331 (set-xmpp-connection-socket! conn sock)

332 (set-xmpp-connection-reader! conn (make-stanza-reader))

333 (set-xmpp-connection-state! conn 'stream-open)

334

335 ;; Open initial stream

336 (open-stream conn)

337

338 ;; Process the connection handshake synchronously

339 (run-handshake conn)))))

340

341 ;; Run the XMPP handshake (blocking until connected or failure)

342 (define (run-handshake conn)

343 (let loop ()

344 (let ((state (xmpp-connection-state conn)))

345 (cond

346 ((eq? state 'connected) #t)

347 ((eq? state 'disconnected) #f)

348 (else

349 ;; Read and process data

350 (let ((data (conn-read conn)))

351 (cond

352 ((or (not data) (eof-object? data))

353 (set-xmpp-connection-state! conn 'disconnected)

354 #f)

355 ((string=? data "") (loop))

356 (else

357 (process-handshake-data conn data)

358 (loop)))))))))

359

360 ;; Process incoming data during handshake

361 (define (process-handshake-data conn data)

362 (let ((reader (xmpp-connection-reader conn)))

363 (stanza-reader-feed! reader data)

364 (let ((stanzas (stanza-reader-stanzas! reader)))

365 (for-each (lambda (stanza) (handle-handshake-stanza conn stanza))

366 stanzas))))

367

368 ;; Handle stanzas during the handshake phase

369 (define (handle-handshake-stanza conn stanza)

370 (let ((state (xmpp-connection-state conn))

371 (type (stanza-type stanza)))

372 (cond

373 ;; Waiting for features after stream open

374 ((and (eq? state 'stream-open)

375 (eq? type 'stream:features))

376 (handle-features conn stanza))

377

378 ;; STARTTLS negotiation

379 ((and (eq? state 'starttls-negotiating)

380 (eq? type 'proceed))

381 (handle-starttls-proceed conn))

382

383 ;; SASL challenge

384 ((and (eq? state 'authenticating)

385 (eq? type 'challenge))

386 (handle-sasl-challenge conn stanza))

387

388 ;; SASL success

389 ((and (eq? state 'authenticating)

390 (eq? type 'success))

391 (handle-sasl-success conn stanza))

392

393 ;; SASL failure

394 ((and (eq? state 'authenticating)

395 (eq? type 'failure))

396 (handle-sasl-failure conn stanza))

397

398 ;; Bind response

399 ((and (eq? state 'binding)

400 (eq? type 'iq))

401 (handle-bind-response conn stanza))

402

403 ;; Features after auth (look for bind)

404 ((and (eq? state 'authenticated)

405 (eq? type 'stream:features))

406 (handle-post-auth-features conn stanza)))))

407

408

409 ;; ============================================================

410 ;; Feature Negotiation

411 ;; ============================================================

412

413 ;; Handle stream features

414 (define (handle-features conn features)

415 (cond

416 ;; STARTTLS available

417 ((stanza-child features 'starttls)

418 (set-xmpp-connection-state! conn 'starttls-negotiating)

419 (conn-write conn "<starttls xmlns='urn:ietf:params:xml:ns:xmpp-tls'/>"))

420

421 ;; SASL mechanisms available

422 ((stanza-child features 'mechanisms)

423 (begin-sasl conn features))

424

425 ;; Bind available

426 ((stanza-child features 'bind)

427 (begin-bind conn))))

428

429

430 ;; ============================================================

431 ;; STARTTLS

432 ;; ============================================================

433

434 (define (handle-starttls-proceed conn)

435 ;; Upgrade socket to TLS

436 (let* ((sock (xmpp-connection-socket conn))

437 (server (xmpp-connection-server conn))

438 (tls (tls-upgrade sock server)))

439 (if (not tls)

440 (begin

441 (set-xmpp-connection-state! conn 'disconnected)

442 (fire-event conn 'error "STARTTLS handshake failed"))

443 (begin

444 (set-xmpp-connection-tls-conn! conn tls)

445 ;; Restart stream

446 (reset-stream conn)

447 (set-xmpp-connection-state! conn 'stream-open)

448 (open-stream conn)))))

449

450

451 ;; ============================================================

452 ;; SASL Authentication

453 ;; ============================================================

454

455 (define (begin-sasl conn features)

456 (let* ((mechanisms-el (stanza-child features 'mechanisms))

457 (mechanism-els (if mechanisms-el

458 (stanza-children mechanisms-el 'mechanism)

459 '()))

460 (mechanism-names (map (lambda (el) (sxml-text el))

461 mechanism-els))

462 (selected (select-sasl-mechanism mechanism-names)))

463 (cond

464 ((eq? selected 'scram-sha-1)

465 (let* ((jid-obj (parse-jid (xmpp-connection-jid conn)))

466 (username (jid-local jid-obj))

467 (scram (make-scram-sha1 username (xmpp-connection-password conn)))

468 (initial (scram-initial-message scram)))

469 (set-xmpp-connection-sasl-state! conn scram)

470 (set-xmpp-connection-state! conn 'authenticating)

471 (conn-write conn

472 (string-append

473 "<auth xmlns='urn:ietf:params:xml:ns:xmpp-sasl'"

474 " mechanism='SCRAM-SHA-1'>"

475 initial "</auth>"))))

476

477 ((eq? selected 'plain)

478 (let* ((jid-obj (parse-jid (xmpp-connection-jid conn)))

479 (username (jid-local jid-obj))

480 (response (sasl-plain-response username

481 (xmpp-connection-password conn))))

482 (set-xmpp-connection-state! conn 'authenticating)

483 (conn-write conn

484 (string-append

485 "<auth xmlns='urn:ietf:params:xml:ns:xmpp-sasl'"

486 " mechanism='PLAIN'>"

487 response "</auth>"))))

488

489 (else

490 (set-xmpp-connection-state! conn 'disconnected)

491 (fire-event conn 'error "No supported SASL mechanism")))))

492

493 (define (handle-sasl-challenge conn stanza)

494 (let ((scram (xmpp-connection-sasl-state conn))

495 (challenge-text (sxml-text stanza)))

496 (if (and scram challenge-text)

497 (let ((response (scram-challenge-response scram challenge-text)))

498 (conn-write conn

499 (string-append "<response xmlns='urn:ietf:params:xml:ns:xmpp-sasl'>"

500 response "</response>")))

501 (begin

502 (set-xmpp-connection-state! conn 'disconnected)

503 (fire-event conn 'error "SASL challenge failed")))))

504

505 (define (handle-sasl-success conn stanza)

506 (let ((scram (xmpp-connection-sasl-state conn))

507 (server-data (sxml-text stanza)))

508 ;; Verify server signature if SCRAM

509 (when (and scram server-data)

510 (unless (scram-verify-server scram server-data)

511 (fire-event conn 'error "SCRAM server verification failed")))

512

513 (set-xmpp-connection-sasl-state! conn #f)

514 (set-xmpp-connection-state! conn 'authenticated)

515

516 ;; Restart stream after auth

517 (reset-stream conn)

518 (open-stream conn)))

519

520 (define (handle-sasl-failure conn stanza)

521 (set-xmpp-connection-state! conn 'disconnected)

522 (fire-event conn 'error

523 (string-append "SASL authentication failed: "

524 (or (sxml-text stanza) "unknown error"))))

525

526

527 ;; ============================================================

528 ;; Resource Binding

529 ;; ============================================================

530

531 (define (handle-post-auth-features conn features)

532 (when (stanza-child features 'bind)

533 (begin-bind conn)))

534

535 (define (begin-bind conn)

536 (set-xmpp-connection-state! conn 'binding)

537 (let ((resource (xmpp-connection-resource conn)))

538 (xmpp-send-raw conn

539 (stanza->xml

540 (xmpp-iq type: "set" id: "bind-1"

541 children: (list

542 (if resource

543 `(bind (@ (xmlns "urn:ietf:params:xml:ns:xmpp-bind"))

544 (resource ,resource))

545 '(bind (@ (xmlns "urn:ietf:params:xml:ns:xmpp-bind"))))))))))

546

547 (define (handle-bind-response conn stanza)

548 (let ((type (stanza-attr stanza 'type)))

549 (cond

550 ((equal? type "result")

551 (let* ((bind-el (stanza-child stanza 'bind))

552 (jid-el (and bind-el (stanza-child bind-el 'jid)))

553 (bound-jid (and jid-el (sxml-text jid-el))))

554 (set-xmpp-connection-bound-jid! conn bound-jid)

555 (set-xmpp-connection-state! conn 'connected)

556 (fire-event conn 'connected conn)))

557

558 (else

559 (set-xmpp-connection-state! conn 'disconnected)

560 (fire-event conn 'error "Resource binding failed")))))

561

562

563 ;; ============================================================

564 ;; Disconnection

565 ;; ============================================================

566

567 ;;; Disconnect from the XMPP server.

568 (define (xmpp-disconnect conn)

569 (: xmpp-connection? -> void?)

570 (when (conn-socket conn)

571 ;; Send stream close

572 (when (memq (xmpp-connection-state conn) '(connected authenticated binding))

573 (conn-write conn "</stream:stream>"))

574

575 ;; Close connections

576 (let ((tls (xmpp-connection-tls-conn conn)))

577 (when tls (tls-close tls)))

578 (let ((sock (xmpp-connection-socket conn)))

579 (when (and sock (not (xmpp-connection-tls-conn conn)))

580 (socket-close sock))))

581

582 (set-xmpp-connection-tls-conn! conn #f)

583 (set-xmpp-connection-socket! conn #f)

584 (set-xmpp-connection-state! conn 'disconnected)

585 (fire-event conn 'disconnected conn))

586

587

588 ;; ============================================================

589 ;; Input Processing

590 ;; ============================================================

591

592 ;;; Process available input from the XMPP connection.

593 ;;;

594 ;;; Returns #t if connection is alive, #f if disconnected.

595 (define (xmpp-process-input conn)

596 (: xmpp-connection? -> boolean?)

597 (let ((data (conn-read conn)))

598 (cond

599 ((or (not data) (eof-object? data))

600 (set-xmpp-connection-state! conn 'disconnected)

601 (fire-event conn 'disconnected conn)

602 #f)

603

604 ((string=? data "") #t)

605

606 (else

607 (let ((reader (xmpp-connection-reader conn)))

608 (stanza-reader-feed! reader data)

609 (let ((stanzas (stanza-reader-stanzas! reader)))

610 (for-each (lambda (stanza) (dispatch-stanza conn stanza))

611 stanzas)))

612 #t))))

613

614

615 ;; ============================================================

616 ;; Event Loop

617 ;; ============================================================

618

619 ;;; Process one tick of the XMPP connection (non-blocking).

620 ;;;

621 ;;; Returns #t if connection is alive, #f if disconnected.

622 (define (xmpp-tick conn)

623 (: xmpp-connection? -> boolean?)

624 (let ((sock (conn-socket conn)))

625 (if (not sock)

626 #f

627 (let ((ready (socket-select (list sock) '() 0)))

628 (if (and ready (pair? (car ready)))

629 (xmpp-process-input conn)

630 #t)))))

631

632 ;;; Run the XMPP connection event loop.

633 ;;;

634 ;;; Processes stanzas until disconnected. When running inside a

635 ;;; `with-async` context, cooperates with other tasks via `await-readable`.

636 ;;; Otherwise blocks in a traditional event loop.

637 (define (xmpp-run conn)

638 (: xmpp-connection? -> void?)

639 (let ((sock (conn-socket conn)))

640 (when sock

641 (if (current-scheduler)

642 ;; Cooperative mode

643 (let loop ()

644 (await-readable sock)

645 (when (xmpp-process-input conn)

646 (when (conn-socket conn)

647 (loop))))

648 ;; Blocking mode

649 (let loop ()

650 (let ((ready (socket-select (list sock) '() 1000)))

651 (when (and ready (pair? (car ready)))

652 (xmpp-process-input conn))

653 (when (conn-socket conn)

654 (loop))))))))

655

656 ))