a3x/whatsxmpp
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

don't overwhelm everyone with copious amounts of XMPP output

Browse source
This commit is contained in:
eta 2020-04-05 16:46:20 +01:00
parent 3337500b90
commit 590390347b
1 changed files with 13 additions and 10 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

23
stuff.lisp
View file

@ -17,6 +17,9 @@
(defparameter +roster-exchange-ns+ "http://jabber.org/protocol/rosterx") (defparameter +roster-exchange-ns+ "http://jabber.org/protocol/rosterx")
(defparameter +delivery-receipts-ns+ "urn:xmpp:receipts") (defparameter +delivery-receipts-ns+ "urn:xmpp:receipts")
(defvar *xmpp-debug-io* (make-broadcast-stream))
(defvar *xmpp-debug-out* (make-synonym-stream '*xmpp-debug-io*))
(defclass xmpp-component (event-emitter) (defclass xmpp-component (event-emitter)
((socket ((socket
:initarg :socket :initarg :socket
@ -77,7 +80,7 @@
(defmethod sax:start-document ((s xmpp-source)) (defmethod sax:start-document ((s xmpp-source))
(declare (ignore s)) (declare (ignore s))
(format *debug-io* "~&XMPP --> [document started]~%")) (format *xmpp-debug-out* "~&XMPP --> [document started]~%"))
(defmethod sax:start-element ((s xmpp-source) namespace-uri local-name qname attributes) (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 (with-accessors ((depth source-depth) (comp source-component) (handlers cxml:broadcast-handler-handlers)) s
@ -88,15 +91,15 @@
(let ((stream-id-attr (find-if #'local-name-is-id attributes))) (let ((stream-id-attr (find-if #'local-name-is-id attributes)))
(when (not stream-id-attr) (when (not stream-id-attr)
(error "Server didn't send a stream ID")) (error "Server didn't send a stream ID"))
(format *debug-io* "~&XMPP --> [stream started, ID ~A]~%" (sax:attribute-value stream-id-attr)) (format *xmpp-debug-out* "~&XMPP --> [stream started, ID ~A]~%" (sax:attribute-value stream-id-attr))
(with-component-data-lock (comp) (with-component-data-lock (comp)
(setf (component-stream-id comp) (sax:attribute-value stream-id-attr)) (setf (component-stream-id comp) (sax:attribute-value stream-id-attr))
(emit :stream-started comp)) (emit :stream-started comp))
(return-from sax:start-element)))) (return-from sax:start-element))))
(when (eql depth 2) (when (eql depth 2)
(let ((dom-builder (cxml-dom:make-dom-builder))) (let ((dom-builder (cxml-dom:make-dom-builder)))
(format *debug-io* "~&XMPP --> ") (format *xmpp-debug-out* "~&XMPP --> ")
(setf handlers (list (cxml:make-character-stream-sink *debug-io*) dom-builder)) (setf handlers (list (cxml:make-character-stream-sink *xmpp-debug-out*) dom-builder))
(sax:start-document dom-builder))) (sax:start-document dom-builder)))
(call-next-method s namespace-uri local-name qname attributes))) (call-next-method s namespace-uri local-name qname attributes)))
@ -112,7 +115,7 @@
(dom-builder (second handlers)) (dom-builder (second handlers))
(stanza (sax:end-document dom-builder))) (stanza (sax:end-document dom-builder)))
(sax:end-document debug-sink) (sax:end-document debug-sink)
(terpri *debug-io*) (terpri *xmpp-debug-out*)
(setf handlers nil) (setf handlers nil)
(emit :raw-stanza comp stanza))))) (emit :raw-stanza comp stanza)))))
@ -123,7 +126,7 @@
(defmethod sax:start-document ((s xmpp-sink)) (defmethod sax:start-document ((s xmpp-sink))
(declare (ignore s)) (declare (ignore s))
(format *debug-io* "~&XMPP <-- ")) (format *xmpp-debug-out* "~&XMPP <-- "))
(defmethod sax:end-element ((s xmpp-sink) namespace-uri local-name qname) (defmethod sax:end-element ((s xmpp-sink) namespace-uri local-name qname)
(if (and (sink-open s) (equal local-name "stream")) (if (and (sink-open s) (equal local-name "stream"))
@ -134,7 +137,7 @@
;; bit of the opening tag. ;; bit of the opening tag.
(sax:characters s "") (sax:characters s "")
(call-next-method s namespace-uri local-name qname)) (call-next-method s namespace-uri local-name qname))
(terpri *debug-io*)) (terpri *xmpp-debug-out*))
(defun close-xmpp-component (comp) (defun close-xmpp-component (comp)
(bt:with-recursive-lock-held ((component-socket-lock comp)) (bt:with-recursive-lock-held ((component-socket-lock comp))
@ -147,7 +150,7 @@
(defun make-xmpp-sink (socket) (defun make-xmpp-sink (socket)
(let ((ret (cxml:make-broadcast-handler (let ((ret (cxml:make-broadcast-handler
(cxml:make-character-stream-sink *debug-io*) (cxml:make-character-stream-sink *xmpp-debug-out*)
(cxml:make-octet-stream-sink socket)))) (cxml:make-octet-stream-sink socket))))
(change-class ret 'xmpp-sink) (change-class ret 'xmpp-sink)
ret)) ret))
@ -410,7 +413,7 @@
:text text)))) :text text))))
(defun handle-connection-complete (comp) (defun handle-connection-complete (comp)
(format *debug-io* "Connection complete! \o/") (format *debug-io* "Connection complete! \\o/")
(emit :connected comp)) (emit :connected comp))
(defun send-stanza-error (comp &key id to from e stanza-type) (defun send-stanza-error (comp &key id to from e stanza-type)
@ -813,7 +816,7 @@ WhatsXMPP represents users as u440123456789 and groups as g1234-5678."
(update-session-data jid sessdata) (update-session-data jid sessdata)
(admin-msg comp jid status) (admin-msg comp jid status)
(admin-presence comp jid status) (admin-presence comp jid status)
(format *debug-io* "~&ws-connected: ~A~%" jid)))) (format *debug-io* "~&ws-connected: ~A (as ~A)~%" jid wa-jid))))
(defun wa-handle-error-status-code (comp conn jid err) (defun wa-handle-error-status-code (comp conn jid err)
(with-wa-handler-context (comp conn jid) (with-wa-handler-context (comp conn jid)