83d172f899
- This commit contains initial support for uploading and sending images natively
-- i.e. a WhatsApp image upload, instead of sending through a bare link.
- All images supported by the OPTICL library are supported; this is because WA
needs us to generate a jpeg thumbnail for the image (which can probably be
made smaller)
- Importantly, this functionality is currently a trivial DoS vector: simply send
a large file (or an infinite file, like time.gif) and it ALL gets downloaded
and buffered into RAM...!
- At least this is limited to users who have actually registered with the
bridge.
- Failing to send the image in any way results in an XMPP error getting reported
back to the sender.
- Also, the initial registration QR code upload thing now happens in another
thread.
173 lines
6.9 KiB
Common Lisp
173 lines
6.9 KiB
Common Lisp
(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) (and (dom:element-p 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) (and (dom:element-p node) (equal (dom:get-attribute node "xmlns") xmlns))))
|
|
(find-if #'is-the-node nodes)))
|
|
|
|
(defun get-node-text (node)
|
|
"Gets the node's text."
|
|
(let ((child-nodes (dom:child-nodes node)))
|
|
(if (> (length child-nodes) 0)
|
|
(dom:node-value (elt child-nodes 0))
|
|
"")))
|
|
|
|
(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 (child-elements 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 (child-elements stanza)))
|
|
(error-children (child-elements 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)))
|