diff --git a/component.lisp b/component.lisp
new file mode 100644
index 0000000..ed506d4
--- /dev/null
+++ b/component.lisp
@@ -0,0 +1,344 @@
+(in-package :whatsxmpp)
+
+(defvar *xmpp-debug-io* (make-broadcast-stream))
+(defvar *xmpp-debug-out* (make-synonym-stream '*xmpp-debug-io*))
+
+(defclass xmpp-component (event-emitter)
+ ((socket
+ :initarg :socket
+ :accessor component-socket)
+ (socket-lock
+ :initform (bt:make-recursive-lock "component socket lock")
+ :accessor component-socket-lock)
+ (data-lock
+ :initform (bt:make-recursive-lock "component data lock")
+ :accessor component-data-lock)
+ (sink
+ :initarg :sink
+ :accessor component-sink)
+ (name
+ :initarg :name
+ :reader component-name)
+ (stream-id
+ :initform nil
+ :accessor component-stream-id)
+ (shared-secret
+ :initarg :shared-secret
+ :reader component-shared-secret)
+ (handlers
+ :initform (make-hash-table)
+ :accessor component-handlers)
+ (promises
+ :initform (make-hash-table :test 'equal)
+ :accessor component-promises)))
+
+(defmacro with-component-data-lock ((comp) &body body)
+ `(bt:with-recursive-lock-held ((component-data-lock ,comp))
+ ,@body))
+
+(defclass xmpp-source (cxml:broadcast-handler)
+ ((component
+ :initarg :component
+ :accessor source-component)
+ (depth
+ :initform 0
+ :accessor source-depth)))
+
+(defun make-xmpp-source (comp)
+ (let ((ret (cxml:make-broadcast-handler)))
+ (change-class ret 'xmpp-source
+ :component comp)
+ ret))
+
+(defmethod sax:start-document ((s xmpp-source))
+ (declare (ignore s))
+ (format *xmpp-debug-out* "~&XMPP --> [document started]~%"))
+
+(defmethod sax:start-element ((s xmpp-source) namespace-uri local-name qname attributes)
+ (with-accessors ((depth source-depth) (comp source-component) (handlers cxml:broadcast-handler-handlers)) s
+ (incf depth)
+ (when (and (eql depth 1) (equal qname "stream:stream"))
+ (flet ((local-name-is-id (attr)
+ (equal (sax:attribute-local-name attr) "id")))
+ (let ((stream-id-attr (find-if #'local-name-is-id attributes)))
+ (when (not stream-id-attr)
+ (error "Server didn't send a stream ID"))
+ (format *xmpp-debug-out* "~&XMPP --> [stream started, ID ~A]~%" (sax:attribute-value stream-id-attr))
+ (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))))
+ (when (eql depth 2)
+ (let ((dom-builder (cxml-dom:make-dom-builder)))
+ (format *xmpp-debug-out* "~&XMPP --> ")
+ (setf handlers (list (cxml:make-character-stream-sink *xmpp-debug-out*) dom-builder))
+ (sax:start-document dom-builder)))
+ (call-next-method s namespace-uri local-name qname attributes)))
+
+(defmethod sax:end-element :before ((s xmpp-source) namespace-uri local-name qname)
+ (when (equal qname "stream:stream")
+ (error "Server closed the stream")))
+
+(defmethod sax:end-element :after ((s xmpp-source) namespace-uri local-name qname)
+ (with-accessors ((depth source-depth) (comp source-component) (handlers cxml:broadcast-handler-handlers)) s
+ (decf depth)
+ (when (eql depth 1)
+ (let* ((debug-sink (first handlers))
+ (dom-builder (second handlers))
+ (stanza (sax:end-document dom-builder)))
+ (sax:end-document debug-sink)
+ (terpri *xmpp-debug-out*)
+ (setf handlers nil)
+ (emit :raw-stanza comp stanza)))))
+
+(defclass xmpp-sink (cxml:broadcast-handler)
+ ((sink-open
+ :initform t
+ :accessor sink-open)))
+
+(defmethod sax:start-document ((s xmpp-sink))
+ (declare (ignore s))
+ (format *xmpp-debug-out* "~&XMPP <-- "))
+
+(defmethod sax:end-element ((s xmpp-sink) namespace-uri local-name qname)
+ (if (and (sink-open s) (equal local-name "stream"))
+ ;; The element gets opened at the start of the connection
+ ;; and closing it represents ending the connection. We therefore don't
+ ;; want to close it...
+ ;; Instead, send some empty characters to get the sinks to write the last ">"
+ ;; bit of the opening tag.
+ (sax:characters s "")
+ (call-next-method s namespace-uri local-name qname))
+ (terpri *xmpp-debug-out*))
+
+(defun close-xmpp-component (comp)
+ (bt:with-recursive-lock-held ((component-socket-lock comp))
+ (setf (sink-open (component-sink comp)) nil)
+ (write-sequence (babel:string-to-octets ""
+ :encoding :utf-8)
+ (component-socket comp))
+ (force-output (component-socket comp))
+ (close (component-socket comp))))
+
+(defun make-xmpp-sink (socket)
+ (let ((ret (cxml:make-broadcast-handler
+ (cxml:make-character-stream-sink *xmpp-debug-out*)
+ (cxml:make-octet-stream-sink socket))))
+ (change-class ret 'xmpp-sink)
+ ret))
+
+(defmacro with-dom-xml-output (&body body)
+ `(cxml:with-xml-output (cxml-dom:make-dom-builder)
+ ,@body))
+
+(defun component-listen-thread (comp)
+ "Listening thread for an XMPP component: constantly reads from the socket and emits new stanzas."
+ (format *debug-io* "Starting component listening thread~%")
+ ;; ### Story time! ###
+ ;; So I spent an hour debugging why this wasn't working.
+ ;; And, long story short, if you just call CXML:PARSE with a stream
+ ;; it gets converted into an 'xstream' inside CXML, which has a :SPEED
+ ;; property. This :SPEED property controls how many bytes it tries to buffer
+ ;; before actually doing the parsing and the goddamn default is 8192 (!!).
+ ;; This obviously ain't gonna fly for our TCP socket, because the initial stream
+ ;; start element is less than 8192 bytes. So we make our own stupid xstream
+ ;; and specify the speed manually, and then it works.
+ ;;
+ ;; Wouldn't it be nice if people documented this sort of thing?
+ ;;
+ ;; ### Part II: The Fucking Stream Strikes Back ###
+ ;; ...and, after another hour of debugging, I found out you have to specify the `name'
+ ;; arg, otherwise it breaks -- but ONLY randomly and once you decide to deploy it
+ ;; in production, of course.
+ (let ((source (make-xmpp-source comp))
+ (fucking-stream (cxml:make-xstream (component-socket comp)
+ :speed 1 ; FFFFFFFFUUUUUUUU
+ :name (cxml::make-stream-name ; AAAARGH
+ :entity-name "main document"
+ :entity-kind :main
+ :uri nil)
+ :name "XMPP server stream"
+ :initial-speed 1)))
+ (cxml:parse fucking-stream source
+ :recode t)))
+
+(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-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-xml-output (comp)
+ (cxml:with-element "handshake"
+ (cxml:attribute "xmlns" +component-ns+)
+ (cxml:text (string-downcase (sha1-hex (concatenate 'string (component-stream-id comp) (component-shared-secret comp))))))))
+
+(defun register-component-iq-handler (comp handler-name func)
+ "Register FUNC to be called for the HANDLER-NAME IQ handler on COMP."
+ (with-component-data-lock (comp)
+ (setf (gethash handler-name (component-handlers comp)) func)))
+
+(defun call-component-iq-handler (comp handler &rest args)
+ "Calls the IQ handler identified by the symbol HANDLER on COMP, with the provided ARGS."
+ (destructuring-bind (&key id to from &allow-other-keys) args
+ (with-component-data-lock (comp)
+ (catcher
+ (attach
+ (let ((func (gethash handler (component-handlers comp))))
+ (unless func
+ (error 'stanza-error
+ :defined-condition "feature-not-implemented"
+ :text (format nil "No handler for ~A registered" handler)
+ :type "cancel"))
+ (let ((result (apply func comp args)))
+ result))
+ (lambda (result-forms)
+ (eval `(with-component-xml-output (,comp)
+ (cxml:with-element "iq"
+ (cxml:attribute "type" "result")
+ (cxml:attribute "id" ,id)
+ (cxml:attribute "from" ,to)
+ (cxml:attribute "to" ,from)
+ ,@result-forms)))))
+ (stanza-error (e)
+ (send-stanza-error comp
+ :stanza-type "iq"
+ :id id :to from :from to :e e))
+ (t (e)
+ (send-stanza-error comp
+ :stanza-type "iq"
+ :id id
+ :to from
+ :from to
+ :e (make-condition 'stanza-error
+ :defined-condition "internal-server-error"
+ :text (format nil "~A" e)
+ :type "cancel"))
+ (warn "IQ handler for ~A failed: ~A" handler e))))))
+
+(defun handle-iq-get (comp id from stanza)
+ "Handles an IQ-get STANZA for component COMP."
+ (let* ((first-child (elt (dom:child-nodes stanza) 0))
+ (tag-name (dom:tag-name first-child))
+ (to (dom:get-attribute stanza "to"))
+ (xmlns (dom:get-attribute first-child "xmlns"))
+ (handler-type
+ (cond
+ ((and (equal xmlns +disco-info-ns+) (equal tag-name "query"))
+ :disco-info)
+ ((and (equal xmlns +disco-items-ns+) (equal tag-name "query"))
+ :disco-items)
+ ((and (equal xmlns +vcard-temp-ns+) (equal tag-name "vCard"))
+ :vcard-temp-get)
+ (t
+ :generic-iq))))
+ (call-component-iq-handler comp handler-type
+ :to to
+ :id id
+ :from from
+ :stanza stanza)))
+
+(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")
+ (handle-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 handle-presence (comp stanza)
+ "Handles a presence STANZA for component COMP."
+ (let* ((type (dom:get-attribute stanza "type"))
+ (from (dom:get-attribute stanza "from"))
+ (to (dom:get-attribute stanza "to"))
+ (event-name
+ (cond
+ ((equal type "subscribe") :presence-subscribe)
+ ((equal type "probe") :presence-probe)
+ ((equal type "unavailable") :presence-unavailable)
+ (t :presence))))
+ (emit event-name comp :from from :to to :type type :stanza stanza)))
+
+(defun handle-message (comp stanza)
+ "Handles a message STANZA for component COMP."
+ (let* ((from (dom:get-attribute stanza "from"))
+ (to (dom:get-attribute stanza "to"))
+ (id (dom:get-attribute stanza "id"))
+ (children (dom:child-nodes stanza))
+ (body (get-node-named children "body"))
+ (marker (get-node-with-xmlns children +chat-markers-ns+))
+ (chat-state (get-node-with-xmlns children +chat-states-ns+)))
+ (cond
+ (body
+ (let* ((child-nodes (dom:child-nodes body))
+ (text (if (> (length child-nodes) 0)
+ (dom:node-value (elt child-nodes 0))
+ "")))
+ (emit :text-message comp :from from :to to :body text :id id :stanza stanza)))
+ (marker
+ (let ((marker-type (dom:tag-name marker))
+ (msgid (dom:get-attribute marker "id")))
+ (emit :message-marker comp :from from :to to :type marker-type :marker-id msgid :id id :stanza stanza)))
+ (chat-state
+ (let ((state-type (dom:tag-name chat-state)))
+ (emit :chat-state comp :from from :to to :type state-type :id id :stanza stanza)))
+ (t
+ (emit :message comp :from from :to to :id id :stanza stanza)))))
+
+(defun component-stanza (comp stanza)
+ "Handles a STANZA received by component COMP."
+ (let* ((stanza (dom:document-element stanza))
+ (tag-name (dom:tag-name stanza)))
+ (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))
+ ((equal tag-name "presence") (handle-presence comp stanza))
+ ((equal tag-name "message") (handle-message comp stanza))
+ (t (emit :stanza comp stanza)))))
+
+(defun make-component (server port shared-secret name)
+ "Make a new XMPP component, connecting to SERVER on PORT with SHARED-SECRET."
+ (let* ((socket (socket-stream
+ (socket-connect server port
+ :element-type '(unsigned-byte 8))))
+ (component (make-instance 'xmpp-component
+ :socket socket
+ :sink (make-xmpp-sink socket)
+ :name name
+ :shared-secret shared-secret)))
+ (bt:make-thread (lambda ()
+ (component-listen-thread component))
+ :name "XMPP component listen thread")
+ (on :stream-started component (lambda ()
+ (component-stream-started component)))
+ (on :raw-stanza component (lambda (stanza)
+ (component-stanza component stanza)))
+ (write-stream-header component)
+ component))
diff --git a/db.lisp b/db.lisp
new file mode 100644
index 0000000..fc5ea27
--- /dev/null
+++ b/db.lisp
@@ -0,0 +1,126 @@
+(in-package :whatsxmpp)
+
+(defun get-user-id (jid)
+ "Get the user ID of JID, or NIL if none exists."
+ (with-prepared-statement
+ (get-user "SELECT id FROM users WHERE jid = ?")
+ (let ((stripped (strip-resource jid)))
+ (bind-parameters get-user stripped)
+ (when (sqlite:step-statement get-user)
+ (first (column-values get-user))))))
+
+(defun get-user-contact-localparts (uid)
+ "Returns a list of all contact localparts for UID."
+ (with-prepared-statements
+ ((get-stmt "SELECT wa_jid FROM user_contacts WHERE user_id = ?"))
+ (bind-parameters get-stmt uid)
+ (loop
+ while (sqlite:step-statement get-stmt)
+ collect (sqlite:statement-column-value get-stmt 0))))
+
+(defun get-user-chat-id (uid localpart)
+ "Get the user chat ID of LOCALPART for UID, or NIL if none exists."
+ (with-prepared-statements
+ ((get-stmt "SELECT id FROM user_chats WHERE user_id = ? AND wa_jid = ?"))
+ (bind-parameters get-stmt uid localpart)
+ (when (sqlite:step-statement get-stmt)
+ (with-bound-columns (id) get-stmt
+ id))))
+
+(defun get-user-chat-subject (uid localpart)
+ "Get the user chat subject of LOCALPART for UID, or NIL if none exists."
+ (with-prepared-statements
+ ((get-stmt "SELECT subject FROM user_chats WHERE user_id = ? AND wa_jid = ?"))
+ (bind-parameters get-stmt uid localpart)
+ (when (sqlite:step-statement get-stmt)
+ (with-bound-columns (subject) get-stmt
+ subject))))
+
+(defun get-user-chat-resource (uid localpart)
+ "Get the user chat resource of LOCALPART for UID, or NIL if none exists."
+ (with-prepared-statements
+ ((get-stmt "SELECT user_resource FROM user_chats WHERE user_id = ? AND wa_jid = ?"))
+ (bind-parameters get-stmt uid localpart)
+ (when (sqlite:step-statement get-stmt)
+ (with-bound-columns (resource) get-stmt
+ (when (and resource (> (length resource) 0))
+ resource)))))
+
+(defun get-participant-resource (chat-id localpart)
+ "Get the participant resource for LOCALPART in CHAT-ID, or NIL if none exists."
+ (with-prepared-statements
+ ((get-stmt "SELECT resource FROM user_chat_members WHERE chat_id = ? AND wa_jid = ?"))
+ (bind-parameters get-stmt chat-id localpart)
+ (when (sqlite:step-statement get-stmt)
+ (with-bound-columns (resource) get-stmt
+ (when (and resource (> (length resource) 0))
+ resource)))))
+
+(defun get-user-chat-joined (uid localpart)
+ "Get the user chat resource of LOCALPART for UID, or NIL if none exists."
+ (with-prepared-statements
+ ((get-stmt "SELECT ucj.jid FROM user_chats AS uc, user_chat_joined AS ucj WHERE uc.user_id = ? AND uc.wa_jid = ? AND uc.id = ucj.chat_id"))
+ (bind-parameters get-stmt uid localpart)
+ (loop
+ while (sqlite:step-statement get-stmt)
+ append (column-values get-stmt))))
+
+(defun get-contact-name (uid localpart)
+ "Get a name for LOCALPART, a possible contact for the user with ID UID."
+ (with-prepared-statements
+ ((get-stmt "SELECT name, notify FROM user_contacts WHERE user_id = ? AND wa_jid = ?"))
+ (bind-parameters get-stmt uid localpart)
+ (when (sqlite:step-statement get-stmt)
+ (with-bound-columns (name notify) get-stmt
+ (or name notify (substitute #\+ #\u localpart))))))
+
+(defun get-contact-status (uid localpart)
+ "Get the contact status text for LOCALPART, a possible contact for the user with ID UID."
+ (declare (type integer uid) (type string localpart))
+ (with-prepared-statements
+ ((get-stmt "SELECT status FROM user_contacts WHERE user_id = ? AND wa_jid = ?"))
+ (bind-parameters get-stmt uid localpart)
+ (when (sqlite:step-statement get-stmt)
+ (with-bound-columns (status) get-stmt
+ status))))
+
+(defun insert-user-message (uid xmpp-id wa-id)
+ "Inserts a mapping between the message IDs XMPP-ID and WA-ID for the user UID."
+ (with-prepared-statements
+ ((insert-stmt "INSERT INTO user_messages (user_id, xmpp_id, wa_id) VALUES (?, ?, ?)"))
+ (bind-parameters insert-stmt uid xmpp-id wa-id)
+ (sqlite:step-statement insert-stmt)))
+
+(defun insert-user-chat (uid wa-id)
+ "Inserts a user chat with localpart WA-ID into the database for the user with UID."
+ (with-prepared-statements
+ ((insert-stmt "INSERT INTO user_chats (user_id, wa_jid) VALUES (?, ?)"))
+ (bind-parameters insert-stmt uid wa-id)
+ (sqlite:step-statement insert-stmt)))
+
+(defun lookup-wa-msgid (uid wa-msgid)
+ "Look up the XMPP ID for the WhatsApp message ID WA-MSGID, when received for the user UID."
+ (with-prepared-statements
+ ((get-stmt "SELECT xmpp_id FROM user_messages WHERE user_id = ? AND wa_id = ?"))
+ (bind-parameters get-stmt uid wa-msgid)
+ (when (sqlite:step-statement get-stmt)
+ (with-bound-columns (xid) get-stmt
+ xid))))
+
+(defun lookup-xmpp-msgid (uid xmpp-msgid)
+ "Look up the WhatsApp message ID for the XMPP message ID XMPP-MSGID, when received for the user UID."
+ (with-prepared-statements
+ ((get-stmt "SELECT wa_id FROM user_messages WHERE user_id = ? AND xmpp_id = ?"))
+ (bind-parameters get-stmt uid xmpp-msgid)
+ (when (sqlite:step-statement get-stmt)
+ (with-bound-columns (wid) get-stmt
+ wid))))
+
+(defun get-contact-localparts (uid)
+ "Get a list of contact localparts for the user with ID UID."
+ (with-prepared-statements
+ ((get-stmt "SELECT wa_jid FROM user_contacts WHERE user_id = ?"))
+ (bind-parameters get-stmt uid)
+ (loop
+ while (sqlite:step-statement get-stmt)
+ collect (with-bound-columns (localpart) get-stmt localpart))))
diff --git a/namespaces.lisp b/namespaces.lisp
new file mode 100644
index 0000000..9038b99
--- /dev/null
+++ b/namespaces.lisp
@@ -0,0 +1,23 @@
+(in-package :whatsxmpp)
+
+(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")
+(defparameter +muc-ns+ "http://jabber.org/protocol/muc")
+(defparameter +file-upload-ns+ "urn:xmpp:http:upload:0")
+(defparameter +oob-ns+ "jabber:x:oob")
+(defparameter +chat-markers-ns+ "urn:xmpp:chat-markers:0")
+(defparameter +delivery-delay-ns+ "urn:xmpp:delay")
+(defparameter +vcard-temp-ns+ "vcard-temp")
+(defparameter +vcard-avatar-ns+ "vcard-temp:x:update")
+(defparameter +nick-ns+ "http://jabber.org/protocol/nick")
+(defparameter +roster-exchange-ns+ "http://jabber.org/protocol/rosterx")
+(defparameter +delivery-receipts-ns+ "urn:xmpp:receipts")
+(defparameter +muc-invite-ns+ "jabber:x:conference")
+(defparameter +muc-stable-id-ns+ "http://jabber.org/protocol/muc#stable_id")
+(defparameter +muc-user-ns+ "http://jabber.org/protocol/muc#user")
+(defparameter +unique-stanzas-ns+ "urn:xmpp:sid:0")
+(defparameter +chat-states-ns+ "http://jabber.org/protocol/chatstates")
+(defparameter +hints-ns+ "urn:xmpp:hints")
diff --git a/stuff.lisp b/stuff.lisp
index 7e67204..13cda86 100644
--- a/stuff.lisp
+++ b/stuff.lisp
@@ -2,59 +2,6 @@
(defparameter +version+ "0.0.1")
-(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")
-(defparameter +muc-ns+ "http://jabber.org/protocol/muc")
-(defparameter +file-upload-ns+ "urn:xmpp:http:upload:0")
-(defparameter +oob-ns+ "jabber:x:oob")
-(defparameter +chat-markers-ns+ "urn:xmpp:chat-markers:0")
-(defparameter +delivery-delay-ns+ "urn:xmpp:delay")
-(defparameter +vcard-temp-ns+ "vcard-temp")
-(defparameter +vcard-avatar-ns+ "vcard-temp:x:update")
-(defparameter +nick-ns+ "http://jabber.org/protocol/nick")
-(defparameter +roster-exchange-ns+ "http://jabber.org/protocol/rosterx")
-(defparameter +delivery-receipts-ns+ "urn:xmpp:receipts")
-(defparameter +muc-invite-ns+ "jabber:x:conference")
-(defparameter +muc-stable-id-ns+ "http://jabber.org/protocol/muc#stable_id")
-(defparameter +muc-user-ns+ "http://jabber.org/protocol/muc#user")
-(defparameter +unique-stanzas-ns+ "urn:xmpp:sid:0")
-(defparameter +chat-states-ns+ "http://jabber.org/protocol/chatstates")
-(defparameter +hints-ns+ "urn:xmpp:hints")
-
-(defvar *xmpp-debug-io* (make-broadcast-stream))
-(defvar *xmpp-debug-out* (make-synonym-stream '*xmpp-debug-io*))
-
-(defclass xmpp-component (event-emitter)
- ((socket
- :initarg :socket
- :accessor component-socket)
- (socket-lock
- :initform (bt:make-recursive-lock "component socket lock")
- :accessor component-socket-lock)
- (data-lock
- :initform (bt:make-recursive-lock "component data lock")
- :accessor component-data-lock)
- (sink
- :initarg :sink
- :accessor component-sink)
- (name
- :initarg :name
- :reader component-name)
- (stream-id
- :initform nil
- :accessor component-stream-id)
- (shared-secret
- :initarg :shared-secret
- :reader component-shared-secret)
- (handlers
- :initform (make-hash-table)
- :accessor component-handlers)
- (promises
- :initform (make-hash-table :test 'equal)
- :accessor component-promises)))
(defclass whatsxmpp-component (xmpp-component)
((whatsapps
@@ -67,304 +14,6 @@
:initarg :upload-component-name
:accessor component-upload-component-name)))
-(defmacro with-component-data-lock ((comp) &body body)
- `(bt:with-recursive-lock-held ((component-data-lock ,comp))
- ,@body))
-
-(defclass xmpp-source (cxml:broadcast-handler)
- ((component
- :initarg :component
- :accessor source-component)
- (depth
- :initform 0
- :accessor source-depth)))
-
-(defun make-xmpp-source (comp)
- (let ((ret (cxml:make-broadcast-handler)))
- (change-class ret 'xmpp-source
- :component comp)
- ret))
-
-(defmethod sax:start-document ((s xmpp-source))
- (declare (ignore s))
- (format *xmpp-debug-out* "~&XMPP --> [document started]~%"))
-
-(defmethod sax:start-element ((s xmpp-source) namespace-uri local-name qname attributes)
- (with-accessors ((depth source-depth) (comp source-component) (handlers cxml:broadcast-handler-handlers)) s
- (incf depth)
- (when (and (eql depth 1) (equal qname "stream:stream"))
- (flet ((local-name-is-id (attr)
- (equal (sax:attribute-local-name attr) "id")))
- (let ((stream-id-attr (find-if #'local-name-is-id attributes)))
- (when (not stream-id-attr)
- (error "Server didn't send a stream ID"))
- (format *xmpp-debug-out* "~&XMPP --> [stream started, ID ~A]~%" (sax:attribute-value stream-id-attr))
- (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))))
- (when (eql depth 2)
- (let ((dom-builder (cxml-dom:make-dom-builder)))
- (format *xmpp-debug-out* "~&XMPP --> ")
- (setf handlers (list (cxml:make-character-stream-sink *xmpp-debug-out*) dom-builder))
- (sax:start-document dom-builder)))
- (call-next-method s namespace-uri local-name qname attributes)))
-
-(defmethod sax:end-element :before ((s xmpp-source) namespace-uri local-name qname)
- (when (equal qname "stream:stream")
- (error "Server closed the stream")))
-
-(defmethod sax:end-element :after ((s xmpp-source) namespace-uri local-name qname)
- (with-accessors ((depth source-depth) (comp source-component) (handlers cxml:broadcast-handler-handlers)) s
- (decf depth)
- (when (eql depth 1)
- (let* ((debug-sink (first handlers))
- (dom-builder (second handlers))
- (stanza (sax:end-document dom-builder)))
- (sax:end-document debug-sink)
- (terpri *xmpp-debug-out*)
- (setf handlers nil)
- (emit :raw-stanza comp stanza)))))
-
-(defclass xmpp-sink (cxml:broadcast-handler)
- ((sink-open
- :initform t
- :accessor sink-open)))
-
-(defmethod sax:start-document ((s xmpp-sink))
- (declare (ignore s))
- (format *xmpp-debug-out* "~&XMPP <-- "))
-
-(defmethod sax:end-element ((s xmpp-sink) namespace-uri local-name qname)
- (if (and (sink-open s) (equal local-name "stream"))
- ;; The element gets opened at the start of the connection
- ;; and closing it represents ending the connection. We therefore don't
- ;; want to close it...
- ;; Instead, send some empty characters to get the sinks to write the last ">"
- ;; bit of the opening tag.
- (sax:characters s "")
- (call-next-method s namespace-uri local-name qname))
- (terpri *xmpp-debug-out*))
-
-(defun close-xmpp-component (comp)
- (bt:with-recursive-lock-held ((component-socket-lock comp))
- (setf (sink-open (component-sink comp)) nil)
- (write-sequence (babel:string-to-octets ""
- :encoding :utf-8)
- (component-socket comp))
- (force-output (component-socket comp))
- (close (component-socket comp))))
-
-(defun make-xmpp-sink (socket)
- (let ((ret (cxml:make-broadcast-handler
- (cxml:make-character-stream-sink *xmpp-debug-out*)
- (cxml:make-octet-stream-sink socket))))
- (change-class ret 'xmpp-sink)
- ret))
-
-(defmacro with-dom-xml-output (&body body)
- `(cxml:with-xml-output (cxml-dom:make-dom-builder)
- ,@body))
-
-(defun component-listen-thread (comp)
- "Listening thread for an XMPP component: constantly reads from the socket and emits new stanzas."
- (format *debug-io* "Starting component listening thread~%")
- ;; ### Story time! ###
- ;; So I spent an hour debugging why this wasn't working.
- ;; And, long story short, if you just call CXML:PARSE with a stream
- ;; it gets converted into an 'xstream' inside CXML, which has a :SPEED
- ;; property. This :SPEED property controls how many bytes it tries to buffer
- ;; before actually doing the parsing and the goddamn default is 8192 (!!).
- ;; This obviously ain't gonna fly for our TCP socket, because the initial stream
- ;; start element is less than 8192 bytes. So we make our own stupid xstream
- ;; and specify the speed manually, and then it works.
- ;;
- ;; Wouldn't it be nice if people documented this sort of thing?
- ;;
- ;; ### Part II: The Fucking Stream Strikes Back ###
- ;; ...and, after another hour of debugging, I found out you have to specify the `name'
- ;; arg, otherwise it breaks -- but ONLY randomly and once you decide to deploy it
- ;; in production, of course.
- (let ((source (make-xmpp-source comp))
- (fucking-stream (cxml:make-xstream (component-socket comp)
- :speed 1 ; FFFFFFFFUUUUUUUU
- :name (cxml::make-stream-name ; AAAARGH
- :entity-name "main document"
- :entity-kind :main
- :uri nil)
- :name "XMPP server stream"
- :initial-speed 1)))
- (cxml:parse fucking-stream source
- :recode t)))
-
-(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-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 octets-to-lowercase-hex (buf)
- "Formats BUF, a vector of octets, as a lowercase hex string and returns it."
- (declare (type (vector (unsigned-byte 8)) buf))
- (format nil "~(~{~2,'0X~}~)" (coerce buf 'list)))
-
-(defun sha1-octets (buf)
- "Returns the SHA1 of BUF, a vector of octets, in lowercase hex."
- (octets-to-lowercase-hex (ironclad:digest-sequence :sha1 buf)))
-
-(defun sha1-hex (str)
- "Returns the SHA1 of STR, a string, in lowercase hex."
- (sha1-octets (babel:string-to-octets str)))
-
-(defun component-stream-started (comp)
- (with-component-xml-output (comp)
- (cxml:with-element "handshake"
- (cxml:attribute "xmlns" +component-ns+)
- (cxml:text (string-downcase (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 id) &body body)
- (alexandria:with-gensyms (uuid ret from-sym id-sym)
- `(with-component-xml-output (,comp)
- (let ((,from-sym (or ,from (component-name ,comp)))
- (,id-sym ,id))
- (multiple-value-bind (,uuid ,ret)
- (if ,id-sym
- (values ,id-sym ,id-sym)
- (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 id) &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
- :id ,id)
- ,@body))
-
-(defmacro with-message ((comp to &key (type "chat") from id) &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
- :id ,id)
- ,@body))
-
-(defmacro with-presence ((comp to &key type from id) &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
- :id ,id)
- ,@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-node-with-xmlns (nodes xmlns)
- "Finds the node with XML namespace XMLNS in NODES, returning NIL if none was found."
- (flet ((is-the-node (node) (equal (dom:get-attribute node "xmlns") xmlns)))
- (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 request-http-upload-slot (comp service-jid filename size mime-type)
- "Requests an XEP-0363 HTTP Upload slot from the service at SERVICE-JID, aiming to upload the file with FILENAME, SIZE (in bytes) and MIME-TYPE. Returns a promise that resolves with a list of the form ((PUT-URL . ((HEADER-NAME . HEADER-VALUE) ...)) GET-URL)."
- (declare (type xmpp-component comp) (type string service-jid filename mime-type) (type integer size))
- (attach
- (with-iq (comp service-jid)
- (cxml:with-element "request"
- (cxml:attribute "xmlns" +file-upload-ns+)
- (cxml:attribute "filename" filename)
- (cxml:attribute "size" (write-to-string size))
- (cxml:attribute "content-type" mime-type)))
- (lambda (results)
- (let ((slot-node (get-node-named results "slot")))
- (unless slot-node
- (error "Malformed XEP-0363 response: no "))
- (let* ((children (dom:child-nodes slot-node))
- (put-node (get-node-named children "put"))
- (get-node (get-node-named children "get"))
- (headers '()))
- (unless (and put-node get-node)
- (error "Malformed XEP-0363 response: PUT or GET nodes missing"))
- (loop
- for node across (dom:child-nodes put-node)
- do (let ((name (dom:tag-name node)))
- (when (equal name "header")
- (setf headers (cons
- (cons (dom:get-attribute node "name")
- (dom:node-value (elt (dom:child-nodes node) 0)))
- headers)))))
- `((,(dom:get-attribute put-node "url") . ,headers) ,(dom:get-attribute get-node "url")))))))
(defun send-text-message (comp to-jid text &optional from)
"Send a simple text message to TO-JID, containing TEXT."
@@ -372,247 +21,13 @@
(cxml:with-element "body"
(cxml:text text))))
-(defun handle-stream-error (comp stanza)
- (flet ((is-error-node (node)
- (equal (dom:namespace-uri node) +streams-ns+))
- (is-text-node (node)
- (equal (dom:tag-name node) "text")))
- (let* ((children (dom:child-nodes stanza))
- (error-node (find-if #'is-error-node children))
- (error-text-node (find-if #'is-text-node children))
- (error-name (dom:tag-name error-node))
- (error-text (when error-text-node
- (dom:node-value (elt (dom:child-nodes error-text-node) 0)))))
- (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
- :initform nil
- :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)
(format *debug-io* "Connection complete! \\o/")
(emit :connected comp))
-(defun send-stanza-error (comp &key id to from e stanza-type)
- "Send E (a STANZA-ERROR) as an error response to a stanza of type STANZA."
- (with-component-xml-output (comp)
- (cxml:with-element stanza-type
- (cxml:attribute "type" "error")
- (cxml:attribute "id" id)
- (cxml:attribute "from" from)
- (cxml:attribute "to" to)
- (cxml:with-element "error"
- (cxml:attribute "type" (stanza-error-type e))
- (cxml:with-element (stanza-error-condition e)
- (cxml:attribute "xmlns" +stanzas-ns+))
- (when (stanza-error-text e)
- (cxml:with-element "text"
- (cxml:text (stanza-error-text e))))))))
-(defmacro disco-identity (name type category)
- `(cxml:with-element "identity"
- ,@(when name
- `((cxml:attribute "name" ,name)))
- (cxml:attribute "type" ,type)
- (cxml:attribute "category" ,category)))
-(defmacro disco-feature (feature)
- `(cxml:with-element "feature"
- (cxml:attribute "var" ,feature)))
-
-(defun register-component-iq-handler (comp handler-name func)
- "Register FUNC to be called for the HANDLER-NAME IQ handler on COMP."
- (with-component-data-lock (comp)
- (setf (gethash handler-name (component-handlers comp)) func)))
-
-(defun call-component-iq-handler (comp handler &rest args)
- "Calls the IQ handler identified by the symbol HANDLER on COMP, with the provided ARGS."
- (destructuring-bind (&key id to from &allow-other-keys) args
- (with-component-data-lock (comp)
- (catcher
- (attach
- (let ((func (gethash handler (component-handlers comp))))
- (unless func
- (error 'stanza-error
- :defined-condition "feature-not-implemented"
- :text (format nil "No handler for ~A registered" handler)
- :type "cancel"))
- (let ((result (apply func comp args)))
- result))
- (lambda (result-forms)
- (eval `(with-component-xml-output (,comp)
- (cxml:with-element "iq"
- (cxml:attribute "type" "result")
- (cxml:attribute "id" ,id)
- (cxml:attribute "from" ,to)
- (cxml:attribute "to" ,from)
- ,@result-forms)))))
- (stanza-error (e)
- (send-stanza-error comp
- :stanza-type "iq"
- :id id :to from :from to :e e))
- (t (e)
- (send-stanza-error comp
- :stanza-type "iq"
- :id id
- :to from
- :from to
- :e (make-condition 'stanza-error
- :defined-condition "internal-server-error"
- :text (format nil "~A" e)
- :type "cancel"))
- (warn "IQ handler for ~A failed: ~A" handler e))))))
-
-(defun handle-iq-get (comp id from stanza)
- "Handles an IQ-get STANZA for component COMP."
- (let* ((first-child (elt (dom:child-nodes stanza) 0))
- (tag-name (dom:tag-name first-child))
- (to (dom:get-attribute stanza "to"))
- (xmlns (dom:get-attribute first-child "xmlns"))
- (handler-type
- (cond
- ((and (equal xmlns +disco-info-ns+) (equal tag-name "query"))
- :disco-info)
- ((and (equal xmlns +disco-items-ns+) (equal tag-name "query"))
- :disco-items)
- ((and (equal xmlns +vcard-temp-ns+) (equal tag-name "vCard"))
- :vcard-temp-get)
- (t
- :generic-iq))))
- (call-component-iq-handler comp handler-type
- :to to
- :id id
- :from from
- :stanza stanza)))
-
-(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")
- (handle-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 handle-presence (comp stanza)
- "Handles a presence STANZA for component COMP."
- (let* ((type (dom:get-attribute stanza "type"))
- (from (dom:get-attribute stanza "from"))
- (to (dom:get-attribute stanza "to"))
- (event-name
- (cond
- ((equal type "subscribe") :presence-subscribe)
- ((equal type "probe") :presence-probe)
- ((equal type "unavailable") :presence-unavailable)
- (t :presence))))
- (emit event-name comp :from from :to to :type type :stanza stanza)))
-
-(defun handle-message (comp stanza)
- "Handles a message STANZA for component COMP."
- (let* ((from (dom:get-attribute stanza "from"))
- (to (dom:get-attribute stanza "to"))
- (id (dom:get-attribute stanza "id"))
- (children (dom:child-nodes stanza))
- (body (get-node-named children "body"))
- (marker (get-node-with-xmlns children +chat-markers-ns+))
- (chat-state (get-node-with-xmlns children +chat-states-ns+)))
- (cond
- (body
- (let* ((child-nodes (dom:child-nodes body))
- (text (if (> (length child-nodes) 0)
- (dom:node-value (elt child-nodes 0))
- "")))
- (emit :text-message comp :from from :to to :body text :id id :stanza stanza)))
- (marker
- (let ((marker-type (dom:tag-name marker))
- (msgid (dom:get-attribute marker "id")))
- (emit :message-marker comp :from from :to to :type marker-type :marker-id msgid :id id :stanza stanza)))
- (chat-state
- (let ((state-type (dom:tag-name chat-state)))
- (emit :chat-state comp :from from :to to :type state-type :id id :stanza stanza)))
- (t
- (emit :message comp :from from :to to :id id :stanza stanza)))))
-
-(defun component-stanza (comp stanza)
- "Handles a STANZA received by component COMP."
- (let* ((stanza (dom:document-element stanza))
- (tag-name (dom:tag-name stanza)))
- (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))
- ((equal tag-name "presence") (handle-presence comp stanza))
- ((equal tag-name "message") (handle-message comp stanza))
- (t (emit :stanza comp stanza)))))
-
-(defun make-component (server port shared-secret name)
- "Make a new XMPP component, connecting to SERVER on PORT with SHARED-SECRET."
- (let* ((socket (socket-stream
- (socket-connect server port
- :element-type '(unsigned-byte 8))))
- (component (make-instance 'xmpp-component
- :socket socket
- :sink (make-xmpp-sink socket)
- :name name
- :shared-secret shared-secret)))
- (bt:make-thread (lambda ()
- (component-listen-thread component))
- :name "XMPP component listen thread")
- (on :stream-started component (lambda ()
- (component-stream-started component)))
- (on :raw-stanza component (lambda (stanza)
- (component-stanza component stanza)))
- (write-stream-header component)
- component))
(defun disco-info-handler (comp &key to from &allow-other-keys)
"Handles XEP-0030 disco#info requests."
@@ -654,36 +69,6 @@
`((cxml:with-element "query"
(cxml:attribute "xmlns" ,+disco-info-ns+)))))
-(defun parse-jid (jid)
- "Parse JID, returning the multiple values HOSTNAME, LOCALPART and RESOURCE."
- (declare (type string jid))
- (let ((at-pos (position #\@ jid))
- (slash-pos (position #\/ jid)))
- (cond
- ((and (not slash-pos) (not at-pos))
- (values jid nil nil))
- ((and slash-pos (not at-pos))
- (multiple-value-bind (hostname resource)
- (whatscl::split-at jid slash-pos)
- (values hostname nil resource)))
- ((and (not slash-pos) at-pos)
- (multiple-value-bind (localpart hostname)
- (whatscl::split-at jid at-pos)
- (values hostname localpart nil)))
- (t
- (multiple-value-bind (rest resource)
- (whatscl::split-at jid slash-pos)
- (multiple-value-bind (localpart hostname)
- (whatscl::split-at rest at-pos)
- (values hostname localpart resource)))))))
-
-(defun strip-resource (jid)
- "Strips a resource from JID, if there is one, returning the bare JID."
- (let ((slash-pos (position #\/ jid)))
- (if slash-pos
- (whatscl::split-at jid slash-pos)
- jid)))
-
(defun admin-jid (comp)
"Get the admin JID for COMP. You need the lock to be taken out for this one."
(concatenate 'string "admin@" (component-name comp) "/adminbot"))
@@ -835,6 +220,9 @@ MEDIA-TYPE is one of (:image :video :audio :document)."
(defun wa-jid-to-whatsxmpp-localpart (waj)
"Convert a whatscl JID object to a WhatsXMPP localpart."
+ (unless waj
+ (format *error-output* "WA-JID-TO-WHATSXMPP-LOCALPART called with NIL!")
+ (return-from wa-jid-to-whatsxmpp-localpart "unknown"))
(with-accessors ((localpart whatscl::jid-localpart) (hostname whatscl::jid-hostname)) waj
(cond
((or (equal hostname "s.whatsapp.net") (equal hostname "c.us"))
@@ -1067,80 +455,6 @@ WhatsXMPP represents users as u440123456789 and groups as g1234-5678."
(format nil "Warning: Failed to process a media message sent to you by ~A:~% ~A"
from e)))))))))))))))
-(defun get-user-id (jid)
- "Get the user ID of JID, or NIL if none exists."
- (with-prepared-statement
- (get-user "SELECT id FROM users WHERE jid = ?")
- (let ((stripped (strip-resource jid)))
- (bind-parameters get-user stripped)
- (when (sqlite:step-statement get-user)
- (first (column-values get-user))))))
-
-(defun get-user-contact-localparts (uid)
- "Returns a list of all contact localparts for UID."
- (with-prepared-statements
- ((get-stmt "SELECT wa_jid FROM user_contacts WHERE user_id = ?"))
- (bind-parameters get-stmt uid)
- (loop
- while (sqlite:step-statement get-stmt)
- collect (sqlite:statement-column-value get-stmt 0))))
-
-(defun get-user-chat-id (uid localpart)
- "Get the user chat ID of LOCALPART for UID, or NIL if none exists."
- (with-prepared-statements
- ((get-stmt "SELECT id FROM user_chats WHERE user_id = ? AND wa_jid = ?"))
- (bind-parameters get-stmt uid localpart)
- (when (sqlite:step-statement get-stmt)
- (with-bound-columns (id) get-stmt
- id))))
-
-(defun get-user-chat-subject (uid localpart)
- "Get the user chat subject of LOCALPART for UID, or NIL if none exists."
- (with-prepared-statements
- ((get-stmt "SELECT subject FROM user_chats WHERE user_id = ? AND wa_jid = ?"))
- (bind-parameters get-stmt uid localpart)
- (when (sqlite:step-statement get-stmt)
- (with-bound-columns (subject) get-stmt
- subject))))
-
-(defun get-user-chat-resource (uid localpart)
- "Get the user chat resource of LOCALPART for UID, or NIL if none exists."
- (with-prepared-statements
- ((get-stmt "SELECT user_resource FROM user_chats WHERE user_id = ? AND wa_jid = ?"))
- (bind-parameters get-stmt uid localpart)
- (when (sqlite:step-statement get-stmt)
- (with-bound-columns (resource) get-stmt
- (when (and resource (> (length resource) 0))
- resource)))))
-
-(defun get-participant-resource (chat-id localpart)
- "Get the participant resource for LOCALPART in CHAT-ID, or NIL if none exists."
- (with-prepared-statements
- ((get-stmt "SELECT resource FROM user_chat_members WHERE chat_id = ? AND wa_jid = ?"))
- (bind-parameters get-stmt chat-id localpart)
- (when (sqlite:step-statement get-stmt)
- (with-bound-columns (resource) get-stmt
- (when (and resource (> (length resource) 0))
- resource)))))
-
-(defun get-user-chat-joined (uid localpart)
- "Get the user chat resource of LOCALPART for UID, or NIL if none exists."
- (with-prepared-statements
- ((get-stmt "SELECT ucj.jid FROM user_chats AS uc, user_chat_joined AS ucj WHERE uc.user_id = ? AND uc.wa_jid = ? AND uc.id = ucj.chat_id"))
- (bind-parameters get-stmt uid localpart)
- (loop
- while (sqlite:step-statement get-stmt)
- append (column-values get-stmt))))
-
-(defun get-contact-name (uid localpart)
- "Get a name for LOCALPART, a possible contact for the user with ID UID."
- (with-prepared-statements
- ((get-stmt "SELECT name, notify FROM user_contacts WHERE user_id = ? AND wa_jid = ?"))
- (bind-parameters get-stmt uid localpart)
- (when (sqlite:step-statement get-stmt)
- (with-bound-columns (name notify) get-stmt
- (or name notify (substitute #\+ #\u localpart))))))
-
(defun get-avatar-data (avatar-url)
"Fetches AVATAR-URL, using the database as a cache. Returns the SHA1 hash (lowercase) of the avatar data as first argument, and the actual octets as second."
(with-prepared-statements
@@ -1175,16 +489,6 @@ Returns three values: avatar data (as two values), and a generalized boolean spe
`(nil nil))
(cons (> (length avatar-url) 0) nil)))))))
-(defun get-contact-status (uid localpart)
- "Get the contact status text for LOCALPART, a possible contact for the user with ID UID."
- (declare (type integer uid) (type string localpart))
- (with-prepared-statements
- ((get-stmt "SELECT status FROM user_contacts WHERE user_id = ? AND wa_jid = ?"))
- (bind-parameters get-stmt uid localpart)
- (when (sqlite:step-statement get-stmt)
- (with-bound-columns (status) get-stmt
- status))))
-
(defun wa-request-avatar (comp conn jid wa-jid localpart)
(format *debug-io* "~&requesting avatar for ~A from ~A~%" localpart jid)
(whatscl::get-profile-picture conn wa-jid
@@ -1252,47 +556,6 @@ Returns three values: avatar data (as two values), and a generalized boolean spe
(bind-parameters update-stmt "asked" ctid)
(sqlite:step-statement update-stmt)))))))
-(defun insert-user-message (uid xmpp-id wa-id)
- "Inserts a mapping between the message IDs XMPP-ID and WA-ID for the user UID."
- (with-prepared-statements
- ((insert-stmt "INSERT INTO user_messages (user_id, xmpp_id, wa_id) VALUES (?, ?, ?)"))
- (bind-parameters insert-stmt uid xmpp-id wa-id)
- (sqlite:step-statement insert-stmt)))
-
-(defun insert-user-chat (uid wa-id)
- "Inserts a user chat with localpart WA-ID into the database for the user with UID."
- (with-prepared-statements
- ((insert-stmt "INSERT INTO user_chats (user_id, wa_jid) VALUES (?, ?)"))
- (bind-parameters insert-stmt uid wa-id)
- (sqlite:step-statement insert-stmt)))
-
-(defun lookup-wa-msgid (uid wa-msgid)
- "Look up the XMPP ID for the WhatsApp message ID WA-MSGID, when received for the user UID."
- (with-prepared-statements
- ((get-stmt "SELECT xmpp_id FROM user_messages WHERE user_id = ? AND wa_id = ?"))
- (bind-parameters get-stmt uid wa-msgid)
- (when (sqlite:step-statement get-stmt)
- (with-bound-columns (xid) get-stmt
- xid))))
-
-(defun lookup-xmpp-msgid (uid xmpp-msgid)
- "Look up the WhatsApp message ID for the XMPP message ID XMPP-MSGID, when received for the user UID."
- (with-prepared-statements
- ((get-stmt "SELECT wa_id FROM user_messages WHERE user_id = ? AND xmpp_id = ?"))
- (bind-parameters get-stmt uid xmpp-msgid)
- (when (sqlite:step-statement get-stmt)
- (with-bound-columns (wid) get-stmt
- wid))))
-
-(defun get-contact-localparts (uid)
- "Get a list of contact localparts for the user with ID UID."
- (with-prepared-statements
- ((get-stmt "SELECT wa_jid FROM user_contacts WHERE user_id = ?"))
- (bind-parameters get-stmt uid)
- (loop
- while (sqlite:step-statement get-stmt)
- collect (with-bound-columns (localpart) get-stmt localpart))))
-
(defun add-wa-contact (comp conn jid contact)
"Adds the WHATSCL:CONTACT to the list of JID's contacts, or updates it if it already exists. Returns the contact's localpart."
(with-accessors ((ct-jid whatscl::contact-jid)
@@ -2117,6 +1380,13 @@ Returns three values: avatar data (as two values), and a generalized boolean spe
(format *error-output* "[!] Fatal error, bridge aborting!~%")
(trivial-backtrace:print-backtrace err
:output *error-output*)
+ (loop
+ for thr in (bt:all-threads)
+ do (progn
+ (format *error-output* "[!] State of thread ~A:~%" thr)
+ (sb-thread:interrupt-thread thr (lambda ()
+ (sb-debug:print-backtrace
+ :stream *error-output*)))))
(sb-ext:exit :code 1 :abort t))
#+sbcl
diff --git a/utils.lisp b/utils.lisp
new file mode 100644
index 0000000..ff37b7a
--- /dev/null
+++ b/utils.lisp
@@ -0,0 +1,14 @@
+(in-package :whatsxmpp)
+
+(defun octets-to-lowercase-hex (buf)
+ "Formats BUF, a vector of octets, as a lowercase hex string and returns it."
+ (declare (type (vector (unsigned-byte 8)) buf))
+ (format nil "~(~{~2,'0X~}~)" (coerce buf 'list)))
+
+(defun sha1-octets (buf)
+ "Returns the SHA1 of BUF, a vector of octets, in lowercase hex."
+ (octets-to-lowercase-hex (ironclad:digest-sequence :sha1 buf)))
+
+(defun sha1-hex (str)
+ "Returns the SHA1 of STR, a string, in lowercase hex."
+ (sha1-octets (babel:string-to-octets str)))
diff --git a/whatsxmpp.asd b/whatsxmpp.asd
index db9fb79..d07e209 100644
--- a/whatsxmpp.asd
+++ b/whatsxmpp.asd
@@ -6,5 +6,12 @@
:entry-point "whatsxmpp::main"
:components
((:file "packages")
+ (:file "utils")
+ (:file "namespaces")
+ (:file "component")
+ (:file "xmpp")
+ (:file "xep-0030")
+ (:file "xep-0363")
(:file "sqlite")
+ (:file "db")
(:file "stuff")))
diff --git a/xep-0030.lisp b/xep-0030.lisp
new file mode 100644
index 0000000..ea99a6f
--- /dev/null
+++ b/xep-0030.lisp
@@ -0,0 +1,51 @@
+(in-package :whatsxmpp)
+
+
+(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))))
+
+(defmacro disco-identity (name type category)
+ `(cxml:with-element "identity"
+ ,@(when name
+ `((cxml:attribute "name" ,name)))
+ (cxml:attribute "type" ,type)
+ (cxml:attribute "category" ,category)))
+
+(defmacro disco-feature (feature)
+ `(cxml:with-element "feature"
+ (cxml:attribute "var" ,feature)))
diff --git a/xep-0363.lisp b/xep-0363.lisp
new file mode 100644
index 0000000..ff1004d
--- /dev/null
+++ b/xep-0363.lisp
@@ -0,0 +1,31 @@
+(in-package :whatsxmpp)
+
+(defun request-http-upload-slot (comp service-jid filename size mime-type)
+ "Requests an XEP-0363 HTTP Upload slot from the service at SERVICE-JID, aiming to upload the file with FILENAME, SIZE (in bytes) and MIME-TYPE. Returns a promise that resolves with a list of the form ((PUT-URL . ((HEADER-NAME . HEADER-VALUE) ...)) GET-URL)."
+ (declare (type xmpp-component comp) (type string service-jid filename mime-type) (type integer size))
+ (attach
+ (with-iq (comp service-jid)
+ (cxml:with-element "request"
+ (cxml:attribute "xmlns" +file-upload-ns+)
+ (cxml:attribute "filename" filename)
+ (cxml:attribute "size" (write-to-string size))
+ (cxml:attribute "content-type" mime-type)))
+ (lambda (results)
+ (let ((slot-node (get-node-named results "slot")))
+ (unless slot-node
+ (error "Malformed XEP-0363 response: no "))
+ (let* ((children (dom:child-nodes slot-node))
+ (put-node (get-node-named children "put"))
+ (get-node (get-node-named children "get"))
+ (headers '()))
+ (unless (and put-node get-node)
+ (error "Malformed XEP-0363 response: PUT or GET nodes missing"))
+ (loop
+ for node across (dom:child-nodes put-node)
+ do (let ((name (dom:tag-name node)))
+ (when (equal name "header")
+ (setf headers (cons
+ (cons (dom:get-attribute node "name")
+ (dom:node-value (elt (dom:child-nodes node) 0)))
+ headers)))))
+ `((,(dom:get-attribute put-node "url") . ,headers) ,(dom:get-attribute get-node "url")))))))
diff --git a/xmpp.lisp b/xmpp.lisp
new file mode 100644
index 0000000..21cfd9b
--- /dev/null
+++ b/xmpp.lisp
@@ -0,0 +1,165 @@
+(in-package :whatsxmpp)
+
+(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 id) &body body)
+ (alexandria:with-gensyms (uuid ret from-sym id-sym)
+ `(with-component-xml-output (,comp)
+ (let ((,from-sym (or ,from (component-name ,comp)))
+ (,id-sym ,id))
+ (multiple-value-bind (,uuid ,ret)
+ (if ,id-sym
+ (values ,id-sym ,id-sym)
+ (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 id) &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
+ :id ,id)
+ ,@body))
+
+(defmacro with-message ((comp to &key (type "chat") from id) &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
+ :id ,id)
+ ,@body))
+
+(defmacro with-presence ((comp to &key type from id) &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
+ :id ,id)
+ ,@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-node-with-xmlns (nodes xmlns)
+ "Finds the node with XML namespace XMLNS in NODES, returning NIL if none was found."
+ (flet ((is-the-node (node) (equal (dom:get-attribute node "xmlns") xmlns)))
+ (find-if #'is-the-node nodes)))
+
+(defun handle-stream-error (comp stanza)
+ (flet ((is-error-node (node)
+ (equal (dom:namespace-uri node) +streams-ns+))
+ (is-text-node (node)
+ (equal (dom:tag-name node) "text")))
+ (let* ((children (dom:child-nodes stanza))
+ (error-node (find-if #'is-error-node children))
+ (error-text-node (find-if #'is-text-node children))
+ (error-name (dom:tag-name error-node))
+ (error-text (when error-text-node
+ (dom:node-value (elt (dom:child-nodes error-text-node) 0)))))
+ (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
+ :initform nil
+ :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 send-stanza-error (comp &key id to from e stanza-type)
+ "Send E (a STANZA-ERROR) as an error response to a stanza of type STANZA."
+ (with-component-xml-output (comp)
+ (cxml:with-element stanza-type
+ (cxml:attribute "type" "error")
+ (cxml:attribute "id" id)
+ (cxml:attribute "from" from)
+ (cxml:attribute "to" to)
+ (cxml:with-element "error"
+ (cxml:attribute "type" (stanza-error-type e))
+ (cxml:with-element (stanza-error-condition e)
+ (cxml:attribute "xmlns" +stanzas-ns+))
+ (when (stanza-error-text e)
+ (cxml:with-element "text"
+ (cxml:text (stanza-error-text e))))))))
+
+(defun parse-jid (jid)
+ "Parse JID, returning the multiple values HOSTNAME, LOCALPART and RESOURCE."
+ (declare (type string jid))
+ (let ((at-pos (position #\@ jid))
+ (slash-pos (position #\/ jid)))
+ (cond
+ ((and (not slash-pos) (not at-pos))
+ (values jid nil nil))
+ ((and slash-pos (not at-pos))
+ (multiple-value-bind (hostname resource)
+ (whatscl::split-at jid slash-pos)
+ (values hostname nil resource)))
+ ((and (not slash-pos) at-pos)
+ (multiple-value-bind (localpart hostname)
+ (whatscl::split-at jid at-pos)
+ (values hostname localpart nil)))
+ (t
+ (multiple-value-bind (rest resource)
+ (whatscl::split-at jid slash-pos)
+ (multiple-value-bind (localpart hostname)
+ (whatscl::split-at rest at-pos)
+ (values hostname localpart resource)))))))
+
+(defun strip-resource (jid)
+ "Strips a resource from JID, if there is one, returning the bare JID."
+ (let ((slash-pos (position #\/ jid)))
+ (if slash-pos
+ (whatscl::split-at jid slash-pos)
+ jid)))