Add procedure specs to xmpp and irc packages

Changed

 src/sigil/xmpp.sgl            |  1 +
 src/sigil/xmpp/connection.sgl | 14 ++++++++++++++
 src/sigil/xmpp/muc.sgl        |  8 ++++++++
 src/sigil/xmpp/presence.sgl   |  4 ++++
 src/sigil/xmpp/roster.sgl     |  9 +++++++++
 src/sigil/xmpp/sasl.sgl       |  6 ++++++
 src/sigil/xmpp/stanza.sgl     | 17 +++++++++++++++++
 7 files changed, 59 insertions(+)

Diff

src/sigil/xmpp.sglmodified

@@ -90,6 +90,7 @@

;;; (xmpp-connect conn)

;;; ```

(define (xmpp-install-features conn)

+93

(: xmpp-connection? -> void?)

;; Handle roster pushes (IQ set with jabber:iq:roster)

(xmpp-on conn 'iq

(lambda (stanza)

src/sigil/xmpp/connection.sglmodified

@@ -110,6 +110,7 @@

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

@@ -125,6 +126,7 @@

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

@@ -184,6 +186,7 @@

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,6 +196,7 @@

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!

@@ -221,6 +225,7 @@

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

@@ -265,10 +270,12 @@

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.

@@ -281,6 +288,7 @@

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!

@@ -291,6 +299,7 @@

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

@@ -305,6 +314,7 @@

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

@@ -556,6 +566,7 @@

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

@@ -582,6 +593,7 @@

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

@@ -608,6 +620,7 @@

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

@@ -622,6 +635,7 @@

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)

src/sigil/xmpp/muc.sglmodified

@@ -89,6 +89,7 @@

;;; (xmpp-muc-join conn "[email protected]" "mynick")

;;; ```

