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.

355 lines
15KB

  1. (in-package :whatsxmpp)
  2. (defvar *xmpp-debug-io* (make-broadcast-stream))
  3. (defvar *xmpp-debug-out* (make-synonym-stream '*xmpp-debug-io*))
  4. (defclass xmpp-component (event-emitter)
  5. ((socket
  6. :initarg :socket
  7. :accessor component-socket)
  8. (socket-lock
  9. :initform (bt:make-recursive-lock "component socket lock")
  10. :accessor component-socket-lock)
  11. (data-lock
  12. :initform (bt:make-recursive-lock "component data lock")
  13. :accessor component-data-lock)
  14. (sink
  15. :initarg :sink
  16. :accessor component-sink)
  17. (name
  18. :initarg :name
  19. :reader component-name)
  20. (stream-id
  21. :initform nil
  22. :accessor component-stream-id)
  23. (shared-secret
  24. :initarg :shared-secret
  25. :reader component-shared-secret)
  26. (handlers
  27. :initform (make-hash-table)
  28. :accessor component-handlers)
  29. (promises
  30. :initform (make-hash-table :test 'equal)
  31. :accessor component-promises)))
  32. (defmacro with-component-data-lock ((comp) &body body)
  33. `(bt:with-recursive-lock-held ((component-data-lock ,comp))
  34. ,@body))
  35. (defclass xmpp-source (cxml:broadcast-handler)
  36. ((component
  37. :initarg :component
  38. :accessor source-component)
  39. (depth
  40. :initform 0
  41. :accessor source-depth)))
  42. (defun make-xmpp-source (comp)
  43. (let ((ret (cxml:make-broadcast-handler)))
  44. (change-class ret 'xmpp-source
  45. :component comp)
  46. ret))
  47. (defmethod sax:start-document ((s xmpp-source))
  48. (declare (ignore s))
  49. (format *xmpp-debug-out* "~&XMPP --> [document started]~%"))
  50. (defmethod sax:start-element ((s xmpp-source) namespace-uri local-name qname attributes)
  51. (with-accessors ((depth source-depth) (comp source-component) (handlers cxml:broadcast-handler-handlers)) s
  52. (incf depth)
  53. (when (and (eql depth 1) (equal qname "stream:stream"))
  54. (flet ((local-name-is-id (attr)
  55. (equal (sax:attribute-local-name attr) "id")))
  56. (let ((stream-id-attr (find-if #'local-name-is-id attributes)))
  57. (when (not stream-id-attr)
  58. (error "Server didn't send a stream ID"))
  59. (format *xmpp-debug-out* "~&XMPP --> [stream started, ID ~A]~%" (sax:attribute-value stream-id-attr))
  60. (with-component-data-lock (comp)
  61. (setf (component-stream-id comp) (sax:attribute-value stream-id-attr))
  62. (emit :stream-started comp))
  63. (return-from sax:start-element))))
  64. (when (eql depth 2)
  65. (let ((dom-builder (cxml-dom:make-dom-builder)))
  66. (format *xmpp-debug-out* "~&XMPP --> ")
  67. (setf handlers (list (cxml:make-character-stream-sink *xmpp-debug-out*) dom-builder))
  68. (sax:start-document dom-builder)))
  69. (call-next-method s namespace-uri local-name qname attributes)))
  70. (defmethod sax:end-element :before ((s xmpp-source) namespace-uri local-name qname)
  71. (when (equal qname "stream:stream")
  72. (error "Server closed the stream")))
  73. (defmethod sax:end-element :after ((s xmpp-source) namespace-uri local-name qname)
  74. (with-accessors ((depth source-depth) (comp source-component) (handlers cxml:broadcast-handler-handlers)) s
  75. (decf depth)
  76. (when (eql depth 1)
  77. (let* ((debug-sink (first handlers))
  78. (dom-builder (second handlers))
  79. (stanza (sax:end-document dom-builder)))
  80. (sax:end-document debug-sink)
  81. (terpri *xmpp-debug-out*)
  82. (setf handlers nil)
  83. (emit :raw-stanza comp stanza)))))
  84. (defclass xmpp-sink (cxml:broadcast-handler)
  85. ((sink-open
  86. :initform t
  87. :accessor sink-open)))
  88. (defmethod sax:start-document ((s xmpp-sink))
  89. (declare (ignore s))
  90. (format *xmpp-debug-out* "~&XMPP <-- "))
  91. (defmethod sax:end-element ((s xmpp-sink) namespace-uri local-name qname)
  92. (if (and (sink-open s) (equal local-name "stream"))
  93. ;; The <stream:stream> element gets opened at the start of the connection
  94. ;; and closing it represents ending the connection. We therefore don't
  95. ;; want to close it...
  96. ;; Instead, send some empty characters to get the sinks to write the last ">"
  97. ;; bit of the opening tag.
  98. (sax:characters s "")
  99. (call-next-method s namespace-uri local-name qname))
  100. (terpri *xmpp-debug-out*))
  101. (defun close-xmpp-component (comp)
  102. (bt:with-recursive-lock-held ((component-socket-lock comp))
  103. (setf (sink-open (component-sink comp)) nil)
  104. (write-sequence (babel:string-to-octets "</stream:stream>"
  105. :encoding :utf-8)
  106. (component-socket comp))
  107. (force-output (component-socket comp))
  108. (close (component-socket comp))))
  109. (defun make-xmpp-sink (socket)
  110. (let ((ret (cxml:make-broadcast-handler
  111. (cxml:make-character-stream-sink *xmpp-debug-out*)
  112. (cxml:make-octet-stream-sink socket))))
  113. (change-class ret 'xmpp-sink)
  114. ret))
  115. (defmacro with-dom-xml-output (&body body)
  116. `(cxml:with-xml-output (cxml-dom:make-dom-builder)
  117. ,@body))
  118. (defun component-listen-thread (comp)
  119. "Listening thread for an XMPP component: constantly reads from the socket and emits new stanzas."
  120. (format *debug-io* "Starting component listening thread~%")
  121. ;; ### Story time! ###
  122. ;; So I spent an hour debugging why this wasn't working.
  123. ;; And, long story short, if you just call CXML:PARSE with a stream
  124. ;; it gets converted into an 'xstream' inside CXML, which has a :SPEED
  125. ;; property. This :SPEED property controls how many bytes it tries to buffer
  126. ;; before actually doing the parsing and the goddamn default is 8192 (!!).
  127. ;; This obviously ain't gonna fly for our TCP socket, because the initial stream
  128. ;; start element is less than 8192 bytes. So we make our own stupid xstream
  129. ;; and specify the speed manually, and then it works.
  130. ;;
  131. ;; Wouldn't it be nice if people documented this sort of thing?
  132. ;;
  133. ;; ### Part II: The Fucking Stream Strikes Back ###
  134. ;; ...and, after another hour of debugging, I found out you have to specify the `name'
  135. ;; arg, otherwise it breaks -- but ONLY randomly and once you decide to deploy it
  136. ;; in production, of course.
  137. (let ((source (make-xmpp-source comp))
  138. (fucking-stream (cxml:make-xstream (component-socket comp)
  139. :speed 1 ; FFFFFFFFUUUUUUUU
  140. :name (cxml::make-stream-name ; AAAARGH
  141. :entity-name "main document"
  142. :entity-kind :main
  143. :uri nil)
  144. :name "XMPP server stream"
  145. :initial-speed 1)))
  146. (cxml:parse fucking-stream source
  147. :recode t)))
  148. (defmacro with-component-xml-output ((comp) &body body)
  149. (let ((ret-sym (gensym)))
  150. `(with-accessors ((lock component-socket-lock) (socket component-socket) (sink component-sink))
  151. ,comp
  152. (with-component-data-lock (,comp)
  153. (bt:with-recursive-lock-held (lock)
  154. (let ((,ret-sym nil))
  155. (cxml:with-xml-output sink
  156. (setf ,ret-sym ,@body))
  157. (force-output socket)
  158. ,ret-sym))))))
  159. (defun write-stream-header (comp)
  160. (with-component-xml-output (comp)
  161. (cxml:with-namespace ("stream" "http://etherx.jabber.org/streams")
  162. (cxml:with-element "stream:stream"
  163. (cxml:attribute "xmlns" +component-ns+)
  164. (cxml:attribute "to" (component-name comp))))))
  165. (defun component-stream-started (comp)
  166. (with-component-xml-output (comp)
  167. (cxml:with-element "handshake"
  168. (cxml:attribute "xmlns" +component-ns+)
  169. (cxml:text (string-downcase (sha1-hex (concatenate 'string (component-stream-id comp) (component-shared-secret comp))))))))
  170. (defun register-component-iq-handler (comp handler-name func)
  171. "Register FUNC to be called for the HANDLER-NAME IQ handler on COMP."
  172. (with-component-data-lock (comp)
  173. (setf (gethash handler-name (component-handlers comp)) func)))
  174. (defun call-component-iq-handler (comp handler &rest args)
  175. "Calls the IQ handler identified by the symbol HANDLER on COMP, with the provided ARGS."
  176. (destructuring-bind (&key id to from &allow-other-keys) args
  177. (with-component-data-lock (comp)
  178. (catcher
  179. (attach
  180. (let ((func (gethash handler (component-handlers comp))))
  181. (unless func
  182. (error 'stanza-error
  183. :defined-condition "feature-not-implemented"
  184. :text (format nil "No handler for ~A registered" handler)
  185. :type "cancel"))
  186. (let ((result (apply func comp args)))
  187. result))
  188. (lambda (result-forms)
  189. (eval `(with-component-xml-output (,comp)
  190. (cxml:with-element "iq"
  191. (cxml:attribute "type" "result")
  192. (cxml:attribute "id" ,id)
  193. (cxml:attribute "from" ,to)
  194. (cxml:attribute "to" ,from)
  195. ,@result-forms)))))
  196. (stanza-error (e)
  197. (send-stanza-error comp
  198. :stanza-type "iq"
  199. :id id :to from :from to :e e))
  200. (t (e)
  201. (send-stanza-error comp
  202. :stanza-type "iq"
  203. :id id
  204. :to from
  205. :from to
  206. :e (make-condition 'stanza-error
  207. :defined-condition "internal-server-error"
  208. :text (format nil "~A" e)
  209. :type "cancel"))
  210. (warn "IQ handler for ~A failed: ~A" handler e))))))
  211. (defun handle-iq-get (comp id from stanza)
  212. "Handles an IQ-get STANZA for component COMP."
  213. (let* ((children (child-elements stanza))
  214. (first-child (if (> (length children) 0)
  215. (elt children 0)
  216. (return-from handle-iq-get)))
  217. (tag-name (dom:tag-name first-child))
  218. (to (dom:get-attribute stanza "to"))
  219. (xmlns (dom:get-attribute first-child "xmlns"))
  220. (handler-type
  221. (cond
  222. ((and (equal xmlns +disco-info-ns+) (equal tag-name "query"))
  223. :disco-info)
  224. ((and (equal xmlns +disco-items-ns+) (equal tag-name "query"))
  225. :disco-items)
  226. ((and (equal xmlns +vcard-temp-ns+) (equal tag-name "vCard"))
  227. :vcard-temp-get)
  228. ((and (equal xmlns +mam-ns+) (equal tag-name "query"))
  229. :mam-query)
  230. ((and (equal xmlns +ping-ns+) (equal tag-name "ping"))
  231. :ping)
  232. (t
  233. :generic-iq))))
  234. (call-component-iq-handler comp handler-type
  235. :to to
  236. :id id
  237. :from from
  238. :stanza stanza)))
  239. (defun handle-iq-response (comp stanza)
  240. "Handles an IQ response STANZA for component COMP."
  241. (with-component-data-lock (comp)
  242. (let ((type (dom:get-attribute stanza "type"))
  243. (id (dom:get-attribute stanza "id"))
  244. (from (dom:get-attribute stanza "from")))
  245. (if (or (equal type "get") (equal type "set"))
  246. (handle-iq-get comp id from stanza)
  247. (symbol-macrolet
  248. ((promise (gethash id (component-promises comp))))
  249. (if promise
  250. (progn
  251. (format t "~&IQ ~A from ~A for ~A~%" type from id)
  252. (cond
  253. ((equal type "result") (finish promise (child-elements stanza)))
  254. ((equal type "error") (signal-error promise (extract-stanza-error stanza)))
  255. (t (warn "Invalid IQ stanza type: ~A" type)))
  256. (setf promise nil))
  257. (warn "Unsolicited IQ stanza from ~A of type ~A, ID ~A" from type id)))))))
  258. (defun handle-presence (comp stanza)
  259. "Handles a presence STANZA for component COMP."
  260. (let* ((type (dom:get-attribute stanza "type"))
  261. (from (dom:get-attribute stanza "from"))
  262. (to (dom:get-attribute stanza "to"))
  263. (event-name
  264. (cond
  265. ((equal type "subscribe") :presence-subscribe)
  266. ((equal type "probe") :presence-probe)
  267. ((equal type "unavailable") :presence-unavailable)
  268. (t :presence))))
  269. (emit event-name comp :from from :to to :type type :stanza stanza)))
  270. (defun handle-message (comp stanza)
  271. "Handles a message STANZA for component COMP."
  272. (let* ((from (dom:get-attribute stanza "from"))
  273. (to (dom:get-attribute stanza "to"))
  274. (id (dom:get-attribute stanza "id"))
  275. (children (child-elements stanza))
  276. (body (get-node-named children "body"))
  277. (marker (get-node-with-xmlns children +chat-markers-ns+))
  278. (oob-element (get-node-with-xmlns children +oob-ns+))
  279. (oob-url-element (when oob-element
  280. (get-node-named (child-elements oob-element) "url")))
  281. (chat-state (get-node-with-xmlns children +chat-states-ns+)))
  282. (cond
  283. (body
  284. (let* ((text (get-node-text body))
  285. (oob-url (when oob-url-element
  286. (get-node-text oob-url-element))))
  287. (emit :text-message comp :from from :to to :body text :id id :stanza stanza
  288. :oob-url oob-url)))
  289. (marker
  290. (let ((marker-type (dom:tag-name marker))
  291. (msgid (dom:get-attribute marker "id")))
  292. (emit :message-marker comp :from from :to to :type marker-type :marker-id msgid :id id :stanza stanza)))
  293. (chat-state
  294. (let ((state-type (dom:tag-name chat-state)))
  295. (emit :chat-state comp :from from :to to :type state-type :id id :stanza stanza)))
  296. (t
  297. (emit :message comp :from from :to to :id id :stanza stanza)))))
  298. (defun component-stanza (comp stanza)
  299. "Handles a STANZA received by component COMP."
  300. (let* ((stanza (dom:document-element stanza))
  301. (tag-name (dom:tag-name stanza)))
  302. (cond
  303. ((equal tag-name "stream:error") (handle-stream-error comp stanza))
  304. ((equal tag-name "handshake") (handle-connection-complete comp))
  305. ((equal tag-name "iq") (handle-iq-response comp stanza))
  306. ((equal tag-name "presence") (handle-presence comp stanza))
  307. ((equal tag-name "message") (handle-message comp stanza))
  308. (t (emit :stanza comp stanza)))))
  309. (defun make-component (server port shared-secret name)
  310. "Make a new XMPP component, connecting to SERVER on PORT with SHARED-SECRET."
  311. (let* ((socket (socket-stream
  312. (socket-connect server port
  313. :element-type '(unsigned-byte 8))))
  314. (component (make-instance 'xmpp-component
  315. :socket socket
  316. :sink (make-xmpp-sink socket)
  317. :name name
  318. :shared-secret shared-secret)))
  319. (bt:make-thread (lambda ()
  320. (component-listen-thread component))
  321. :name "XMPP component listen thread")
  322. (on :stream-started component (lambda ()
  323. (component-stream-started component)))
  324. (on :raw-stanza component (lambda (stanza)
  325. (component-stanza component stanza)))
  326. (write-stream-header component)
  327. component))