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!

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