*: move 750 LoC from 'stuff.lisp' into other sensibly-named files
This commit is contained in:
eta
parent
6c0e61f2a5
commit
0962c5d488
344
component.lisp
Normal file
344
component.lisp
Normal file
|
|
@ -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 <stream:stream> 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 "</stream:stream>"
|
||||
: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))
|
||||
126
db.lisp
Normal file
126
db.lisp
Normal file
|
|
@ -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))))
|
||||
23
namespaces.lisp
Normal file
23
namespaces.lisp
Normal file
|
|
@ -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")
|
||||
750
stuff.lisp
750
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 <stream:stream> 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 "</stream:stream>"
|
||||
: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 <query/>"))
|
||||
(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 <query/>"))
|
||||
(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 <slot/>"))
|
||||
(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 <error/> 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
|
||||
|
|
|
|||
14
utils.lisp
Normal file
14
utils.lisp
Normal file
|
|
@ -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)))
|
||||
|
|
@ -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")))
|
||||
|
|
|
|||
51
xep-0030.lisp
Normal file
51
xep-0030.lisp
Normal file
|
|
@ -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 <query/>"))
|
||||
(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 <query/>"))
|
||||
(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)))
|
||||
31
xep-0363.lisp
Normal file
31
xep-0363.lisp
Normal file
|
|
@ -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 <slot/>"))
|
||||
(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")))))))
|
||||
165
xmpp.lisp
Normal file
165
xmpp.lisp
Normal file
|
|
@ -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 <error/> 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)))
|
||||
Loading…
Reference in a new issue