Commit7d019933Recorded20 Feb 2026Repositorysigil-xmpp
feat: Add sigil-xmpp package with stanza, JID, and SASL modules
Message
Phase 1-3 of XMPP client library: package setup, stanza construction and inspection, JID parsing, SCRAM-SHA-1 and PLAIN authentication, and XML serialization via SXML.
Changed
package.sgl | 19 +++++++++++
src/sigil/xmpp/sasl.sgl | 196 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
src/sigil/xmpp/stanza.sgl | 301 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
test/test-sasl.sgl | 78 +++++++++++++++++++++++++++++++++++++++++++
test/test-stanza.sgl | 148 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
5 files changed, 742 insertions(+)Diff
package.sgladded
@@ -0,0 +1,19 @@
+1
;;; sigil-xmpp - XMPP client library+2
;;;+3
;;; Provides XMPP client functionality with STARTTLS, SASL authentication,+4
;;; roster management, presence, MUC support, and cooperative non-blocking I/O.+5
+6
(package+7
name: "sigil-xmpp"+8
version: "0.1.0"+9
description: "XMPP client library with STARTTLS and SASL support"+10
url: "https://codeberg.org/sigil/sigil"+11
license: "BSD-3-Clause"+12
authors: (list "David Wilson <[email protected]>")+13
+14
dependencies: (list+15
(from-workspace name: "sigil-stdlib")+16
(from-workspace name: "sigil-socket")+17
(from-workspace name: "sigil-tls")+18
(from-workspace name: "sigil-crypto")+19
(from-workspace name: "sigil-sxml")))src/sigil/xmpp/sasl.sgladded
@@ -0,0 +1,196 @@
+1
;;; (sigil xmpp sasl) - SASL Authentication for XMPP+2
;;;+3
;;; Implements SCRAM-SHA-1 (RFC 5802) and PLAIN authentication mechanisms.+4
+5
(define-library (sigil xmpp sasl)+6
(import (sigil core)+7
(sigil string)+8
(sigil math)+9
(sigil crypto)+10
(scheme base))+11
+12
(export+13
;; SCRAM-SHA-1+14
make-scram-sha1+15
scram-initial-message+16
scram-challenge-response+17
scram-verify-server+18
+19
;; PLAIN+20
sasl-plain-response+21
+22
;; Mechanism selection+23
select-sasl-mechanism)+24
+25
(begin+26
+27
;; ============================================================+28
;; Bytevector Utilities+29
;; ============================================================+30
+31
;; XOR two bytevectors of equal length+32
(define (bytevector-xor a b)+33
(let* ((len (bytevector-length a))+34
(result (make-bytevector len)))+35
(let loop ((i 0))+36
(if (>= i len)+37
result+38
(begin+39
(bytevector-u8-set! result i+40
(bitwise-xor (bytevector-u8-ref a i)+41
(bytevector-u8-ref b i)))+42
(loop (+ i 1)))))))+43
+44
+45
;; ============================================================+46
;; SCRAM-SHA-1 (RFC 5802)+47
;; ============================================================+48
+49
;; SCRAM state is a vector:+50
;; 0: username+51
;; 1: password+52
;; 2: client-nonce+53
;; 3: client-first-message-bare+54
;; 4: server-first-message (set after challenge)+55
;; 5: auth-message (set after challenge)+56
;; 6: server-signature (set after challenge, for verification)+57
;; 7: salted-password (set after challenge)+58
+59
;;; Create a SCRAM-SHA-1 authentication state.+60
;;;+61
;;; ```scheme+62
;;; (define scram (make-scram-sha1 "user" "password"))+63
;;; ```+64
(define (make-scram-sha1 username password)+65
(let ((state (make-vector 8 #f))+66
(nonce (base64-encode (random-bytes 18))))+67
(vector-set! state 0 username)+68
(vector-set! state 1 password)+69
(vector-set! state 2 nonce)+70
state))+71
+72
;; SASLprep is a no-op for ASCII passwords (sufficient for most XMPP)+73
(define (saslprep str) str)+74
+75
;;; Generate the SCRAM client-first-message (base64-encoded).+76
;;;+77
;;; Returns the base64-encoded message to send in the SASL auth element.+78
(define (scram-initial-message state)+79
(let* ((username (vector-ref state 0))+80
(nonce (vector-ref state 2))+81
(bare (string-append "n=" username ",r=" nonce)))+82
(vector-set! state 3 bare)+83
;; gs2-header is "n,," (no channel binding, no authzid)+84
(base64-encode (string->utf8 (string-append "n,," bare)))))+85
+86
;; Parse a SCRAM challenge string into an alist+87
(define (parse-scram-challenge str)+88
(let loop ((parts (string-split str ",")) (result '()))+89
(if (null? parts)+90
(reverse result)+91
(let ((part (car parts)))+92
(if (< (string-length part) 2)+93
(loop (cdr parts) result)+94
(let ((key (substring part 0 1))+95
(val (substring part 2 (string-length part))))+96
(loop (cdr parts)+97
(cons (cons key val) result))))))))+98
+99
;; SCRAM Hi function: PBKDF2 with HMAC-SHA-1+100
(define (scram-hi password salt iterations)+101
(pbkdf2-sha1 password salt iterations 20))+102
+103
;;; Process SCRAM server challenge and generate client-final-message.+104
;;;+105
;;; Takes the base64-encoded server challenge, returns the base64-encoded+106
;;; client-final-message.+107
(define (scram-challenge-response state server-challenge-b64)+108
(let* ((server-msg (utf8->string (base64-decode server-challenge-b64)))+109
(parts (parse-scram-challenge server-msg))+110
(server-nonce (cdr (assoc "r" parts)))+111
(salt-b64 (cdr (assoc "s" parts)))+112
(iterations (string->number (cdr (assoc "i" parts))))+113
(salt (base64-decode salt-b64))+114
(client-nonce (vector-ref state 2))+115
(password (saslprep (vector-ref state 1)))+116
(client-first-bare (vector-ref state 3)))+117
+118
;; Verify server nonce starts with our nonce+119
(unless (string-starts-with? server-nonce client-nonce)+120
(error "SCRAM: server nonce doesn't start with client nonce"))+121
+122
(vector-set! state 4 server-msg)+123
+124
;; Compute salted password and keys+125
(let* ((salted-password (scram-hi (string->utf8 password) salt iterations))+126
(client-key (hmac-sha1 salted-password "Client Key"))+127
(stored-key (sha1 client-key))+128
(channel-binding (base64-encode (string->utf8 "n,,")))+129
(client-final-without-proof+130
(string-append "c=" channel-binding ",r=" server-nonce))+131
(auth-message+132
(string-append client-first-bare "," server-msg ","+133
client-final-without-proof))+134
(client-signature (hmac-sha1 stored-key auth-message))+135
(client-proof (bytevector-xor client-key client-signature))+136
(server-key (hmac-sha1 salted-password "Server Key"))+137
(server-signature (hmac-sha1 server-key auth-message)))+138
+139
(vector-set! state 5 auth-message)+140
(vector-set! state 6 server-signature)+141
(vector-set! state 7 salted-password)+142
+143
;; Return client-final-message+144
(base64-encode+145
(string->utf8+146
(string-append client-final-without-proof+147
",p=" (base64-encode client-proof)))))))+148
+149
;;; Verify the server's final response.+150
;;;+151
;;; Returns #t if the server signature matches, #f otherwise.+152
(define (scram-verify-server state server-final-b64)+153
(let* ((server-msg (utf8->string (base64-decode server-final-b64)))+154
(parts (parse-scram-challenge server-msg))+155
(server-sig-b64 (cdr (assoc "v" parts)))+156
(expected (vector-ref state 6)))+157
(equal? (base64-decode server-sig-b64) expected)))+158
+159
+160
;; ============================================================+161
;; PLAIN (RFC 4616)+162
;; ============================================================+163
+164
;;; Generate a PLAIN SASL response (base64-encoded).+165
;;;+166
;;; Format: base64(\0username\0password)+167
(define (sasl-plain-response username password)+168
(let* ((user-bv (string->utf8 username))+169
(pass-bv (string->utf8 password))+170
(zero (make-bytevector 1 0))+171
(payload (bytevector-append zero user-bv zero pass-bv)))+172
(base64-encode payload)))+173
+174
+175
;; ============================================================+176
;; Mechanism Selection+177
;; ============================================================+178
+179
;; Priority order for SASL mechanisms+180
(define mechanism-priority '("SCRAM-SHA-1" "PLAIN"))+181
+182
;;; Select the best SASL mechanism from a list of server-offered mechanisms.+183
;;;+184
;;; Returns a symbol: 'scram-sha-1, 'plain, or #f if none supported.+185
(define (select-sasl-mechanism offered)+186
(let loop ((prefs mechanism-priority))+187
(if (null? prefs)+188
#f+189
(if (member (car prefs) offered)+190
(cond+191
((string=? (car prefs) "SCRAM-SHA-1") 'scram-sha-1)+192
((string=? (car prefs) "PLAIN") 'plain)+193
(else (loop (cdr prefs))))+194
(loop (cdr prefs))))))+195
+196
))src/sigil/xmpp/stanza.sgladded
@@ -0,0 +1,301 @@
+1
;;; (sigil xmpp stanza) - XMPP Stanza Construction and JID Handling+2
;;;+3
;;; Provides JID parsing, stanza constructors, stanza inspection,+4
;;; and XML serialization for XMPP protocol elements.+5
+6
(define-library (sigil xmpp stanza)+7
(import (sigil core)+8
(sigil string)+9
(sigil struct)+10
(sigil sxml)+11
(sigil crypto))+12
+13
(export+14
;; JID handling+15
jid+16
jid?+17
jid-local+18
jid-domain+19
jid-resource+20
parse-jid+21
jid->string+22
jid-bare+23
+24
;; Stanza constructors+25
xmpp-message+26
xmpp-presence+27
xmpp-iq+28
+29
;; Stanza inspection+30
stanza-type+31
stanza-attr+32
stanza-to+33
stanza-from+34
stanza-id+35
message-body+36
stanza-child+37
stanza-children+38
sxml-text+39
+40
;; ID generation+41
generate-stanza-id+42
+43
;; Serialization+44
stanza->xml)+45
+46
(begin+47
+48
;; ============================================================+49
;; JID Handling+50
;; ============================================================+51
+52
(define-struct jid+53
(local default: #f)+54
(domain)+55
(resource default: #f))+56
+57
;;; Parse a JID string into a jid record.+58
;;;+59
;;; Handles formats: "local@domain/resource", "local@domain",+60
;;; "domain/resource", and bare "domain".+61
;;;+62
;;; ```scheme+63
;;; (parse-jid "[email protected]/bot")+64
;;; ; => #<jid local: "user" domain: "example.com" resource: "bot">+65
;;; ```+66
(define (parse-jid str)+67
(let ((at-pos (string-index str (lambda (c) (char=? c #\@))))+68
(slash-pos (string-index str (lambda (c) (char=? c #\/)))))+69
(cond+70
;; local@domain/resource+71
((and at-pos slash-pos (< at-pos slash-pos))+72
(jid local: (substring str 0 at-pos)+73
domain: (substring str (+ at-pos 1) slash-pos)+74
resource: (substring str (+ slash-pos 1) (string-length str))))+75
;; local@domain+76
((and at-pos (not slash-pos))+77
(jid local: (substring str 0 at-pos)+78
domain: (substring str (+ at-pos 1) (string-length str))))+79
;; domain/resource+80
((and (not at-pos) slash-pos)+81
(jid domain: (substring str 0 slash-pos)+82
resource: (substring str (+ slash-pos 1) (string-length str))))+83
;; bare domain+84
(else+85
(jid domain: str)))))+86
+87
;;; Convert a jid record to its string representation.+88
;;;+89
;;; ```scheme+90
;;; (jid->string (parse-jid "[email protected]/bot"))+91
;;; ; => "[email protected]/bot"+92
;;; ```+93
(define (jid->string j)+94
(let ((local (jid-local j))+95
(domain (jid-domain j))+96
(resource (jid-resource j)))+97
(cond+98
((and local resource)+99
(string-append local "@" domain "/" resource))+100
(local+101
(string-append local "@" domain))+102
(resource+103
(string-append domain "/" resource))+104
(else domain))))+105
+106
;;; Return the bare JID (without resource) as a string.+107
;;;+108
;;; ```scheme+109
;;; (jid-bare "[email protected]/bot") ; => "[email protected]"+110
;;; (jid-bare (parse-jid "[email protected]/bot")) ; => "[email protected]"+111
;;; ```+112
(define (jid-bare j)+113
(let ((j (if (string? j) (parse-jid j) j)))+114
(let ((local (jid-local j))+115
(domain (jid-domain j)))+116
(if local+117
(string-append local "@" domain)+118
domain))))+119
+120
+121
;; ============================================================+122
;; ID Generation+123
;; ============================================================+124
+125
(define id-counter 0)+126
+127
;;; Generate a unique stanza ID.+128
;;;+129
;;; Uses a counter combined with random bytes for uniqueness.+130
(define (generate-stanza-id)+131
(set! id-counter (+ id-counter 1))+132
(string-append "s" (number->string id-counter) "-"+133
(base64-encode (random-bytes 6))))+134
+135
+136
;; ============================================================+137
;; Stanza Constructors+138
;; ============================================================+139
+140
;; Build an attribute list, filtering out #f values+141
(define (build-attrs . pairs)+142
(let loop ((pairs pairs) (attrs '()))+143
(if (null? pairs)+144
(if (null? attrs)+145
'()+146
(list (cons '@ (reverse attrs))))+147
(let ((key (car pairs))+148
(val (cadr pairs)))+149
(loop (cddr pairs)+150
(if val+151
(cons (list key val) attrs)+152
attrs))))))+153
+154
;;; Construct an XMPP message stanza as SXML.+155
;;;+156
;;; ```scheme+157
;;; (xmpp-message to: "[email protected]" body: "Hello")+158
;;; ; => (message (@ (to "[email protected]") (id "s1-...")) (body "Hello"))+159
;;; ```+160
(define (xmpp-message (keys: (to #f) (from #f) (type "chat")+161
(id #f) (body #f) (subject #f)+162
(children '())))+163
(let ((id (or id (generate-stanza-id))))+164
(append+165
(cons 'message+166
(build-attrs 'to to 'from from 'type type 'id id))+167
(if subject (list (list 'subject subject)) '())+168
(if body (list (list 'body body)) '())+169
children)))+170
+171
;;; Construct an XMPP presence stanza as SXML.+172
;;;+173
;;; ```scheme+174
;;; (xmpp-presence show: "away" status: "Be right back")+175
;;; ```+176
(define (xmpp-presence (keys: (to #f) (from #f) (type #f)+177
(id #f) (show #f) (status #f)+178
(priority #f) (children '())))+179
(append+180
(cons 'presence+181
(build-attrs 'to to 'from from 'type type 'id id))+182
(if show (list (list 'show show)) '())+183
(if status (list (list 'status status)) '())+184
(if priority (list (list 'priority (if (number? priority)+185
(number->string priority)+186
priority))) '())+187
children))+188
+189
;;; Construct an XMPP IQ stanza as SXML.+190
;;;+191
;;; ```scheme+192
;;; (xmpp-iq type: "get" to: "example.com"+193
;;; children: (list '(query (@ (xmlns "jabber:iq:roster")))))+194
;;; ```+195
(define (xmpp-iq (keys: (to #f) (from #f) (type "get")+196
(id #f) (children '())))+197
(let ((id (or id (generate-stanza-id))))+198
(append+199
(cons 'iq+200
(build-attrs 'to to 'from from 'type type 'id id))+201
children)))+202
+203
+204
;; ============================================================+205
;; Stanza Inspection+206
;; ============================================================+207
+208
;;; Get the type of a stanza (message, presence, iq) as a symbol.+209
(define (stanza-type stanza)+210
(if (pair? stanza) (car stanza) #f))+211
+212
;;; Get an attribute value from a stanza.+213
;;;+214
;;; ```scheme+215
;;; (stanza-attr msg 'to) ; => "[email protected]"+216
;;; ```+217
(define (stanza-attr stanza name)+218
(sxml-attr-ref stanza name))+219
+220
;;; Get the 'to' attribute of a stanza.+221
(define (stanza-to stanza)+222
(sxml-attr-ref stanza 'to))+223
+224
;;; Get the 'from' attribute of a stanza.+225
(define (stanza-from stanza)+226
(sxml-attr-ref stanza 'from))+227
+228
;;; Get the 'id' attribute of a stanza.+229
(define (stanza-id stanza)+230
(sxml-attr-ref stanza 'id))+231
+232
;;; Get the body text from a message stanza.+233
;;;+234
;;; ```scheme+235
;;; (message-body '(message (@ (to "a@b")) (body "Hello")))+236
;;; ; => "Hello"+237
;;; ```+238
(define (message-body stanza)+239
(let ((body-el (stanza-child stanza 'body)))+240
(if body-el+241
(sxml-text body-el)+242
#f)))+243
+244
;;; Find the first child element with the given tag name.+245
;;;+246
;;; ```scheme+247
;;; (stanza-child msg 'body) ; => (body "Hello")+248
;;; ```+249
(define (stanza-child stanza tag)+250
(let ((content (sxml-content stanza)))+251
(let loop ((items content))+252
(if (null? items)+253
#f+254
(let ((item (car items)))+255
(if (and (pair? item) (eq? (car item) tag))+256
item+257
(loop (cdr items))))))))+258
+259
;;; Find all child elements with the given tag name.+260
(define (stanza-children stanza tag)+261
(let ((content (sxml-content stanza)))+262
(let loop ((items content) (result '()))+263
(if (null? items)+264
(reverse result)+265
(let ((item (car items)))+266
(if (and (pair? item) (eq? (car item) tag))+267
(loop (cdr items) (cons item result))+268
(loop (cdr items) result)))))))+269
+270
;;; Extract text content from an SXML element.+271
;;;+272
;;; Returns the concatenation of all string children, or #f if none.+273
(define (sxml-text element)+274
(if (not (pair? element))+275
#f+276
(let ((content (sxml-content element)))+277
(let loop ((items content) (texts '()))+278
(if (null? items)+279
(if (null? texts)+280
#f+281
(apply string-append (reverse texts)))+282
(let ((item (car items)))+283
(if (string? item)+284
(loop (cdr items) (cons item texts))+285
(loop (cdr items) texts))))))))+286
+287
+288
;; ============================================================+289
;; Serialization+290
;; ============================================================+291
+292
;;; Convert a stanza (SXML) to an XML string.+293
;;;+294
;;; ```scheme+295
;;; (stanza->xml (xmpp-message to: "[email protected]" body: "Hi"))+296
;;; ; => "<message to=\"[email protected]\" ...><body>Hi</body></message>"+297
;;; ```+298
(define (stanza->xml stanza)+299
(sxml->xml stanza))+300
+301
))test/test-sasl.sgladded
@@ -0,0 +1,78 @@
+1
(import (sigil test)+2
(sigil string)+3
(sigil xmpp sasl)+4
(sigil crypto)+5
(scheme base))+6
+7
;; ============================================================+8
;; PLAIN Authentication+9
;; ============================================================+10
+11
(test-group "sasl-plain"+12
(test "plain response format"+13
(let ((response (sasl-plain-response "user" "password")))+14
;; base64(\0user\0password)+15
(let ((decoded (base64-decode response)))+16
(assert-equal 14 (bytevector-length decoded)) ; 1 + 4 + 1 + 8+17
(assert-equal 0 (bytevector-u8-ref decoded 0))+18
(assert-equal 0 (bytevector-u8-ref decoded 5))))))+19
+20
;; ============================================================+21
;; SCRAM-SHA-1+22
;; ============================================================+23
+24
(test-group "scram-sha-1"+25
(test "initial message format"+26
(let* ((scram (make-scram-sha1 "user" "pencil"))+27
(msg (scram-initial-message scram))+28
(decoded (utf8->string (base64-decode msg))))+29
;; Should start with "n,,n=user,r="+30
(assert-true (string-starts-with? decoded "n,,n=user,r="))))+31
+32
;; RFC 5802 test vector+33
;; This tests the full SCRAM exchange with known values+34
(test "SCRAM exchange with RFC 5802 values"+35
(let ((scram (make-scram-sha1 "user" "pencil")))+36
;; Override the nonce to match RFC 5802+37
(vector-set! scram 2 "fyko+d2lbbFgONRv9qkxdawL")+38
+39
(let ((initial (scram-initial-message scram)))+40
;; Verify client-first-message+41
(let ((decoded (utf8->string (base64-decode initial))))+42
(assert-equal "n,,n=user,r=fyko+d2lbbFgONRv9qkxdawL" decoded))+43
+44
;; Server challenge (from RFC 5802)+45
(let* ((server-challenge+46
(base64-encode+47
(string->utf8+48
"r=fyko+d2lbbFgONRv9qkxdawL3rfcNHYJY1ZVvWVs7j,s=QSXCR+Q6sek8bf92,i=4096")))+49
(response (scram-challenge-response scram server-challenge))+50
(decoded (utf8->string (base64-decode response))))+51
;; Verify client-final-message format+52
(assert-true (string-starts-with? decoded "c="))+53
(assert-true (string-contains? decoded ",r=fyko+d2lbbFgONRv9qkxdawL3rfcNHYJY1ZVvWVs7j"))+54
(assert-true (string-contains? decoded ",p="))+55
+56
;; Verify server signature+57
(let ((server-final+58
(base64-encode+59
(string->utf8 "v=rmF9pqV8S7suAoZWja4dJRkFsKQ="))))+60
(assert-true (scram-verify-server scram server-final))))))))+61
+62
;; ============================================================+63
;; Mechanism Selection+64
;; ============================================================+65
+66
(test-group "mechanism-selection"+67
(test "prefers SCRAM-SHA-1"+68
(assert-equal 'scram-sha-1+69
(select-sasl-mechanism '("PLAIN" "SCRAM-SHA-1"))))+70
+71
(test "falls back to PLAIN"+72
(assert-equal 'plain+73
(select-sasl-mechanism '("PLAIN"))))+74
+75
(test "returns #f for unsupported"+76
(assert-false (select-sasl-mechanism '("GSSAPI" "EXTERNAL")))))+77
+78
(run-tests)test/test-stanza.sgladded
@@ -0,0 +1,148 @@
+1
(import (sigil test)+2
(sigil string)+3
(sigil xmpp stanza))+4
+5
;; ============================================================+6
;; JID Handling+7
;; ============================================================+8
+9
(test-group "jid-parsing"+10
(test "full JID"+11
(let ((j (parse-jid "[email protected]/bot")))+12
(assert-equal "user" (jid-local j))+13
(assert-equal "example.com" (jid-domain j))+14
(assert-equal "bot" (jid-resource j))))+15
+16
(test "bare JID"+17
(let ((j (parse-jid "[email protected]")))+18
(assert-equal "user" (jid-local j))+19
(assert-equal "example.com" (jid-domain j))+20
(assert-false (jid-resource j))))+21
+22
(test "domain only"+23
(let ((j (parse-jid "example.com")))+24
(assert-false (jid-local j))+25
(assert-equal "example.com" (jid-domain j))+26
(assert-false (jid-resource j))))+27
+28
(test "domain with resource"+29
(let ((j (parse-jid "example.com/announce")))+30
(assert-false (jid-local j))+31
(assert-equal "example.com" (jid-domain j))+32
(assert-equal "announce" (jid-resource j)))))+33
+34
(test-group "jid-string-conversion"+35
(test "full JID round-trip"+36
(assert-equal "[email protected]/bot"+37
(jid->string (parse-jid "[email protected]/bot"))))+38
+39
(test "bare JID round-trip"+40
(assert-equal "[email protected]"+41
(jid->string (parse-jid "[email protected]"))))+42
+43
(test "domain-only round-trip"+44
(assert-equal "example.com"+45
(jid->string (parse-jid "example.com"))))+46
+47
(test "jid-bare from full JID"+48
(assert-equal "[email protected]"+49
(jid-bare "[email protected]/bot")))+50
+51
(test "jid-bare from string"+52
(assert-equal "[email protected]"+53
(jid-bare "[email protected]")))+54
+55
(test "jid-bare from domain"+56
(assert-equal "example.com"+57
(jid-bare "example.com"))))+58
+59
;; ============================================================+60
;; Stanza Construction+61
;; ============================================================+62
+63
(test-group "stanza-construction"+64
(test "message stanza"+65
(let ((msg (xmpp-message to: "[email protected]" body: "Hello" id: "test-1")))+66
(assert-equal 'message (stanza-type msg))+67
(assert-equal "[email protected]" (stanza-to msg))+68
(assert-equal "chat" (stanza-attr msg 'type))+69
(assert-equal "test-1" (stanza-id msg))+70
(assert-equal "Hello" (message-body msg))))+71
+72
(test "message with subject"+73
(let ((msg (xmpp-message to: "[email protected]" subject: "Test" body: "Hello" id: "test-2")))+74
(let ((subj (stanza-child msg 'subject)))+75
(assert-true (pair? subj))+76
(assert-equal "Test" (sxml-text subj)))))+77
+78
(test "presence stanza"+79
(let ((p (xmpp-presence show: "away" status: "BRB")))+80
(assert-equal 'presence (stanza-type p))+81
(assert-equal "away" (sxml-text (stanza-child p 'show)))+82
(assert-equal "BRB" (sxml-text (stanza-child p 'status)))))+83
+84
(test "presence with type"+85
(let ((p (xmpp-presence type: "unavailable")))+86
(assert-equal "unavailable" (stanza-attr p 'type))))+87
+88
(test "iq stanza"+89
(let ((iq (xmpp-iq type: "get" to: "example.com" id: "iq-1"+90
children: (list '(query (@ (xmlns "jabber:iq:roster")))))))+91
(assert-equal 'iq (stanza-type iq))+92
(assert-equal "get" (stanza-attr iq 'type))+93
(assert-equal "example.com" (stanza-to iq))+94
(let ((query (stanza-child iq 'query)))+95
(assert-true (pair? query)))))+96
+97
(test "auto-generated ID"+98
(let ((msg (xmpp-message to: "[email protected]" body: "Hi")))+99
(assert-true (string? (stanza-id msg))))))+100
+101
;; ============================================================+102
;; Stanza Inspection+103
;; ============================================================+104
+105
(test-group "stanza-inspection"+106
(test "inspect parsed stanza"+107
(let ((s '(message (@ (to "a@b") (from "c@d") (type "chat") (id "m1"))+108
(body "Hello"))))+109
(assert-equal 'message (stanza-type s))+110
(assert-equal "a@b" (stanza-to s))+111
(assert-equal "c@d" (stanza-from s))+112
(assert-equal "m1" (stanza-id s))+113
(assert-equal "Hello" (message-body s))))+114
+115
(test "stanza without attributes"+116
(let ((s '(message (body "Hello"))))+117
(assert-equal 'message (stanza-type s))+118
(assert-false (stanza-to s))+119
(assert-equal "Hello" (message-body s))))+120
+121
(test "stanza-children"+122
(let ((s '(iq (@ (type "result"))+123
(query (item (@ (jid "a@b")))+124
(item (@ (jid "c@d")))))))+125
(let ((query (stanza-child s 'query)))+126
(assert-equal 2 (length (stanza-children query 'item))))))+127
+128
(test "sxml-text concatenates strings"+129
(assert-equal "Hello World" (sxml-text '(body "Hello " "World"))))+130
+131
(test "sxml-text returns #f for no text"+132
(assert-false (sxml-text '(empty)))))+133
+134
;; ============================================================+135
;; Serialization+136
;; ============================================================+137
+138
(test-group "stanza-serialization"+139
(test "message to XML"+140
(let ((xml (stanza->xml '(message (@ (to "a@b")) (body "Hi")))))+141
(assert-true (string? xml))+142
(assert-true (string-starts-with? xml "<message"))+143
(assert-true (string-ends-with? xml "</message>"))))+144
+145
(test "empty element"+146
(assert-equal "<presence></presence>" (stanza->xml '(presence)))))+147
+148
(run-tests)