diff --git a/stuff.lisp b/stuff.lisp
index 1d78f75..7e7a51e 100644
--- a/stuff.lisp
+++ b/stuff.lisp
@@ -1,10 +1,13 @@
(defpackage :whatsxmpp
- (:use :cl :usocket :event-emitter))
+ (:use :cl :usocket :event-emitter :blackbird :blackbird-base))
(in-package :whatsxmpp)
(defvar *last-stanza*)
(defparameter +streams-ns+ "urn:ietf:params:xml:ns:xmpp-streams")
+(defparameter +stanzas-ns+ "urn:ietf:params:xml:ns:xmpp-stanzas")
(defparameter +component-ns+ "jabber:component:accept")
+(defparameter +disco-info-ns+ "http://jabber.org/protocol/disco#info")
+(defparameter +disco-items-ns+ "http://jabber.org/protocol/disco#items")
(defclass xmpp-component (event-emitter)
((socket
@@ -27,15 +30,15 @@
:accessor component-stream-id)
(shared-secret
:initarg :shared-secret
- :reader component-shared-secret)))
+ :reader component-shared-secret)
+ (promises
+ :initform (make-hash-table :test 'equal)
+ :accessor component-promises)))
-(defmacro with-component-data-lock (comp &body body)
+(defmacro with-component-data-lock ((comp) &body body)
`(bt:with-recursive-lock-held ((component-data-lock ,comp))
,@body))
-(defmethod sax:start-document ((s start-ignoring-sink))
- (declare (ignore s)))
-
(defclass xmpp-source (cxml:broadcast-handler)
((component
:initarg :component
@@ -64,7 +67,7 @@
(when (not stream-id-attr)
(error "Server didn't send a stream ID"))
(format *debug-io* "~&XMPP --> [stream started, ID ~A]~%" (sax:attribute-value stream-id-attr))
- (with-component-data-lock comp
+ (with-component-data-lock (comp)
(setf (component-stream-id comp) (sax:attribute-value stream-id-attr))
(emit :stream-started comp))
(return-from sax:start-element))))
@@ -152,28 +155,126 @@
(cxml:parse fucking-stream source
:recode t)))
-(defmacro with-component-xml-output (comp &rest body)
- `(with-accessors ((lock component-socket-lock) (socket component-socket) (sink component-sink))
- ,comp
- (bt:with-recursive-lock-held (lock)
- (cxml:with-xml-output sink
- ,@body)
- (force-output socket))))
+(defmacro with-component-xml-output ((comp) &body body)
+ (let ((ret-sym (gensym)))
+ `(with-accessors ((lock component-socket-lock) (socket component-socket) (sink component-sink))
+ ,comp
+ (with-component-data-lock (,comp)
+ (bt:with-recursive-lock-held (lock)
+ (let ((,ret-sym nil))
+ (cxml:with-xml-output sink
+ (setf ,ret-sym ,@body))
+ (force-output socket)
+ ,ret-sym))))))
(defun write-stream-header (comp)
- (with-component-data-lock comp
- (with-component-xml-output comp
- (cxml:with-namespace ("stream" "http://etherx.jabber.org/streams")
- (cxml:with-element "stream:stream"
- (cxml:attribute "xmlns" +component-ns+)
- (cxml:attribute "to" (component-name comp)))))))
+ (with-component-xml-output (comp)
+ (cxml:with-namespace ("stream" "http://etherx.jabber.org/streams")
+ (cxml:with-element "stream:stream"
+ (cxml:attribute "xmlns" +component-ns+)
+ (cxml:attribute "to" (component-name comp))))))
(defun component-stream-started (comp)
- (with-component-data-lock comp
- (with-component-xml-output comp
- (cxml:with-element "handshake"
- (cxml:attribute "xmlns" +component-ns+)
- (cxml:text (string-downcase (sha1:sha1-hex (concatenate 'string (component-stream-id comp) (component-shared-secret comp)))))))))
+ (with-component-xml-output (comp)
+ (cxml:with-element "handshake"
+ (cxml:attribute "xmlns" +component-ns+)
+ (cxml:text (string-downcase (sha1:sha1-hex (concatenate 'string (component-stream-id comp) (component-shared-secret comp))))))))
+
+(defun make-message-uuid (comp)
+ (with-accessors ((promises component-promises)) comp
+ (let ((uuid (string-downcase (write-to-string (uuid:make-v4-uuid))))
+ (promise (make-promise)))
+ (setf (gethash uuid promises) promise)
+ (values uuid promise))))
+
+(defmacro with-stanza ((comp stanza-name &key type from to) &body body)
+ (alexandria:with-gensyms (uuid ret from-sym)
+ `(with-component-xml-output (,comp)
+ (let ((,from-sym (or ,from (component-name ,comp))))
+ (multiple-value-bind (,uuid ,ret)
+ (make-message-uuid ,comp)
+ (cxml:with-element ,stanza-name
+ (cxml:attribute "from" ,from-sym)
+ (cxml:attribute "id" ,uuid)
+ ,(when to
+ `(cxml:attribute "to" ,to))
+ ,(when type
+ `(cxml:attribute "type" ,type))
+ ,@body)
+ ,ret)))))
+
+(defmacro with-iq ((comp to &key (type "get") from) &body body)
+ "Send an IQ stanza (of type TYPE) on the COMP component, from the JID FROM (default: component name) to the JID TO, with BODY specifying further CXML commands to make up the body of the stanza. Returns a promise."
+ `(with-stanza (,comp "iq"
+ :type ,type
+ :to ,to
+ :from ,from)
+ ,@body))
+
+(defmacro with-message ((comp to &key (type "chat") from) &body body)
+ "Send a message stanza (of type TYPE) on the COMP component. Semantics the same as WITH-IQ, except for the fact that message stanzas don't normally prompt a response."
+ `(with-stanza (,comp "message"
+ :type ,type
+ :to ,to
+ :from ,from)
+ ,@body))
+
+(defmacro with-presence ((comp to &key type from) &body body)
+ "Send a presence stanza (of type TYPE) on the COMP component. Semantics the same as WITH-IQ, except for the fact that presence stanzas don't normally prompt a response."
+ `(with-stanza (,comp "presence"
+ :type ,type
+ :to ,to
+ :from ,from)
+ ,@body))
+
+(defun get-node-named (nodes name)
+ "Finds the node with tag name NAME in NODES, returning NIL if none was found."
+ (flet ((is-the-node (node) (equal (dom:tag-name node) name)))
+ (find-if #'is-the-node nodes)))
+
+(defun get-disco-info (comp to &optional from)
+ "Send an XEP-0030 disco#info request. Returns a promise that resolves with a list of supported features."
+ (attach
+ (with-iq (comp to :from from)
+ (cxml:with-element "query"
+ (cxml:attribute "xmlns" +disco-info-ns+)))
+ (lambda (results)
+ (let ((query-node (get-node-named results "query"))
+ (features '()))
+ (unless query-node
+ (error "Malformed disco#info response: no "))
+ (loop
+ for node across (dom:child-nodes query-node)
+ do (let ((name (dom:tag-name node)))
+ (when (equal name "feature")
+ (setf features (cons (dom:get-attribute node "var") features)))))
+ features))))
+
+(defun get-disco-items (comp to &optional from)
+ "Send an XEP-0030 disco#items request. Returns a promise that resolves with an alist, mapping JIDs to names."
+ (attach
+ (with-iq (comp to :from from)
+ (cxml:with-element "query"
+ (cxml:attribute "xmlns" +disco-items-ns+)))
+ (lambda (results)
+ (let ((query-node (get-node-named results "query"))
+ (items '()))
+ (unless query-node
+ (error "Malformed disco#items response: no "))
+ (loop
+ for node across (dom:child-nodes query-node)
+ do (let ((name (dom:tag-name node)))
+ (when (equal name "item")
+ (setf items (cons
+ (cons (dom:get-attribute node "jid") (dom:get-attribute node "name"))
+ items)))))
+ items))))
+
+(defun send-text-message (comp to-jid text &optional from)
+ "Send a simple text message to TO-JID, containing TEXT."
+ (with-message (comp to-jid :from from)
+ (cxml:with-element "body"
+ (cxml:text text))))
(defun handle-stream-error (comp stanza)
(flet ((is-error-node (node)
@@ -189,10 +290,70 @@
(warn "Stream error of type ~A encountered: ~A" error-name error-text)
(emit :stream-error comp error-name error-text stanza))))
+(define-condition stanza-error (error)
+ ((defined-condition
+ :initarg :defined-condition
+ :accessor stanza-error-condition)
+ (type
+ :initarg :type
+ :accessor stanza-error-type)
+ (text
+ :initarg :text
+ :initform nil
+ :accessor stanza-error-text)
+ (raw
+ :initarg :raw
+ :accessor stanza-error-raw))
+ (:report (lambda (err stream)
+ (with-slots (defined-condition type text) err
+ (format stream "~A (type ~A): ~A" defined-condition type text)))))
+
+(defun extract-stanza-error (stanza)
+ "Extracts a STANZA-ERROR from the given STANZA, which must contain an element conforming to RFC 6120 ยง 8.3."
+ (flet ((is-error-condition-node (node)
+ (equal (dom:namespace-uri node) +stanzas-ns+))
+ (is-error-node (node)
+ (equal (dom:tag-name node) "error"))
+ (is-text-node (node)
+ (and (equal (dom:namespace-uri node) +stanzas-ns+) (equal (dom:tag-name node) "text"))))
+ (let* ((error-node (find-if #'is-error-node (dom:child-nodes stanza)))
+ (error-children (dom:child-nodes error-node))
+ (type (dom:get-attribute error-node "type"))
+ (condition-node (find-if #'is-error-condition-node error-children))
+ (condition-name (dom:tag-name condition-node))
+ (text-node (find-if #'is-text-node error-children))
+ (text (when text-node
+ (dom:node-value (elt (dom:child-nodes text-node) 0)))))
+ (make-condition 'stanza-error
+ :raw error-node
+ :defined-condition condition-name
+ :type type
+ :text text))))
+
(defun handle-connection-complete (comp)
(declare (ignore comp))
(format *debug-io* "Connection complete! \o/"))
+(defun handle-iq-response (comp stanza)
+ "Handles an IQ response STANZA for component COMP."
+ (with-component-data-lock (comp)
+ (let ((type (dom:get-attribute stanza "type"))
+ (id (dom:get-attribute stanza "id"))
+ (from (dom:get-attribute stanza "from")))
+ (if (equal type "get")
+ (emit :iq-get comp id from stanza)
+ (symbol-macrolet
+ ((promise (gethash id (component-promises comp))))
+ (if promise
+ (progn
+ (format t "~&IQ ~A from ~A for ~A~%" type from id)
+ (cond
+ ((equal type "result") (finish promise (dom:child-nodes stanza)))
+ ((equal type "error") (signal-error promise (extract-stanza-error stanza)))
+ (t (warn "Invalid IQ stanza type: ~A" type)))
+ (setf promise nil))
+ (warn "Unsolicited IQ stanza from ~A of type ~A, ID ~A" from type id)))))))
+
(defun component-stanza (comp stanza)
(setf *last-stanza* stanza)
(let* ((stanza (dom:document-element stanza))
@@ -200,6 +361,7 @@
(cond
((equal tag-name "stream:error") (handle-stream-error comp stanza))
((equal tag-name "handshake") (handle-connection-complete comp))
+ ((equal tag-name "iq") (handle-iq-response comp stanza))
(t (emit :stanza comp stanza)))))
(defun make-component (server port shared-secret name)