Commit973a84daRecorded20 Feb 2026Repositorysigil-xmpp

feat: Add roster, presence, and MUC modules to sigil-xmpp

Message

Roster module handles contact list management with subscription operations and roster push handling. Presence module tracks contact availability. MUC module supports multi-user chat rooms with occupant tracking, messaging, and room administration.

Changed
 src/sigil/xmpp.sgl          |  81 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++----
 src/sigil/xmpp/muc.sgl      | 208 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 src/sigil/xmpp/presence.sgl | 125 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 src/sigil/xmpp/roster.sgl   | 199 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 test/test-muc.sgl           |  47 +++++++++++++++++++++++++++++++++++++
 test/test-roster.sgl        |  57 +++++++++++++++++++++++++++++++++++++++++++++
 6 files changed, 712 insertions(+), 5 deletions(-)
Diff
src/sigil/xmpp.sglmodified
@@ -1,12 +1,17 @@
1
;;; (sigil xmpp) - XMPP Client Library
2
;;;
3
;;; Provides a complete XMPP client with STARTTLS, SASL authentication,
−4
;;; stanza handling, and cooperative I/O.
+4
;;; stanza handling, roster, presence, MUC, and cooperative I/O.
5
6
(define-library (sigil xmpp)
−7
(import (sigil xmpp stanza)
+7
(import (sigil core)
+8
(sigil sxml)
+9
(sigil xmpp stanza)
10
(sigil xmpp sasl)
−9
(sigil xmpp connection))
+11
(sigil xmpp connection)
+12
(sigil xmpp roster)
+13
(sigil xmpp presence)
+14
(sigil xmpp muc))
15
16
(export
17
;; From (sigil xmpp stanza)
@@ -38,5 +43,71 @@
43
xmpp-send xmpp-send-raw xmpp-process-input
44
;; Event loop
45
xmpp-run xmpp-tick
−41
;; Presence
−42
xmpp-send-presence))
+46
;; Presence (basic)
+47
xmpp-send-presence
+48
+49
;; From (sigil xmpp roster)
+50
roster-item roster-item?
+51
roster-item-jid roster-item-name
+52
roster-item-subscription roster-item-groups roster-item-ask
+53
xmpp-request-roster xmpp-roster xmpp-roster-item
+54
xmpp-roster-add xmpp-roster-remove
+55
xmpp-subscribe xmpp-accept-subscription
+56
xmpp-deny-subscription xmpp-unsubscribe
+57
+58
;; From (sigil xmpp presence)
+59
presence-info presence-info?
+60
presence-info-jid presence-info-show
+61
presence-info-status presence-info-priority
+62
xmpp-set-status xmpp-go-offline
+63
xmpp-presence-of xmpp-resources-of
+64
+65
;; From (sigil xmpp muc)
+66
muc-room muc-room?
+67
muc-room-jid muc-room-nick
+68
muc-room-subject muc-room-occupants muc-room-joined?
+69
muc-occupant muc-occupant?
+70
muc-occupant-nick muc-occupant-jid
+71
muc-occupant-affiliation muc-occupant-role
+72
xmpp-muc-join xmpp-muc-leave
+73
xmpp-muc-message xmpp-muc-private-message
+74
xmpp-muc-set-subject xmpp-muc-occupants
+75
xmpp-muc-kick xmpp-muc-invite
+76
+77
;; Feature integration
+78
xmpp-install-features)
+79
+80
(begin
+81
+82
;;; Install roster, presence, and MUC feature handlers on a connection.
+83
;;;
+84
;;; Call this after creating a connection to enable automatic roster
+85
;;; push handling, presence tracking, and MUC occupant tracking.
+86
;;;
+87
;;; ```scheme
+88
;;; (define conn (make-xmpp-connection ...))
+89
;;; (xmpp-install-features conn)
+90
;;; (xmpp-connect conn)
+91
;;; ```
+92
(define (xmpp-install-features conn)
+93
;; Handle roster pushes (IQ set with jabber:iq:roster)
+94
(xmpp-on conn 'iq
+95
(lambda (stanza)
+96
(when (equal? (stanza-attr stanza 'type) "set")
+97
(let ((query (stanza-child stanza 'query)))
+98
(when (and query
+99
(equal? (sxml-attr-ref query 'xmlns) "jabber:iq:roster"))
+100
(handle-roster-push conn stanza))))))
+101
+102
;; Track presence updates
+103
(xmpp-on conn 'presence
+104
(lambda (stanza)
+105
(handle-presence-update conn stanza)
+106
;; Check for MUC presence (has x element with MUC xmlns)
+107
(let ((x-el (stanza-child stanza 'x)))
+108
(when (and x-el
+109
(equal? (sxml-attr-ref x-el 'xmlns)
+110
"http://jabber.org/protocol/muc#user"))
+111
(handle-muc-presence conn stanza))))))
+112
+113
))
src/sigil/xmpp/muc.sgladded
@@ -0,0 +1,208 @@
+1
;;; (sigil xmpp muc) - Multi-User Chat (XEP-0045)
+2
;;;
+3
;;; Provides MUC (chatroom) support including joining, leaving,
+4
;;; messaging, occupant tracking, and room administration.
+5
+6
(define-library (sigil xmpp muc)
+7
(import (sigil core)
+8
(sigil struct)
+9
(sigil sxml)
+10
(sigil xmpp stanza)
+11
(sigil xmpp connection))
+12
+13
(export
+14
;; MUC room
+15
muc-room
+16
muc-room?
+17
muc-room-jid
+18
muc-room-nick
+19
muc-room-subject
+20
muc-room-occupants
+21
muc-room-joined?
+22
+23
;; MUC occupant
+24
muc-occupant
+25
muc-occupant?
+26
muc-occupant-nick
+27
muc-occupant-jid
+28
muc-occupant-affiliation
+29
muc-occupant-role
+30
+31
;; MUC operations
+32
xmpp-muc-join
+33
xmpp-muc-leave
+34
xmpp-muc-message
+35
xmpp-muc-private-message
+36
xmpp-muc-set-subject
+37
xmpp-muc-occupants
+38
xmpp-muc-kick
+39
xmpp-muc-invite
+40
+41
;; Internal
+42
handle-muc-presence)
+43
+44
(begin
+45
+46
;; ============================================================
+47
;; MUC Data Structures
+48
;; ============================================================
+49
+50
(define-struct muc-room
+51
(jid)
+52
(nick)
+53
(subject default: #f mutable: #t)
+54
(occupants default: #{} mutable: #t)
+55
(joined? default: #f mutable: #t))
+56
+57
(define-struct muc-occupant
+58
(nick)
+59
(jid default: #f)
+60
(affiliation default: "none")
+61
(role default: "none"))
+62
+63
+64
;; ============================================================
+65
;; Room Registry
+66
;; ============================================================
+67
+68
;; Get or create room tracking entry
+69
(define (get-muc-rooms conn)
+70
(or (dict-ref (xmpp-connection-event-handlers conn) '%muc-rooms #f)
+71
#{}))
+72
+73
(define (set-muc-rooms! conn rooms)
+74
(set-xmpp-connection-event-handlers!
+75
conn
+76
(dict-set (xmpp-connection-event-handlers conn) '%muc-rooms rooms)))
+77
+78
(define (get-room conn room-jid)
+79
(dict-ref (get-muc-rooms conn) room-jid #f))
+80
+81
+82
;; ============================================================
+83
;; MUC Operations
+84
;; ============================================================
+85
+86
;;; Join a MUC room.
+87
;;;
+88
;;; ```scheme
+89
;;; (xmpp-muc-join conn "[email protected]" "mynick")
+90
;;; ```
+91
(define (xmpp-muc-join conn room-jid nick)
+92
;; Register room
+93
(let* ((rooms (get-muc-rooms conn))
+94
(room (muc-room jid: room-jid nick: nick)))
+95
(set-muc-rooms! conn (dict-set rooms room-jid room)))
+96
+97
;; Send presence to room
+98
(xmpp-send conn
+99
(xmpp-presence
+100
to: (string-append room-jid "/" nick)
+101
children: (list '(x (@ (xmlns "http://jabber.org/protocol/muc")))))))
+102
+103
;;; Leave a MUC room.
+104
(define (xmpp-muc-leave conn room-jid (keys: (reason #f)))
+105
(let ((room (get-room conn room-jid)))
+106
(when room
+107
(xmpp-send conn
+108
(xmpp-presence
+109
to: (string-append room-jid "/" (muc-room-nick room))
+110
type: "unavailable"
+111
children: (if reason
+112
(list `(status ,reason))
+113
'())))
+114
;; Remove room from tracking
+115
(set-muc-rooms! conn
+116
(dict-remove (get-muc-rooms conn) room-jid)))))
+117
+118
;;; Send a message to a MUC room.
+119
;;;
+120
;;; ```scheme
+121
;;; (xmpp-muc-message conn "[email protected]" "Hello room!")
+122
;;; ```
+123
(define (xmpp-muc-message conn room-jid body)
+124
(xmpp-send conn
+125
(xmpp-message to: room-jid type: "groupchat" body: body)))
+126
+127
;;; Send a private message to a MUC occupant.
+128
(define (xmpp-muc-private-message conn room-jid nick body)
+129
(xmpp-send conn
+130
(xmpp-message to: (string-append room-jid "/" nick)
+131
type: "chat" body: body)))
+132
+133
;;; Set the subject of a MUC room.
+134
(define (xmpp-muc-set-subject conn room-jid subject)
+135
(xmpp-send conn
+136
(xmpp-message to: room-jid type: "groupchat" subject: subject)))
+137
+138
;;; Get the occupants of a MUC room.
+139
;;;
+140
;;; Returns a list of muc-occupant records, or '() if not in the room.
+141
(define (xmpp-muc-occupants conn room-jid)
+142
(let ((room (get-room conn room-jid)))
+143
(if room
+144
(dict-values (muc-room-occupants room))
+145
'())))
+146
+147
;;; Kick an occupant from a MUC room (requires moderator role).
+148
(define (xmpp-muc-kick conn room-jid nick (keys: (reason #f)))
+149
(xmpp-send conn
+150
(xmpp-iq type: "set" to: room-jid
+151
children: (list
+152
`(query (@ (xmlns "http://jabber.org/protocol/muc#admin"))
+153
(item (@ (nick ,nick) (role "none"))
+154
,@(if reason
+155
(list `(reason ,reason))
+156
'())))))))
+157
+158
;;; Send a mediated invitation to a user.
+159
(define (xmpp-muc-invite conn room-jid invitee-jid (keys: (reason #f)))
+160
(xmpp-send conn
+161
(xmpp-message to: room-jid
+162
children: (list
+163
`(x (@ (xmlns "http://jabber.org/protocol/muc#user"))
+164
(invite (@ (to ,invitee-jid))
+165
,@(if reason
+166
(list `(reason ,reason))
+167
'())))))))
+168
+169
+170
;; ============================================================
+171
;; MUC Presence Handling
+172
;; ============================================================
+173
+174
;; Handle MUC presence updates
+175
(define (handle-muc-presence conn stanza)
+176
(let* ((from (stanza-from stanza))
+177
(type (stanza-attr stanza 'type)))
+178
(when from
+179
(let* ((from-jid (parse-jid from))
+180
(room-jid (jid-bare from))
+181
(nick (jid-resource from-jid))
+182
(room (get-room conn room-jid)))
+183
(when (and room nick)
+184
;; Extract MUC user info
+185
(let* ((x-el (stanza-child stanza 'x))
+186
(item-el (and x-el (stanza-child x-el 'item)))
+187
(real-jid (and item-el (stanza-attr item-el 'jid)))
+188
(affiliation (or (and item-el (stanza-attr item-el 'affiliation)) "none"))
+189
(role (or (and item-el (stanza-attr item-el 'role)) "none")))
+190
+191
(if (equal? type "unavailable")
+192
;; Occupant left
+193
(set-muc-room-occupants! room
+194
(dict-remove (muc-room-occupants room) nick))
+195
;; Occupant joined or updated
+196
(let ((occupant (muc-occupant
+197
nick: nick
+198
jid: real-jid
+199
affiliation: affiliation
+200
role: role)))
+201
(set-muc-room-occupants! room
+202
(dict-set (muc-room-occupants room) nick occupant))
+203
+204
;; If this is our own presence, mark room as joined
+205
(when (equal? nick (muc-room-nick room))
+206
(set-muc-room-joined?! room #t))))))))))
+207
+208
))
src/sigil/xmpp/presence.sgladded
@@ -0,0 +1,125 @@
+1
;;; (sigil xmpp presence) - XMPP Presence Tracking
+2
;;;
+3
;;; Tracks presence information for contacts and provides
+4
;;; convenience functions for managing own presence.
+5
+6
(define-library (sigil xmpp presence)
+7
(import (sigil core)
+8
(sigil struct)
+9
(sigil sxml)
+10
(sigil xmpp stanza)
+11
(sigil xmpp connection))
+12
+13
(export
+14
;; Presence info
+15
presence-info
+16
presence-info?
+17
presence-info-jid
+18
presence-info-show
+19
presence-info-status
+20
presence-info-priority
+21
+22
;; Presence operations
+23
xmpp-set-status
+24
xmpp-go-offline
+25
xmpp-presence-of
+26
xmpp-resources-of
+27
+28
;; Internal
+29
handle-presence-update)
+30
+31
(begin
+32
+33
;; ============================================================
+34
;; Presence Info
+35
;; ============================================================
+36
+37
(define-struct presence-info
+38
(jid)
+39
(show default: "available")
+40
(status default: #f)
+41
(priority default: 0))
+42
+43
+44
;; ============================================================
+45
;; Presence Operations
+46
;; ============================================================
+47
+48
;;; Set own presence status.
+49
;;;
+50
;;; ```scheme
+51
;;; (xmpp-set-status conn show: "away" status: "Be right back")
+52
;;; ```
+53
(define (xmpp-set-status conn (keys: (show #f) (status #f) (priority #f)))
+54
(xmpp-send conn
+55
(xmpp-presence show: show status: status priority: priority)))
+56
+57
;;; Go offline (send unavailable presence and disconnect).
+58
(define (xmpp-go-offline conn)
+59
(xmpp-send conn (xmpp-presence type: "unavailable"))
+60
(xmpp-disconnect conn))
+61
+62
;;; Get the cached presence info for a JID.
+63
;;;
+64
;;; Returns a presence-info record or #f.
+65
(define (xmpp-presence-of conn jid)
+66
(let ((presences (dict-ref (xmpp-connection-event-handlers conn)
+67
'%presences #f)))
+68
(and presences (dict-ref presences jid #f))))
+69
+70
;;; Get all available resources for a bare JID.
+71
;;;
+72
;;; Returns a list of full JID strings that are currently available.
+73
(define (xmpp-resources-of conn bare-jid)
+74
(let ((presences (dict-ref (xmpp-connection-event-handlers conn)
+75
'%presences #f)))
+76
(if (not presences)
+77
'()
+78
(let ((bare (jid-bare bare-jid)))
+79
(dict-fold
+80
(lambda (full-jid info result)
+81
(if (and (equal? (jid-bare full-jid) bare)
+82
(not (equal? (presence-info-show info) "unavailable")))
+83
(cons full-jid result)
+84
result))
+85
'()
+86
presences)))))
+87
+88
+89
;; ============================================================
+90
;; Presence Update Handling
+91
;; ============================================================
+92
+93
;; Handle incoming presence stanza and update cache
+94
(define (handle-presence-update conn stanza)
+95
(let* ((from (stanza-from stanza))
+96
(type (stanza-attr stanza 'type))
+97
(show-el (stanza-child stanza 'show))
+98
(status-el (stanza-child stanza 'status))
+99
(priority-el (stanza-child stanza 'priority))
+100
(presences (or (dict-ref (xmpp-connection-event-handlers conn)
+101
'%presences #f)
+102
#{})))
+103
(when from
+104
(if (equal? type "unavailable")
+105
;; Remove from presence cache
+106
(set-xmpp-connection-event-handlers!
+107
conn
+108
(dict-set (xmpp-connection-event-handlers conn)
+109
'%presences
+110
(dict-remove presences from)))
+111
;; Update presence cache
+112
(let ((info (presence-info
+113
jid: from
+114
show: (or (and show-el (sxml-text show-el)) "available")
+115
status: (and status-el (sxml-text status-el))
+116
priority: (if priority-el
+117
(or (string->number (sxml-text priority-el)) 0)
+118
0))))
+119
(set-xmpp-connection-event-handlers!
+120
conn
+121
(dict-set (xmpp-connection-event-handlers conn)
+122
'%presences
+123
(dict-set presences from info))))))))
+124
+125
))
src/sigil/xmpp/roster.sgladded
@@ -0,0 +1,199 @@
+1
;;; (sigil xmpp roster) - XMPP Roster Management
+2
;;;
+3
;;; Provides roster (contact list) management including fetching,
+4
;;; adding/removing contacts, and subscription handling.
+5
+6
(define-library (sigil xmpp roster)
+7
(import (sigil core)
+8
(sigil struct)
+9
(sigil sxml)
+10
(sigil xmpp stanza)
+11
(sigil xmpp connection))
+12
+13
(export
+14
;; Roster item
+15
roster-item
+16
roster-item?
+17
roster-item-jid
+18
roster-item-name
+19
roster-item-subscription
+20
roster-item-groups
+21
roster-item-ask
+22
+23
;; Roster operations
+24
xmpp-request-roster
+25
xmpp-roster
+26
xmpp-roster-item
+27
xmpp-roster-add
+28
xmpp-roster-remove
+29
+30
;; Subscription management
+31
xmpp-subscribe
+32
xmpp-accept-subscription
+33
xmpp-deny-subscription
+34
xmpp-unsubscribe
+35
+36
;; Internal (for connection module)
+37
handle-roster-push
+38
parse-roster-query)
+39
+40
(begin
+41
+42
;; ============================================================
+43
;; Roster Item
+44
;; ============================================================
+45
+46
(define-struct roster-item
+47
(jid)
+48
(name default: #f)
+49
(subscription default: "none")
+50
(groups default: '())
+51
(ask default: #f))
+52
+53
+54
;; ============================================================
+55
;; Roster Parsing
+56
;; ============================================================
+57
+58
;; Parse a roster query element into a list of roster-items
+59
(define (parse-roster-query query-el)
+60
(let ((items (stanza-children query-el 'item)))
+61
(map (lambda (item)
+62
(let ((groups (map sxml-text (stanza-children item 'group))))
+63
(roster-item
+64
jid: (stanza-attr item 'jid)
+65
name: (stanza-attr item 'name)
+66
subscription: (or (stanza-attr item 'subscription) "none")
+67
groups: groups
+68
ask: (stanza-attr item 'ask))))
+69
items)))
+70
+71
+72
;; ============================================================
+73
;; Roster Operations
+74
;; ============================================================
+75
+76
;;; Request the roster from the server.
+77
;;;
+78
;;; Calls `callback` with a list of `roster-item` records.
+79
;;;
+80
;;; ```scheme
+81
;;; (xmpp-request-roster conn
+82
;;; (lambda (items)
+83
;;; (for-each (lambda (item)
+84
;;; (display (roster-item-jid item)))
+85
;;; items)))
+86
;;; ```
+87
(define (xmpp-request-roster conn callback)
+88
(xmpp-send-iq conn
+89
(xmpp-iq type: "get"
+90
children: (list '(query (@ (xmlns "jabber:iq:roster")))))
+91
(lambda (response)
+92
(let ((query (stanza-child response 'query)))
+93
(if query
+94
(callback (parse-roster-query query))
+95
(callback '()))))))
+96
+97
;;; Get the cached roster as a list of roster-items.
+98
;;;
+99
;;; Returns #f if the roster hasn't been fetched yet.
+100
(define (xmpp-roster conn)
+101
;; Roster is stored in the connection's event handlers dict
+102
;; under the '%roster key
+103
(dict-ref (xmpp-connection-event-handlers conn) '%roster #f))
+104
+105
;;; Look up a specific contact in the cached roster.
+106
(define (xmpp-roster-item conn jid)
+107
(let ((roster (xmpp-roster conn)))
+108
(and roster
+109
(let loop ((items roster))
+110
(if (null? items)
+111
#f
+112
(if (equal? (roster-item-jid (car items)) (jid-bare jid))
+113
(car items)
+114
(loop (cdr items))))))))
+115
+116
;;; Add or update a contact in the roster.
+117
;;;
+118
;;; ```scheme
+119
;;; (xmpp-roster-add conn "[email protected]" name: "Friend")
+120
;;; ```
+121
(define (xmpp-roster-add conn jid (keys: (name #f) (groups '())))
+122
(let ((children
+123
(append
+124
(if name
+125
`((item (@ (jid ,jid) (name ,name))))
+126
`((item (@ (jid ,jid)))))
+127
(map (lambda (g) `(group ,g)) groups))))
+128
(xmpp-send conn
+129
(xmpp-iq type: "set"
+130
children: (list
+131
`(query (@ (xmlns "jabber:iq:roster"))
+132
,@children))))))
+133
+134
;;; Remove a contact from the roster.
+135
(define (xmpp-roster-remove conn jid)
+136
(xmpp-send conn
+137
(xmpp-iq type: "set"
+138
children: (list
+139
`(query (@ (xmlns "jabber:iq:roster"))
+140
(item (@ (jid ,jid) (subscription "remove"))))))))
+141
+142
+143
;; ============================================================
+144
;; Subscription Management
+145
;; ============================================================
+146
+147
;;; Send a subscription request to a JID.
+148
(define (xmpp-subscribe conn jid)
+149
(xmpp-send conn (xmpp-presence to: jid type: "subscribe")))
+150
+151
;;; Accept a subscription request from a JID.
+152
(define (xmpp-accept-subscription conn jid)
+153
(xmpp-send conn (xmpp-presence to: jid type: "subscribed")))
+154
+155
;;; Deny a subscription request from a JID.
+156
(define (xmpp-deny-subscription conn jid)
+157
(xmpp-send conn (xmpp-presence to: jid type: "unsubscribed")))
+158
+159
;;; Unsubscribe from a JID's presence.
+160
(define (xmpp-unsubscribe conn jid)
+161
(xmpp-send conn (xmpp-presence to: jid type: "unsubscribe")))
+162
+163
+164
;; ============================================================
+165
;; Roster Push Handling
+166
;; ============================================================
+167
+168
;; Handle incoming roster push IQ from server
+169
(define (handle-roster-push conn stanza)
+170
(let ((query (stanza-child stanza 'query)))
+171
(when query
+172
(let ((items (parse-roster-query query)))
+173
;; Update cached roster
+174
(let ((roster (or (xmpp-roster conn) '())))
+175
(for-each
+176
(lambda (new-item)
+177
(let ((jid (roster-item-jid new-item)))
+178
(set! roster
+179
(if (equal? (roster-item-subscription new-item) "remove")
+180
;; Remove item
+181
(filter (lambda (i) (not (equal? (roster-item-jid i) jid)))
+182
roster)
+183
;; Add or replace
+184
(cons new-item
+185
(filter (lambda (i) (not (equal? (roster-item-jid i) jid)))
+186
roster))))))
+187
items)
+188
;; Store updated roster
+189
(set-xmpp-connection-event-handlers!
+190
conn
+191
(dict-set (xmpp-connection-event-handlers conn)
+192
'%roster roster)))
+193
+194
;; Acknowledge the push
+195
(xmpp-send conn
+196
(xmpp-iq type: "result"
+197
id: (stanza-id stanza)))))))
+198
+199
))
test/test-muc.sgladded
@@ -0,0 +1,47 @@
+1
(import (sigil test)
+2
(sigil string)
+3
(sigil xmpp stanza)
+4
(sigil xmpp muc))
+5
+6
;; ============================================================
+7
;; MUC Data Structures
+8
;; ============================================================
+9
+10
(test-group "muc-structs"
+11
(test "create muc-room"
+12
(let ((room (muc-room jid: "[email protected]" nick: "bot")))
+13
(assert-equal "[email protected]" (muc-room-jid room))
+14
(assert-equal "bot" (muc-room-nick room))
+15
(assert-false (muc-room-joined? room))))
+16
+17
(test "create muc-occupant"
+18
(let ((occ (muc-occupant nick: "alice"
+19
jid: "[email protected]/res"
+20
affiliation: "member"
+21
role: "participant")))
+22
(assert-equal "alice" (muc-occupant-nick occ))
+23
(assert-equal "[email protected]/res" (muc-occupant-jid occ))
+24
(assert-equal "member" (muc-occupant-affiliation occ))
+25
(assert-equal "participant" (muc-occupant-role occ)))))
+26
+27
;; ============================================================
+28
;; MUC Message Construction
+29
;; ============================================================
+30
+31
(test-group "muc-messages"
+32
(test "groupchat message"
+33
(let ((msg (xmpp-message to: "[email protected]" type: "groupchat"
+34
body: "Hello room" id: "m1")))
+35
(assert-equal "groupchat" (stanza-attr msg 'type))
+36
(assert-equal "[email protected]" (stanza-to msg))
+37
(assert-equal "Hello room" (message-body msg))))
+38
+39
(test "MUC join presence has x element"
+40
(let ((p (xmpp-presence
+41
to: "[email protected]/bot"
+42
children: (list '(x (@ (xmlns "http://jabber.org/protocol/muc")))))))
+43
(assert-equal "[email protected]/bot" (stanza-to p))
+44
(let ((x (stanza-child p 'x)))
+45
(assert-true (pair? x))))))
+46
+47
(run-tests)
test/test-roster.sgladded
@@ -0,0 +1,57 @@
+1
(import (sigil test)
+2
(sigil xmpp roster)
+3
(sigil xmpp stanza))
+4
+5
;; ============================================================
+6
;; Roster Parsing
+7
;; ============================================================
+8
+9
(test-group "roster-parsing"
+10
(test "parse roster query"
+11
(let ((items (parse-roster-query
+12
'(query (@ (xmlns "jabber:iq:roster"))
+13
(item (@ (jid "[email protected]")
+14
(name "Alice")
+15
(subscription "both"))
+16
(group "Friends"))
+17
(item (@ (jid "[email protected]")
+18
(subscription "from")))))))
+19
(assert-equal 2 (length items))
+20
+21
(let ((alice (car items)))
+22
(assert-equal "[email protected]" (roster-item-jid alice))
+23
(assert-equal "Alice" (roster-item-name alice))
+24
(assert-equal "both" (roster-item-subscription alice))
+25
(assert-equal '("Friends") (roster-item-groups alice)))
+26
+27
(let ((bob (cadr items)))
+28
(assert-equal "[email protected]" (roster-item-jid bob))
+29
(assert-false (roster-item-name bob))
+30
(assert-equal "from" (roster-item-subscription bob))
+31
(assert-equal '() (roster-item-groups bob)))))
+32
+33
(test "parse empty roster"
+34
(let ((items (parse-roster-query
+35
'(query (@ (xmlns "jabber:iq:roster"))))))
+36
(assert-equal '() items)))
+37
+38
(test "parse roster item with multiple groups"
+39
(let ((items (parse-roster-query
+40
'(query (@ (xmlns "jabber:iq:roster"))
+41
(item (@ (jid "a@b") (subscription "both"))
+42
(group "Work")
+43
(group "Friends"))))))
+44
(assert-equal '("Work" "Friends")
+45
(roster-item-groups (car items))))))
+46
+47
;; ============================================================
+48
;; Subscription Stanza Construction
+49
;; ============================================================
+50
+51
(test-group "subscription"
+52
(test "subscribe presence type"
+53
(let ((p (xmpp-presence to: "[email protected]" type: "subscribe")))
+54
(assert-equal "subscribe" (stanza-attr p 'type))
+55
(assert-equal "[email protected]" (stanza-to p)))))
+56
+57
(run-tests)