Browse Source

xmpp: NIH a whole promises library (!), use it for disco#info

- I anticipate we're going to need a promises-like abstraction (like what
  whatsxmpp had), because sending and receiving stanzas is by nature async.
  - So I NIH'd one to avoid having to import blackbird, and we now use it
    for IQ-GET.
- This has the rather nifty effect that we can use the "join" abstraction
  provided to only populate *SERVER-FEATURES* once both IQ-gets (self, server)
  have returned!
master
eta 1 month ago
parent
commit
70685f40c0
  1. 231
      src/plugins/xmpp/support.lisp

231
src/plugins/xmpp/support.lisp

@ -1,5 +1,8 @@
;; TODO(eta): use something like STRING-CASE in this file
;;; Package definitions
(defpackage :wee-impl
(:use))
@ -12,6 +15,8 @@
(in-package :weexmpp)
;;; Globals
(defvar *jid* nil
"Jabber ID (JID) of active connection. NIL if not connected yet.")
(defvar *iq-hash-table* (make-hash-table :test #'equal)
@ -22,6 +27,145 @@
(defparameter +ns-bind+ "urn:ietf:params:xml:ns:xmpp-bind")
(defparameter +ns-disco-info+ "http://jabber.org/protocol/disco#info")
;;; Thenables library
(defclass thenable ()
((callbacks
:accessor callbacks
:initform nil)
(state
:initform :pending
:accessor state)
(name
:initarg :name
:reader name)
(errbacks
:accessor errbacks
:initform nil)
(resolved-value
:accessor resolved-value
:initform nil)
(rejected-value
:accessor rejected-value
:initform nil)))
(defmethod print-object ((obj thenable) stream)
(print-unreadable-object (obj stream :type t)
(with-slots (state callbacks errbacks name) obj
(format stream "\"~A\" ~A (~A cb, ~A eb)"
name state (length callbacks) (length errbacks)))))
(defun thenable-resolve (thenable args-list)
(unless (eql (state thenable) :pending)
(error "Thenable ~A is already ~A (tried to resolve)"
thenable (state thenable)))
(setf (state thenable) :resolved)
(setf (resolved-value thenable) args-list)
(dolist (callback (callbacks thenable))
(apply callback args-list)))
(defun thenable-reject (thenable args-list)
(unless (eql (state thenable) :pending)
(error "Thenable ~A is already ~A (tried to reject)"
thenable (state thenable)))
(setf (state thenable) :rejected)
(setf (rejected-value thenable) args-list)
(dolist (callback (errbacks thenable))
(apply callback args-list)))
(defmacro with-thenable ((&key resolve reject name) &body body)
(let ((thenable-sym (gensym "thenable"))
(args1-sym (gensym "args"))
(args2-sym (gensym "args"))
(resolve-sym (or resolve (gensym "resolve")))
(reject-sym (or reject (gensym "reject")))
(condition-sym (gensym "condition")))
`(let ((,thenable-sym
(make-instance 'thenable
:name (or ,name "unnamed thenable"))))
(labels
((,resolve-sym (&rest ,args1-sym)
(thenable-resolve ,thenable-sym ,args1-sym))
(,reject-sym (&rest ,args2-sym)
(thenable-reject ,thenable-sym ,args2-sym)))
(handler-case
(progn ,@body)
(serious-condition (,condition-sym)
(,reject-sym ,condition-sym))))
,thenable-sym)))
(defun thenable-immediate (value)
(with-thenable (:resolve resolve
:name "immediate thenable")
(resolve value)))
(defun do-then (thenable &optional callback errback)
(with-thenable (:resolve resolve
:reject reject
:name (format nil "then: ~A"
(name thenable)))
(when callback
(let ((next-callback
(lambda (&rest args)
(handler-case
(let ((result (apply callback args)))
(typecase result
(thenable
(do-then result #'resolve #'reject))
(t
(apply #'resolve result))))
(serious-condition (c)
(reject c))))))
(if (eql (state thenable) :resolved)
(apply next-callback (resolved-value thenable))
(push next-callback (callbacks thenable)))))
(let ((err-callback
(lambda (&rest args)
(when errback
(ignore-errors (apply errback args)))
(apply #'reject args))))
(if (eql (state thenable) :rejected)
(apply err-callback (rejected-value thenable))
(push err-callback (errbacks thenable))))))
(defun thenable-join (&rest thenables)
(with-thenable (:resolve resolve
:reject reject
:name (format nil "join of ~A thenables"
(length thenables)))
(let ((results (make-array (length thenables)
:initial-element nil))
(num-resolved 0)
(num 0)
(num-needed (length thenables))
(err nil))
(labels
((each-callback (nth &rest args)
(unless err
(setf (aref results nth) args)
(when (eql (incf num-resolved) num-needed)
(apply #'resolve (coerce results 'list)))))
(each-errback (&rest args)
(unless err
(apply #'reject args))))
(dolist (thenable thenables)
(let ((i (1- (incf num))))
(do-then thenable
(lambda (&rest args)
(apply #'each-callback i args))
#'each-errback)))))))
(defmacro then (thenable lambda-list &body body)
`(do-then ,thenable
(lambda ,lambda-list ,@body)))
(defmacro then-err (thenable lambda-list &body body)
`(do-then ,thenable
nil
(lambda ,lambda-list ,@body)))
;;; WeeChat output gray streams
(defclass weechat-output (gray::fundamental-character-output-stream)
((to-err
:initarg :to-err
@ -280,26 +424,24 @@
(random (expt 2 32))
(get-universal-time)))
(defvar *current-stanza-id* :sentinel)
(defun do-on-result (func)
(when (eql *current-stanza-id* :sentinel)
(error "ON-RESULT may only be used from within an IQ-GET invocation"))
(setf (gethash *current-stanza-id* *iq-hash-table*)
func))
(defmacro on-result ((stanza) &body body)
`(do-on-result (lambda (,stanza) ,@body)))
(defmacro iq-get ((&key to id) &body body)
`(let ((*current-stanza-id* (or ,id (generate-id))))
(stanzaize ("iq")
,@(when to
`((stanza-attr "to" ,to)))
(stanza-attr "from" *jid*)
(stanza-attr "id" *current-stanza-id*)
(stanza-attr "type" "get")
,@body)))
(let ((stanza-id-sym (gensym "stanza-id"))
(thenable-sym (gensym "thenable")))
`(let* ((,stanza-id-sym (or ,id (generate-id)))
(,thenable-sym
(make-instance 'thenable
:name (format nil "IQ ~A" ,stanza-id-sym))))
(setf (gethash ,stanza-id-sym *iq-hash-table*)
,thenable-sym)
(send
(stanzaize ("iq")
,@(when to
`((stanza-attr "to" ,to)))
(stanza-attr "from" *jid*)
(stanza-attr "id" ,stanza-id-sym)
(stanza-attr "type" "get")
,@body))
,thenable-sym)))
(defun bare-jid (jid)
"Strips the resource component from JID, if there is one."
@ -316,18 +458,29 @@
(subseq jid (1+ at))
jid)))
(defun update-server-features (entity)
(send
(iq-get (:to entity)
(stanzaize ("query")
(stanza-attr "xmlns" +ns-disco-info+))
(on-result (stanza)
(let ((query-child (s-child "query" stanza)))
(dolist (child (children query-child))
(when (string= (name child) "feature")
(push (s-attr "var" child) *server-features*)))
(printf "xmpp: identified ~A disco#info features for ~A"
(length *server-features*) entity))))))
(defun disco-info (entity)
(then
(iq-get (:to entity)
(stanzaize ("query")
(stanza-attr "xmlns" +ns-disco-info+)))
(stanza)
(let ((query-child (s-child "query" stanza))
(ret nil))
(dolist (child (children query-child))
(when (string= (name child) "feature")
(push (s-attr "var" child) ret)))
ret)))
(defun update-server-features ()
(then
(thenable-join
(disco-info (jid-hostname *jid*))
(disco-info (bare-jid *jid*)))
(server self)
(let ((both (append server self)))
(printf "xmpp: identified ~A disco#info features (~A server, ~A self)"
(length both) (length server) (length self))
(setf *server-features* both))))
;; Stanza handling
@ -343,8 +496,7 @@
(progn
(setf *jid* bound-jid)
(update-presence)
(update-server-features (jid-hostname *jid*))
(update-server-features (bare-jid *jid*))
(update-server-features)
(printf "xmpp: bound to JID ~A" bound-jid))
(eprintf "xmpp: failed to destructure bind stanza! rendered ~A"
(render-stanza stanza)))))
@ -352,16 +504,9 @@
(s-name-is "iq" stanza)
(s-attr-is "type" "result" stanza))
(let* ((id (s-attr "id" stanza))
(func (gethash id *iq-hash-table*)))
(if func
(progn
(handler-case
(funcall func stanza)
(error (e)
(eprintf "xmpp: IQ handler for ~A failed: ~A"
id e)))
(remhash id *iq-hash-table*))
(eprintf "xmpp: no IQ handler registered: ~A" (render-stanza stanza)))))
(thenable (gethash id *iq-hash-table*)))
(thenable-resolve thenable (list stanza))
(remhash id *iq-hash-table*)))
((and
(s-name-is "iq" stanza)
(s-attr-is "type" "error" stanza))

Loading…
Cancel
Save