Commitd0891d70Recorded20 Feb 2026Repositorysigil-xmpp
feat: Add XMPP connection lifecycle and top-level re-export module
Message
Connection module implements full XMPP handshake: TCP connect, stream open, STARTTLS upgrade, SASL auth (SCRAM-SHA-1/PLAIN), resource binding. Dual event dispatch via callbacks and channels. Cooperative async I/O with await-readable fallback to socket-select.
Changed
src/sigil/xmpp.sgl | 42 +++++++++++
src/sigil/xmpp/connection.sgl | 636 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2 files changed, 678 insertions(+)Diff
src/sigil/xmpp.sgladded
@@ -0,0 +1,42 @@
+1
;;; (sigil xmpp) - XMPP Client Library+2
;;;+3
;;; Provides a complete XMPP client with STARTTLS, SASL authentication,+4
;;; stanza handling, and cooperative I/O.+5
+6
(define-library (sigil xmpp)+7
(import (sigil xmpp stanza)+8
(sigil xmpp sasl)+9
(sigil xmpp connection))+10
+11
(export+12
;; From (sigil xmpp stanza)+13
;; JID handling+14
jid jid? jid-local jid-domain jid-resource+15
parse-jid jid->string jid-bare+16
;; Stanza constructors+17
xmpp-message xmpp-presence xmpp-iq+18
;; Stanza inspection+19
stanza-type stanza-attr stanza-to stanza-from stanza-id+20
message-body stanza-child stanza-children sxml-text+21
;; ID generation & serialization+22
generate-stanza-id stanza->xml+23
+24
;; From (sigil xmpp sasl)+25
select-sasl-mechanism+26
+27
;; From (sigil xmpp connection)+28
;; Connection+29
make-xmpp-connection xmpp-connection?+30
xmpp-connection-server xmpp-connection-port+31
xmpp-connection-jid xmpp-connection-state+32
xmpp-connection-bound-jid+33
;; Lifecycle+34
xmpp-connect xmpp-disconnect xmpp-connected?+35
;; Events+36
xmpp-on-stanza xmpp-on xmpp-send-iq xmpp-channel+37
;; I/O+38
xmpp-send xmpp-send-raw xmpp-process-input+39
;; Event loop+40
xmpp-run xmpp-tick+41
;; Presence+42
xmpp-send-presence))src/sigil/xmpp/connection.sgladded
@@ -0,0 +1,636 @@
+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.+5
+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))+20
+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+32
+33
;; Connection lifecycle+34
xmpp-connect+35
xmpp-disconnect+36
xmpp-connected?+37
+38
;; Event handling (callback interface)+39
xmpp-on-stanza+40
xmpp-on+41
xmpp-send-iq+42
+43
;; Channel interface+44
xmpp-channel+45
+46
;; I/O+47
xmpp-send+48
xmpp-send-raw+49
xmpp-process-input+50
+51
;; Event loop+52
xmpp-run+53
xmpp-tick+54
+55
;; Presence+56
xmpp-send-presence)+57
+58
(begin+59
+60
;; ============================================================+61
;; Connection Record+62
;; ============================================================+63
+64
(define-struct xmpp-connection+65
;; Configuration (immutable)+66
(server)+67
(port default: 5222)+68
(jid)+69
(password)+70
(resource default: "sigil")+71
+72
;; State (mutable)+73
(state default: 'disconnected mutable: #t)+74
(socket default: #f mutable: #t)+75
(tls-conn default: #f mutable: #t)+76
(reader default: #f mutable: #t)+77
(bound-jid default: #f mutable: #t)+78
(sasl-state default: #f mutable: #t)+79
+80
;; Handlers (mutable)+81
(stanza-handlers default: '() mutable: #t)+82
(event-handlers default: #{} mutable: #t)+83
(iq-callbacks default: #{} mutable: #t)+84
+85
;; Channels (mutable)+86
(broadcasts default: #{} mutable: #t))+87
+88
+89
;; ============================================================+90
;; Connection Constructor+91
;; ============================================================+92
+93
;;; Create a new XMPP connection (does not connect yet).+94
;;;+95
;;; ```scheme+96
;;; (make-xmpp-connection+97
;;; server: "example.com"+98
;;; jid: "[email protected]"+99
;;; password: "secret"+100
;;; resource: "bot")+101
;;; ```+102
(define (make-xmpp-connection (keys: (server #f)+103
(port 5222)+104
(jid #f)+105
(password #f)+106
(resource "sigil")))+107
(unless server+108
(error "make-xmpp-connection: server: is required"))+109
(unless jid+110
(error "make-xmpp-connection: jid: is required"))+111
(unless password+112
(error "make-xmpp-connection: password: is required"))+113
(xmpp-connection+114
server: server+115
port: port+116
jid: jid+117
password: password+118
resource: resource))+119
+120
;;; Check if connection is in connected state.+121
(define (xmpp-connected? conn)+122
(eq? (xmpp-connection-state conn) 'connected))+123
+124
+125
;; ============================================================+126
;; I/O Abstraction+127
;; ============================================================+128
+129
;; Write to the connection (dispatches to socket or TLS)+130
(define (conn-write conn data)+131
(let ((tls (xmpp-connection-tls-conn conn))+132
(sock (xmpp-connection-socket conn)))+133
(if tls+134
(tls-write tls data)+135
(when sock (socket-write sock data)))))+136
+137
;; Read from the connection+138
(define (conn-read conn)+139
(let ((tls (xmpp-connection-tls-conn conn))+140
(sock (xmpp-connection-socket conn)))+141
(if tls+142
(tls-read tls)+143
(when sock (socket-read sock)))))+144
+145
;; Get the socket object for select/await (even after TLS upgrade)+146
(define (conn-socket conn)+147
(or (xmpp-connection-tls-conn conn)+148
(xmpp-connection-socket conn)))+149
+150
+151
;; ============================================================+152
;; Stream Management+153
;; ============================================================+154
+155
;; Open an XML stream to the server+156
(define (open-stream conn)+157
(let ((jid-obj (parse-jid (xmpp-connection-jid conn))))+158
(conn-write conn+159
(string-append+160
"<?xml version='1.0'?>"+161
"<stream:stream"+162
" xmlns='jabber:client'"+163
" xmlns:stream='http://etherx.jabber.org/streams'"+164
" to='" (jid-domain jid-obj) "'"+165
" version='1.0'>"))))+166
+167
;; Reset the stanza reader for a new stream+168
(define (reset-stream conn)+169
(let ((reader (xmpp-connection-reader conn)))+170
(when reader+171
(stanza-reader-reset! reader)))+172
(set-xmpp-connection-reader! conn (make-stanza-reader)))+173
+174
+175
;; ============================================================+176
;; Event Handling+177
;; ============================================================+178
+179
;;; Register a handler for all incoming stanzas.+180
(define (xmpp-on-stanza conn handler)+181
(set-xmpp-connection-stanza-handlers!+182
conn+183
(cons handler (xmpp-connection-stanza-handlers conn))))+184
+185
;;; Register a handler for a specific event type.+186
;;;+187
;;; Event types: 'message, 'presence, 'iq, 'connected,+188
;;; 'disconnected, 'error+189
(define (xmpp-on conn event handler)+190
(let* ((handlers (xmpp-connection-event-handlers conn))+191
(existing (dict-ref handlers event '())))+192
(set-xmpp-connection-event-handlers!+193
conn+194
(dict-set handlers event (cons handler existing)))))+195
+196
;; Fire an event to registered handlers+197
(define (fire-event conn event . args)+198
(let ((handlers (dict-ref (xmpp-connection-event-handlers conn) event '())))+199
(for-each (lambda (handler) (apply handler args))+200
handlers))+201
;; Also send to broadcast channel if one exists+202
(let ((bc (dict-ref (xmpp-connection-broadcasts conn) event #f)))+203
(when (and bc (pair? args))+204
(broadcast-send bc (car args)))))+205
+206
;;; Get a channel for receiving events of a given type.+207
;;;+208
;;; Creates a broadcast subscription. Use with `channel-receive`+209
;;; or `for-channel`.+210
;;;+211
;;; ```scheme+212
;;; (let ((msgs (xmpp-channel conn 'message)))+213
;;; (for-channel msgs+214
;;; (lambda (stanza)+215
;;; (display (message-body stanza)))))+216
;;; ```+217
(define (xmpp-channel conn event)+218
(let* ((broadcasts (xmpp-connection-broadcasts conn))+219
(bc (dict-ref broadcasts event #f)))+220
;; Create broadcast if it doesn't exist yet+221
(let ((bc (or bc (let ((new-bc (make-broadcast)))+222
(set-xmpp-connection-broadcasts!+223
conn+224
(dict-set broadcasts event new-bc))+225
new-bc))))+226
(broadcast-subscribe bc))))+227
+228
;; Dispatch a stanza to handlers+229
(define (dispatch-stanza conn stanza)+230
;; Call general stanza handlers+231
(for-each (lambda (handler) (handler stanza))+232
(xmpp-connection-stanza-handlers conn))+233
+234
;; Fire event based on stanza type+235
(let ((type (stanza-type stanza)))+236
(when type+237
(fire-event conn type stanza)+238
(fire-event conn 'stanza stanza)))+239
+240
;; Handle IQ callbacks+241
(when (eq? (stanza-type stanza) 'iq)+242
(let* ((id (stanza-id stanza))+243
(callbacks (xmpp-connection-iq-callbacks conn))+244
(cb (and id (dict-ref callbacks id #f))))+245
(when cb+246
(set-xmpp-connection-iq-callbacks!+247
conn+248
(dict-remove callbacks id))+249
(cb stanza)))))+250
+251
+252
;; ============================================================+253
;; Sending+254
;; ============================================================+255
+256
;;; Send a stanza (SXML) to the server.+257
;;;+258
;;; ```scheme+259
;;; (xmpp-send conn (xmpp-message to: "[email protected]" body: "Hi"))+260
;;; ```+261
(define (xmpp-send conn stanza)+262
(conn-write conn (stanza->xml stanza)))+263
+264
;;; Send raw XML string to the server.+265
(define (xmpp-send-raw conn data)+266
(conn-write conn data))+267
+268
;;; Send an IQ stanza and register a callback for the response.+269
;;;+270
;;; The callback receives the response stanza.+271
;;;+272
;;; ```scheme+273
;;; (xmpp-send-iq conn+274
;;; (xmpp-iq type: "get" children: '((query (@ (xmlns "jabber:iq:roster")))))+275
;;; (lambda (response) (display "Got roster\n")))+276
;;; ```+277
(define (xmpp-send-iq conn stanza callback)+278
(let ((id (stanza-id stanza)))+279
(when id+280
(set-xmpp-connection-iq-callbacks!+281
conn+282
(dict-set (xmpp-connection-iq-callbacks conn)+283
id callback)))+284
(xmpp-send conn stanza)))+285
+286
;;; Send initial presence to indicate availability.+287
(define (xmpp-send-presence conn . args)+288
(xmpp-send conn (apply xmpp-presence args)))+289
+290
+291
;; ============================================================+292
;; Connection Flow+293
;; ============================================================+294
+295
;;; Connect to the XMPP server.+296
;;;+297
;;; Performs the full XMPP connection sequence:+298
;;; TCP connect -> stream open -> STARTTLS -> SASL auth -> bind+299
;;;+300
;;; Returns #t on success, #f on failure.+301
(define (xmpp-connect conn)+302
(when (not (eq? (xmpp-connection-state conn) 'disconnected))+303
(error "xmpp-connect: already connected or connecting"))+304
+305
(set-xmpp-connection-state! conn 'connecting)+306
+307
;; TCP connect+308
(let ((sock (tcp-connect (xmpp-connection-server conn)+309
(xmpp-connection-port conn))))+310
(if (not sock)+311
(begin+312
(set-xmpp-connection-state! conn 'disconnected)+313
#f)+314
(begin+315
(set-xmpp-connection-socket! conn sock)+316
(set-xmpp-connection-reader! conn (make-stanza-reader))+317
(set-xmpp-connection-state! conn 'stream-open)+318
+319
;; Open initial stream+320
(open-stream conn)+321
+322
;; Process the connection handshake synchronously+323
(run-handshake conn)))))+324
+325
;; Run the XMPP handshake (blocking until connected or failure)+326
(define (run-handshake conn)+327
(let loop ()+328
(let ((state (xmpp-connection-state conn)))+329
(cond+330
((eq? state 'connected) #t)+331
((eq? state 'disconnected) #f)+332
(else+333
;; Read and process data+334
(let ((data (conn-read conn)))+335
(cond+336
((or (not data) (eof-object? data))+337
(set-xmpp-connection-state! conn 'disconnected)+338
#f)+339
((string=? data "") (loop))+340
(else+341
(process-handshake-data conn data)+342
(loop)))))))))+343
+344
;; Process incoming data during handshake+345
(define (process-handshake-data conn data)+346
(let ((reader (xmpp-connection-reader conn)))+347
(stanza-reader-feed! reader data)+348
(let ((stanzas (stanza-reader-stanzas! reader)))+349
(for-each (lambda (stanza) (handle-handshake-stanza conn stanza))+350
stanzas))))+351
+352
;; Handle stanzas during the handshake phase+353
(define (handle-handshake-stanza conn stanza)+354
(let ((state (xmpp-connection-state conn))+355
(type (stanza-type stanza)))+356
(cond+357
;; Waiting for features after stream open+358
((and (eq? state 'stream-open)+359
(eq? type 'stream:features))+360
(handle-features conn stanza))+361
+362
;; STARTTLS negotiation+363
((and (eq? state 'starttls-negotiating)+364
(eq? type 'proceed))+365
(handle-starttls-proceed conn))+366
+367
;; SASL challenge+368
((and (eq? state 'authenticating)+369
(eq? type 'challenge))+370
(handle-sasl-challenge conn stanza))+371
+372
;; SASL success+373
((and (eq? state 'authenticating)+374
(eq? type 'success))+375
(handle-sasl-success conn stanza))+376
+377
;; SASL failure+378
((and (eq? state 'authenticating)+379
(eq? type 'failure))+380
(handle-sasl-failure conn stanza))+381
+382
;; Bind response+383
((and (eq? state 'binding)+384
(eq? type 'iq))+385
(handle-bind-response conn stanza))+386
+387
;; Features after auth (look for bind)+388
((and (eq? state 'authenticated)+389
(eq? type 'stream:features))+390
(handle-post-auth-features conn stanza)))))+391
+392
+393
;; ============================================================+394
;; Feature Negotiation+395
;; ============================================================+396
+397
;; Handle stream features+398
(define (handle-features conn features)+399
(cond+400
;; STARTTLS available+401
((stanza-child features 'starttls)+402
(set-xmpp-connection-state! conn 'starttls-negotiating)+403
(conn-write conn "<starttls xmlns='urn:ietf:params:xml:ns:xmpp-tls'/>"))+404
+405
;; SASL mechanisms available+406
((stanza-child features 'mechanisms)+407
(begin-sasl conn features))+408
+409
;; Bind available+410
((stanza-child features 'bind)+411
(begin-bind conn))))+412
+413
+414
;; ============================================================+415
;; STARTTLS+416
;; ============================================================+417
+418
(define (handle-starttls-proceed conn)+419
;; Upgrade socket to TLS+420
(let* ((sock (xmpp-connection-socket conn))+421
(server (xmpp-connection-server conn))+422
(tls (tls-upgrade sock server)))+423
(if (not tls)+424
(begin+425
(set-xmpp-connection-state! conn 'disconnected)+426
(fire-event conn 'error "STARTTLS handshake failed"))+427
(begin+428
(set-xmpp-connection-tls-conn! conn tls)+429
;; Restart stream+430
(reset-stream conn)+431
(set-xmpp-connection-state! conn 'stream-open)+432
(open-stream conn)))))+433
+434
+435
;; ============================================================+436
;; SASL Authentication+437
;; ============================================================+438
+439
(define (begin-sasl conn features)+440
(let* ((mechanisms-el (stanza-child features 'mechanisms))+441
(mechanism-els (if mechanisms-el+442
(stanza-children mechanisms-el 'mechanism)+443
'()))+444
(mechanism-names (map (lambda (el) (sxml-text el))+445
mechanism-els))+446
(selected (select-sasl-mechanism mechanism-names)))+447
(cond+448
((eq? selected 'scram-sha-1)+449
(let* ((jid-obj (parse-jid (xmpp-connection-jid conn)))+450
(username (jid-local jid-obj))+451
(scram (make-scram-sha1 username (xmpp-connection-password conn)))+452
(initial (scram-initial-message scram)))+453
(set-xmpp-connection-sasl-state! conn scram)+454
(set-xmpp-connection-state! conn 'authenticating)+455
(conn-write conn+456
(string-append+457
"<auth xmlns='urn:ietf:params:xml:ns:xmpp-sasl'"+458
" mechanism='SCRAM-SHA-1'>"+459
initial "</auth>"))))+460
+461
((eq? selected 'plain)+462
(let* ((jid-obj (parse-jid (xmpp-connection-jid conn)))+463
(username (jid-local jid-obj))+464
(response (sasl-plain-response username+465
(xmpp-connection-password conn))))+466
(set-xmpp-connection-state! conn 'authenticating)+467
(conn-write conn+468
(string-append+469
"<auth xmlns='urn:ietf:params:xml:ns:xmpp-sasl'"+470
" mechanism='PLAIN'>"+471
response "</auth>"))))+472
+473
(else+474
(set-xmpp-connection-state! conn 'disconnected)+475
(fire-event conn 'error "No supported SASL mechanism")))))+476
+477
(define (handle-sasl-challenge conn stanza)+478
(let ((scram (xmpp-connection-sasl-state conn))+479
(challenge-text (sxml-text stanza)))+480
(if (and scram challenge-text)+481
(let ((response (scram-challenge-response scram challenge-text)))+482
(conn-write conn+483
(string-append "<response xmlns='urn:ietf:params:xml:ns:xmpp-sasl'>"+484
response "</response>")))+485
(begin+486
(set-xmpp-connection-state! conn 'disconnected)+487
(fire-event conn 'error "SASL challenge failed")))))+488
+489
(define (handle-sasl-success conn stanza)+490
(let ((scram (xmpp-connection-sasl-state conn))+491
(server-data (sxml-text stanza)))+492
;; Verify server signature if SCRAM+493
(when (and scram server-data)+494
(unless (scram-verify-server scram server-data)+495
(fire-event conn 'error "SCRAM server verification failed")))+496
+497
(set-xmpp-connection-sasl-state! conn #f)+498
(set-xmpp-connection-state! conn 'authenticated)+499
Showing the first 500 of 637 diff lines for this file. This diff is INCOMPLETE; read the file or clone the repository for the rest.