(define (xmpp-muc-join conn room-jid nick)

+92

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

;; Register room

(let* ((rooms (get-muc-rooms conn))

(room (muc-room jid: room-jid nick: nick)))

@@ -102,6 +103,7 @@

103

104

;;; Leave a MUC room.

105

(define (xmpp-muc-leave conn room-jid (keys: (reason #f)))

+106

(: xmpp-connection? string? (reason: any?) -> void?)

107

(let ((room (get-room conn room-jid)))

108

(when room

109

(xmpp-send conn

@@ -121,17 +123,20 @@

123

;;; (xmpp-muc-message conn "[email protected]" "Hello room!")

124

;;; ```

125

(define (xmpp-muc-message conn room-jid body)

+126

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

127

(xmpp-send conn

128

(xmpp-message to: room-jid type: "groupchat" body: body)))

129

130

;;; Send a private message to a MUC occupant.

131

(define (xmpp-muc-private-message conn room-jid nick body)

+132

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

133

(xmpp-send conn

134

(xmpp-message to: (string-append room-jid "/" nick)

135

type: "chat" body: body)))

136

137

;;; Set the subject of a MUC room.

138

(define (xmpp-muc-set-subject conn room-jid subject)

+139

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

140

(xmpp-send conn

141

(xmpp-message to: room-jid type: "groupchat" subject: subject)))

142

@@ -139,6 +144,7 @@

144

;;;

145

;;; Returns a list of muc-occupant records, or '() if not in the room.

146

(define (xmpp-muc-occupants conn room-jid)

+147

(: xmpp-connection? string? -> list?)

148

(let ((room (get-room conn room-jid)))

149

(if room

150

(dict-values (muc-room-occupants room))

@@ -146,6 +152,7 @@

152

153

;;; Kick an occupant from a MUC room (requires moderator role).

154

(define (xmpp-muc-kick conn room-jid nick (keys: (reason #f)))

+155

(: xmpp-connection? string? string? (reason: any?) -> void?)

156

(xmpp-send conn

157

(xmpp-iq type: "set" to: room-jid

158

children: (list

@@ -157,6 +164,7 @@

164

165

;;; Send a mediated invitation to a user.

166

(define (xmpp-muc-invite conn room-jid invitee-jid (keys: (reason #f)))

+167

(: xmpp-connection? string? string? (reason: any?) -> void?)

168

(xmpp-send conn

169

(xmpp-message to: room-jid

170

children: (list

src/sigil/xmpp/presence.sglmodified

@@ -51,11 +51,13 @@

;;; (xmpp-set-status conn show: "away" status: "Be right back")

;;; ```

(define (xmpp-set-status conn (keys: (show #f) (status #f) (priority #f)))

+54

(: xmpp-connection? (show: any?) (status: any?) (priority: any?) -> void?)

(xmpp-send conn

(xmpp-presence show: show status: status priority: priority)))

;;; Go offline (send unavailable presence and disconnect).

(define (xmpp-go-offline conn)

+60

(: xmpp-connection? -> void?)

(xmpp-send conn (xmpp-presence type: "unavailable"))

(xmpp-disconnect conn))

@@ -63,6 +65,7 @@

;;;

;;; Returns a presence-info record or #f.

(define (xmpp-presence-of conn jid)

+68

(: xmpp-connection? string? -> any?)

(let ((presences (dict-ref (xmpp-connection-event-handlers conn)

'%presences #f)))

(and presences (dict-ref presences jid #f))))

@@ -71,6 +74,7 @@

;;;

;;; Returns a list of full JID strings that are currently available.

(define (xmpp-resources-of conn bare-jid)

+77

(: xmpp-connection? string? -> list?)

(let ((presences (dict-ref (xmpp-connection-event-handlers conn)

'%presences #f)))

(if (not presences)

src/sigil/xmpp/roster.sglmodified

@@ -85,6 +85,7 @@

;;; items)))

;;; ```

(define (xmpp-request-roster conn callback)

+88

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

(xmpp-send-iq conn

(xmpp-iq type: "get"

children: (list '(query (@ (xmlns "jabber:iq:roster")))))

@@ -98,12 +99,14 @@

;;;

100

;;; Returns #f if the roster hasn't been fetched yet.

101

(define (xmpp-roster conn)

+102

(: xmpp-connection? -> any?)

103

;; Roster is stored in the connection's event handlers dict

104

;; under the '%roster key

105

(dict-ref (xmpp-connection-event-handlers conn) '%roster #f))

106

107

;;; Look up a specific contact in the cached roster.

108

(define (xmpp-roster-item conn jid)

+109

(: xmpp-connection? string? -> any?)

110

(let ((roster (xmpp-roster conn)))

111

(and roster

112

(let loop ((items roster))

@@ -119,6 +122,7 @@

122

;;; (xmpp-roster-add conn "[email protected]" name: "Friend")

123

;;; ```

124

(define (xmpp-roster-add conn jid (keys: (name #f) (groups '())))

+125

(: xmpp-connection? string? (name: any?) (groups: list?) -> void?)

126

(let ((children

127

(append

128

(if name

@@ -133,6 +137,7 @@

137

138

;;; Remove a contact from the roster.

139

(define (xmpp-roster-remove conn jid)

+140

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

141

(xmpp-send conn

142

(xmpp-iq type: "set"

143

children: (list

@@ -146,18 +151,22 @@

151

152

;;; Send a subscription request to a JID.

153

(define (xmpp-subscribe conn jid)

+154

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

155

(xmpp-send conn (xmpp-presence to: jid type: "subscribe")))

156

157

;;; Accept a subscription request from a JID.

158

(define (xmpp-accept-subscription conn jid)

+159

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

160

(xmpp-send conn (xmpp-presence to: jid type: "subscribed")))

161

162

;;; Deny a subscription request from a JID.

163

(define (xmpp-deny-subscription conn jid)

+164

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

165

(xmpp-send conn (xmpp-presence to: jid type: "unsubscribed")))

166

167

;;; Unsubscribe from a JID's presence.

168

(define (xmpp-unsubscribe conn jid)

+169

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

170

(xmpp-send conn (xmpp-presence to: jid type: "unsubscribe")))

171

172

src/sigil/xmpp/sasl.sglmodified

@@ -62,6 +62,7 @@

;;; (define scram (make-scram-sha1 "user" "password"))

;;; ```

(define (make-scram-sha1 username password)

+65

(: string? string? -> vector?)

(let ((state (make-vector 8 #f))

(nonce (base64-encode (random-bytes 18))))

(vector-set! state 0 username)

@@ -76,6 +77,7 @@

;;;

;;; Returns the base64-encoded message to send in the SASL auth element.

(define (scram-initial-message state)

+80

(: vector? -> string?)

(let* ((username (vector-ref state 0))

(nonce (vector-ref state 2))

(bare (string-append "n=" username ",r=" nonce)))

@@ -105,6 +107,7 @@

107

;;; Takes the base64-encoded server challenge, returns the base64-encoded

108

;;; client-final-message.

109

(define (scram-challenge-response state server-challenge-b64)

+110

(: vector? string? -> string?)

111

(let* ((server-msg (utf8->string (base64-decode server-challenge-b64)))

112

(parts (parse-scram-challenge server-msg))

113

(server-nonce (cdr (assoc "r" parts)))

@@ -150,6 +153,7 @@

153

;;;

154

;;; Returns #t if the server signature matches, #f otherwise.

155

(define (scram-verify-server state server-final-b64)

+156

(: vector? string? -> boolean?)

157

(let* ((server-msg (utf8->string (base64-decode server-final-b64)))

158

(parts (parse-scram-challenge server-msg))

159

(server-sig-b64 (cdr (assoc "v" parts)))

@@ -165,6 +169,7 @@

169

;;;

170

;;; Format: base64(\0username\0password)

171

(define (sasl-plain-response username password)

+172

(: string? string? -> string?)

173

(let* ((user-bv (string->utf8 username))

174

(pass-bv (string->utf8 password))

175

(zero (make-bytevector 1 0))

@@ -183,6 +188,7 @@

188

;;;

189

;;; Returns a symbol: 'scram-sha-1, 'plain, or #f if none supported.

190

(define (select-sasl-mechanism offered)

+191

(: list? -> any?)

192

(let loop ((prefs mechanism-priority))

193

(if (null? prefs)

194

#f

src/sigil/xmpp/stanza.sglmodified

@@ -64,6 +64,7 @@

;;; ; => #<jid local: "user" domain: "example.com" resource: "bot">

;;; ```

(define (parse-jid str)

+67

(: string? -> jid?)

(let ((at-pos (string-index str (lambda (c) (char=? c #\@))))

(slash-pos (string-index str (lambda (c) (char=? c #\/)))))

(cond

@@ -91,6 +92,7 @@

;;; ; => "[email protected]/bot"

;;; ```

(define (jid->string j)

+95

(: jid? -> string?)

(let ((local (jid-local j))

(domain (jid-domain j))

(resource (jid-resource j)))

@@ -110,6 +112,7 @@

112

;;; (jid-bare (parse-jid "[email protected]/bot")) ; => "[email protected]"

113

;;; ```

114

(define (jid-bare j)

+115

(: any? -> string?)

116

(let ((j (if (string? j) (parse-jid j) j)))

117

(let ((local (jid-local j))

118

(domain (jid-domain j)))

@@ -128,6 +131,7 @@

131

;;;

132

;;; Uses a counter combined with random bytes for uniqueness.

133

(define (generate-stanza-id)

+134

(: -> string?)

135

(set! id-counter (+ id-counter 1))

136

(string-append "s" (number->string id-counter) "-"

137

(base64-encode (random-bytes 6))))

@@ -160,6 +164,7 @@

164

(define (xmpp-message (keys: (to #f) (from #f) (type "chat")

165

(id #f) (body #f) (subject #f)

166

(children '())))

+167

(: (to: any?) (from: any?) (type: string?) (id: any?) (body: any?) (subject: any?) (children: list?) -> list?)

168

(let ((id (or id (generate-stanza-id))))

169

(append

170

(cons 'message

@@ -176,6 +181,7 @@

181

(define (xmpp-presence (keys: (to #f) (from #f) (type #f)

182

(id #f) (show #f) (status #f)

183

(priority #f) (children '())))

+184

      (: (to: any?) (from: any?) (type: any?) (id: any?) (show: any?) (status: any?) (priority: any?) (children: list?) -> list?)

185

(append

186

(cons 'presence

187

(build-attrs 'to to 'from from 'type type 'id id))

@@ -194,6 +200,7 @@

200

;;; ```

201

(define (xmpp-iq (keys: (to #f) (from #f) (type "get")

202

(id #f) (children '())))

+203

(: (to: any?) (from: any?) (type: string?) (id: any?) (children: list?) -> list?)

204

(let ((id (or id (generate-stanza-id))))

205

(append

206

(cons 'iq

@@ -207,6 +214,7 @@

214

215

;;; Get the type of a stanza (message, presence, iq) as a symbol.

216

(define (stanza-type stanza)

+217

(: list? -> any?)

218

(if (pair? stanza) (car stanza) #f))

219

220

;;; Get an attribute value from a stanza.

@@ -215,18 +223,22 @@

223

;;; (stanza-attr msg 'to) ; => "[email protected]"

224

;;; ```

225

(define (stanza-attr stanza name)

+226

(: list? symbol? -> any?)

227

(sxml-attr-ref stanza name))

228

229

;;; Get the 'to' attribute of a stanza.

230

(define (stanza-to stanza)

+231

(: list? -> any?)

232

(sxml-attr-ref stanza 'to))

233

234

;;; Get the 'from' attribute of a stanza.

235

(define (stanza-from stanza)

+236

(: list? -> any?)

237

(sxml-attr-ref stanza 'from))

238

239

;;; Get the 'id' attribute of a stanza.

240

(define (stanza-id stanza)

+241

(: list? -> any?)

242

(sxml-attr-ref stanza 'id))

243

244

;;; Get the body text from a message stanza.

@@ -236,6 +248,7 @@

248

;;; ; => "Hello"

249

;;; ```

250

(define (message-body stanza)

+251

(: list? -> any?)

252

(let ((body-el (stanza-child stanza 'body)))

253

(if body-el

254

(sxml-text body-el)

@@ -247,6 +260,7 @@

260

;;; (stanza-child msg 'body) ; => (body "Hello")

261

;;; ```

262

(define (stanza-child stanza tag)

+263

(: list? symbol? -> any?)

264

(let ((content (sxml-content stanza)))

265

(let loop ((items content))

266

(if (null? items)

@@ -258,6 +272,7 @@

272

273

;;; Find all child elements with the given tag name.

274

(define (stanza-children stanza tag)

+275

(: list? symbol? -> list?)

276

(let ((content (sxml-content stanza)))

277

(let loop ((items content) (result '()))

278

(if (null? items)

@@ -271,6 +286,7 @@

286

;;;

287

;;; Returns the concatenation of all string children, or #f if none.

288

(define (sxml-text element)

+289

(: any? -> any?)

290

(if (not (pair? element))

291

#f

292

(let ((content (sxml-content element)))

@@ -296,6 +312,7 @@

312

;;; ; => "<message to=\"[email protected]\" ...><body>Hi</body></message>"

313

;;; ```

314

(define (stanza->xml stanza)

+315

(: list? -> string?)

316

(sxml->xml stanza))

317

318

))