A WhatsApp (Web) transport for XMPP.
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

173 lines

  1. (in-package :whatsxmpp)
  2. (defun make-message-uuid (comp)
  3. (with-accessors ((promises component-promises)) comp
  4. (let ((uuid (string-downcase (write-to-string (uuid:make-v4-uuid))))
  5. (promise (make-promise)))
  6. (setf (gethash uuid promises) promise)
  7. (values uuid promise))))
  8. (defmacro with-stanza ((comp stanza-name &key type from to id) &body body)
  9. (alexandria:with-gensyms (uuid ret from-sym id-sym)
  10. `(with-component-xml-output (,comp)
  11. (let ((,from-sym (or ,from (component-name ,comp)))
  12. (,id-sym ,id))
  13. (multiple-value-bind (,uuid ,ret)
  14. (if ,id-sym
  15. (values ,id-sym ,id-sym)
  16. (make-message-uuid ,comp))
  17. (cxml:with-element ,stanza-name
  18. (cxml:attribute "from" ,from-sym)
  19. (cxml:attribute "id" ,uuid)
  20. ,(when to
  21. `(cxml:attribute "to" ,to))
  22. ,(when type
  23. `(cxml:attribute "type" ,type))
  24. ,@body)
  25. ,ret)))))
  26. (defmacro with-iq ((comp to &key (type "get") from id) &body body)
  27. "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."
  28. `(with-stanza (,comp "iq"
  29. :type ,type
  30. :to ,to
  31. :from ,from
  32. :id ,id)
  33. ,@body))
  34. (defmacro with-message ((comp to &key (type "chat") from id) &body body)
  35. "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."
  36. `(with-stanza (,comp "message"
  37. :type ,type
  38. :to ,to
  39. :from ,from
  40. :id ,id)
  41. ,@body))
  42. (defmacro with-presence ((comp to &key type from id) &body body)
  43. "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."
  44. `(with-stanza (,comp "presence"
  45. :type ,type
  46. :to ,to
  47. :from ,from
  48. :id ,id)
  49. ,@body))
  50. (defun get-node-named (nodes name)
  51. "Finds the node with tag name NAME in NODES, returning NIL if none was found."
  52. (flet ((is-the-node (node) (and (dom:element-p node) (equal (dom:tag-name node) name))))
  53. (find-if #'is-the-node nodes)))
  54. (defun get-node-with-xmlns (nodes xmlns)
  55. "Finds the node with XML namespace XMLNS in NODES, returning NIL if none was found."
  56. (flet ((is-the-node (node) (and (dom:element-p node) (equal (dom:get-attribute node "xmlns") xmlns))))
  57. (find-if #'is-the-node nodes)))
  58. (defun get-node-text (node)
  59. "Gets the node's text."
  60. (let ((child-nodes (dom:child-nodes node)))
  61. (if (> (length child-nodes) 0)
  62. (dom:node-value (elt child-nodes 0))
  63. "")))
  64. (defun handle-stream-error (comp stanza)
  65. (flet ((is-error-node (node)
  66. (equal (dom:namespace-uri node) +streams-ns+))
  67. (is-text-node (node)
  68. (equal (dom:tag-name node) "text")))
  69. (let* ((children (child-elements stanza))
  70. (error-node (find-if #'is-error-node children))
  71. (error-text-node (find-if #'is-text-node children))
  72. (error-name (dom:tag-name error-node))
  73. (error-text (when error-text-node
  74. (dom:node-value (elt (dom:child-nodes error-text-node) 0)))))
  75. (warn "Stream error of type ~A encountered: ~A" error-name error-text)
  76. (emit :stream-error comp error-name error-text stanza))))
  77. (define-condition stanza-error (error)
  78. ((defined-condition
  79. :initarg :defined-condition
  80. :accessor stanza-error-condition)
  81. (type
  82. :initarg :type
  83. :accessor stanza-error-type)
  84. (text
  85. :initarg :text
  86. :initform nil
  87. :accessor stanza-error-text)
  88. (raw
  89. :initarg :raw
  90. :initform nil
  91. :accessor stanza-error-raw))
  92. (:report (lambda (err stream)
  93. (with-slots (defined-condition type text) err
  94. (format stream "~A (type ~A): ~A" defined-condition type text)))))
  95. (defun extract-stanza-error (stanza)
  96. "Extracts a STANZA-ERROR from the given STANZA, which must contain an <error/> element conforming to RFC 6120 § 8.3."
  97. (flet ((is-error-condition-node (node)
  98. (equal (dom:namespace-uri node) +stanzas-ns+))
  99. (is-error-node (node)
  100. (equal (dom:tag-name node) "error"))
  101. (is-text-node (node)
  102. (and (equal (dom:namespace-uri node) +stanzas-ns+) (equal (dom:tag-name node) "text"))))
  103. (let* ((error-node (find-if #'is-error-node (child-elements stanza)))
  104. (error-children (child-elements error-node))
  105. (type (dom:get-attribute error-node "type"))
  106. (condition-node (find-if #'is-error-condition-node error-children))
  107. (condition-name (dom:tag-name condition-node))
  108. (text-node (find-if #'is-text-node error-children))
  109. (text (when text-node
  110. (dom:node-value (elt (dom:child-nodes text-node) 0)))))
  111. (make-condition 'stanza-error
  112. :raw error-node
  113. :defined-condition condition-name
  114. :type type
  115. :text text))))
  116. (defun send-stanza-error (comp &key id to from e stanza-type)
  117. "Send E (a STANZA-ERROR) as an error response to a stanza of type STANZA."
  118. (with-component-xml-output (comp)
  119. (cxml:with-element stanza-type
  120. (cxml:attribute "type" "error")
  121. (cxml:attribute "id" id)
  122. (cxml:attribute "from" from)
  123. (cxml:attribute "to" to)
  124. (cxml:with-element "error"
  125. (cxml:attribute "type" (stanza-error-type e))
  126. (cxml:with-element (stanza-error-condition e)
  127. (cxml:attribute "xmlns" +stanzas-ns+))
  128. (when (stanza-error-text e)
  129. (cxml:with-element "text"
  130. (cxml:text (stanza-error-text e))))))))
  131. (defun parse-jid (jid)
  132. "Parse JID, returning the multiple values HOSTNAME, LOCALPART and RESOURCE."
  133. (declare (type string jid))
  134. (let ((at-pos (position #\@ jid))
  135. (slash-pos (position #\/ jid)))
  136. (cond
  137. ((and (not slash-pos) (not at-pos))
  138. (values jid nil nil))
  139. ((and slash-pos (not at-pos))
  140. (multiple-value-bind (hostname resource)
  141. (whatscl::split-at jid slash-pos)
  142. (values hostname nil resource)))
  143. ((and (not slash-pos) at-pos)
  144. (multiple-value-bind (localpart hostname)
  145. (whatscl::split-at jid at-pos)
  146. (values hostname localpart nil)))
  147. (t
  148. (multiple-value-bind (rest resource)
  149. (whatscl::split-at jid slash-pos)
  150. (multiple-value-bind (localpart hostname)
  151. (whatscl::split-at rest at-pos)
  152. (values hostname localpart resource)))))))
  153. (defun strip-resource (jid)
  154. "Strips a resource from JID, if there is one, returning the bare JID."
  155. (let ((slash-pos (position #\/ jid)))
  156. (if slash-pos
  157. (whatscl::split-at jid slash-pos)
  158. jid)))