Handle presence subscriptions, vcard-temp, and other stuff
This commit is contained in:
eta
parent
e2add1d98f
commit
12cb121100
|
|
@ -14,7 +14,7 @@ CREATE TABLE users (
|
|||
);
|
||||
|
||||
CREATE TABLE user_contacts (
|
||||
id SERIAL PRIMARY KEY,
|
||||
id INTEGER PRIMARY KEY,
|
||||
user_id INT NOT NULL REFERENCES users,
|
||||
wa_jid VARCHAR UNIQUE NOT NULL,
|
||||
subscription_state VARCHAR NOT NULL DEFAULT 'none',
|
||||
|
|
|
|||
|
|
@ -43,9 +43,10 @@ In other words, prepares STATEMENT once, then returns the prepared statement aft
|
|||
"Evaluates FORMS, binding a prepared statement with SQL text STATEMENT to NAME, and ensuring it is reset when control is transferred."
|
||||
`(bt:with-recursive-lock-held (*db-lock*)
|
||||
(let ((,name (prepared-statement ,statement)))
|
||||
(prog1
|
||||
(unwind-protect
|
||||
(progn ,@forms)
|
||||
(ignore-errors (sqlite:reset-statement ,name))))))
|
||||
(ignore-errors (sqlite:reset-statement ,name)))))))
|
||||
|
||||
(defmacro with-prepared-statements (statements &body forms)
|
||||
"Like WITH-PREPARED-STATEMENT, but takes multiple statements."
|
||||
|
|
@ -55,9 +56,10 @@ In other words, prepares STATEMENT once, then returns the prepared statement aft
|
|||
collect `(ignore-errors (sqlite:reset-statement ,name)))))
|
||||
`(bt:with-recursive-lock-held (*db-lock*)
|
||||
(let (,@let-forms)
|
||||
(prog1
|
||||
(unwind-protect
|
||||
(progn ,@forms))
|
||||
(ignore-errors (progn ,@reset-forms))))))
|
||||
(ignore-errors (progn ,@reset-forms)))))))
|
||||
|
||||
(defmacro column-values (statement)
|
||||
"Returns the values in the current row of the STATEMENT."
|
||||
|
|
|
|||
190
stuff.lisp
190
stuff.lisp
|
|
@ -12,6 +12,8 @@
|
|||
(defparameter +chat-markers-ns+ "urn:xmpp:chat-markers:0")
|
||||
(defparameter +delivery-delay-ns+ "urn:xmpp:delay")
|
||||
(defparameter +vcard-temp-ns+ "vcard-temp")
|
||||
(defparameter +nick-ns+ "http://jabber.org/protocol/nick")
|
||||
(defparameter +roster-exchange-ns+ "http://jabber.org/protocol/rosterx")
|
||||
|
||||
(defclass xmpp-component (event-emitter)
|
||||
((socket
|
||||
|
|
@ -596,10 +598,6 @@
|
|||
`((cxml:with-element "query"
|
||||
(cxml:attribute "xmlns" ,+disco-info-ns+)))))
|
||||
|
||||
(defun register-whatsxmpp-handlers (comp)
|
||||
(register-component-iq-handler comp :disco-info #'disco-info-handler)
|
||||
(register-component-iq-handler comp :disco-items #'disco-items-handler))
|
||||
|
||||
(defun parse-jid (jid)
|
||||
"Parse JID, returning the multiple values HOSTNAME, LOCALPART and RESOURCE."
|
||||
(declare (type string jid))
|
||||
|
|
@ -650,6 +648,17 @@ Commands:
|
|||
"Send an admin message from the admin on COMP to JID."
|
||||
(send-text-message comp jid text (admin-jid comp)))
|
||||
|
||||
(defun admin-presence (comp jid status &optional show)
|
||||
"Send presence from the admin on COMP to JID."
|
||||
(with-presence (comp jid
|
||||
:from (admin-jid comp))
|
||||
(when show
|
||||
(cxml:with-element "show"
|
||||
(cxml:text show))
|
||||
(cxml:with-element "status"
|
||||
(cxml:text status)))))
|
||||
|
||||
|
||||
(defun wa-resetup-users (comp)
|
||||
"Go through the list of WhatsApp users and reconnect those whose connections have dropped."
|
||||
(with-component-data-lock (comp)
|
||||
|
|
@ -753,6 +762,7 @@ WhatsXMPP represents users as u440123456789 and groups as g1234-5678."
|
|||
(format *debug-io* "~&ws-error ~A: ~A~%" jid err)
|
||||
(admin-msg comp jid
|
||||
(format nil "WhatsApp websocket error: ~A" err))
|
||||
(admin-presence comp jid "WebSocket error" "away")
|
||||
(setf (gethash jid (component-whatsapps comp)) nil)))
|
||||
|
||||
(defun wa-handle-ws-close (comp conn jid)
|
||||
|
|
@ -760,17 +770,20 @@ WhatsXMPP represents users as u440123456789 and groups as g1234-5678."
|
|||
(format *debug-io* "~&ws-close: ~A~%" jid)
|
||||
(admin-msg comp jid
|
||||
"WhatsApp websocket closed (will reconnect soon).")
|
||||
(admin-presence comp jid "WebSocket closed" "away")
|
||||
(setf (gethash jid (component-whatsapps comp)) nil)))
|
||||
|
||||
(defun wa-handle-ws-open (comp conn jid)
|
||||
(with-wa-handler-context (comp conn jid)
|
||||
(format *debug-io* "~&ws-open: ~A~%" jid)
|
||||
(admin-presence comp jid "Connected" "away")
|
||||
(admin-msg comp jid
|
||||
"WhatsApp websocket connected.")))
|
||||
|
||||
(defun wa-handle-ws-qrcode (comp conn jid qrcode)
|
||||
(with-wa-handler-context (comp conn jid)
|
||||
(format *debug-io* "~&qrcode: ~A~%" jid)
|
||||
(admin-presence comp jid "Waiting for QR code" "away")
|
||||
(send-qrcode comp jid qrcode)))
|
||||
|
||||
(defun update-session-data (jid sessdata)
|
||||
|
|
@ -782,11 +795,12 @@ WhatsXMPP represents users as u440123456789 and groups as g1234-5678."
|
|||
|
||||
(defun wa-handle-ws-connected (comp conn jid wa-jid)
|
||||
(with-wa-handler-context (comp conn jid)
|
||||
(let ((sessdata (whatscl::serialize-persistent-session (whatscl::wac-session conn))))
|
||||
(update-session-data jid sessdata))
|
||||
(admin-msg comp jid
|
||||
(format nil "Logged in to WhatsApp as ~A." wa-jid))
|
||||
(format *debug-io* "~&ws-connected: ~A~%" jid)))
|
||||
(let ((sessdata (whatscl::serialize-persistent-session (whatscl::wac-session conn)))
|
||||
(status (format nil "Logged in to WhatsApp as ~A." wa-jid)))
|
||||
(update-session-data jid sessdata)
|
||||
(admin-msg comp jid status)
|
||||
(admin-presence comp jid status)
|
||||
(format *debug-io* "~&ws-connected: ~A~%" jid))))
|
||||
|
||||
(defun wa-handle-error-status-code (comp conn jid err)
|
||||
(with-wa-handler-context (comp conn jid)
|
||||
|
|
@ -796,13 +810,17 @@ WhatsXMPP represents users as u440123456789 and groups as g1234-5678."
|
|||
((equal status-code 401)
|
||||
(progn
|
||||
(admin-msg comp jid "Error: The WhatsApp Web connection was removed from your device! You'll need to scan the QR code again.")
|
||||
(admin-presence comp jid "Connection removed" "xa")
|
||||
(update-session-data jid "")))
|
||||
((equal status-code 403)
|
||||
(progn
|
||||
(admin-msg comp jid "Error: WhatsApp Web denied access. You may have violated the Terms of Service.")
|
||||
(admin-presence comp jid "Access denied" "xa")
|
||||
(update-session-data jid "")))
|
||||
(t
|
||||
(admin-msg comp jid (format nil "Login failure: ~A" err)))))
|
||||
(progn
|
||||
(admin-presence comp jid "Login failure" "xa")
|
||||
(admin-msg comp jid (format nil "Login failure: ~A" err))))))
|
||||
(admin-msg comp jid "(Disabling automatic reconnections.)")
|
||||
(remhash jid (component-whatsapps comp))))
|
||||
|
||||
|
|
@ -812,6 +830,7 @@ WhatsXMPP represents users as u440123456789 and groups as g1234-5678."
|
|||
(admin-msg comp jid
|
||||
(format nil "A programming error has been detected and your connection has been aborted unexpectedly.~%Report the following error to the bridge admin: ~A" err))
|
||||
(admin-msg comp jid "(Disabling automatic reconnections.)")
|
||||
(admin-presence comp jid "Programming error" "xa")
|
||||
(remhash jid (component-whatsapps comp))))
|
||||
|
||||
(defun wa-handle-message (comp conn jid msg delivery-type)
|
||||
|
|
@ -844,6 +863,88 @@ WhatsXMPP represents users as u440123456789 and groups as g1234-5678."
|
|||
(cxml:with-element "markable"
|
||||
(cxml:attribute "xmlns" +chat-markers-ns+))))))))))
|
||||
|
||||
(defun wa-handle-message-ack (comp conn jid &key id ack from to ts)
|
||||
(with-wa-handler-context (comp conn jid)
|
||||
|
||||
))
|
||||
|
||||
(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-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 handle-wa-contact-presence (comp jid localpart)
|
||||
"Check if we need to send out presence subscriptions for LOCALPART."
|
||||
(let ((uid (get-user-id jid)))
|
||||
(assert uid () "No user ID for ~A!" jid)
|
||||
(with-prepared-statements
|
||||
((get-stmt "SELECT subscription_state, name, notify, id FROM user_contacts WHERE user_id = ? AND wa_jid = ?")
|
||||
(update-stmt "UPDATE user_contacts SET subscription_state = ? WHERE id = ?"))
|
||||
(bind-parameters get-stmt uid localpart)
|
||||
(unless (sqlite:step-statement get-stmt)
|
||||
(error "No contact with localpart ~A exists!" localpart))
|
||||
(with-bound-columns (subscription-state name notify ctid) get-stmt
|
||||
(when (equal subscription-state "none")
|
||||
(let ((name-to-use (or name
|
||||
(when notify (concatenate 'string "~" notify))
|
||||
(substitute #\+ #\u localpart)))
|
||||
(from (concatenate 'string localpart "@" (component-name comp))))
|
||||
(with-presence (comp jid
|
||||
:type "subscribe"
|
||||
:from from)
|
||||
(cxml:with-element "status"
|
||||
(cxml:text (format nil "I'm ~A from your WhatsApp contacts! (via whatsxmpp)" name-to-use)))
|
||||
(cxml:with-element "nick"
|
||||
(cxml:attribute "xmlns" +nick-ns+)
|
||||
(cxml:text name-to-use)))
|
||||
(bind-parameters update-stmt "asked" ctid)
|
||||
(sqlite:step-statement update-stmt)))))))
|
||||
|
||||
(defun add-wa-contact (comp jid contact)
|
||||
"Adds the WHATSCL:CONTACT to the list of JID's contacts, or updates it if it already exists."
|
||||
(with-accessors ((ct-jid whatscl::contact-jid)
|
||||
(ct-notify whatscl::contact-notify)
|
||||
(ct-name whatscl::contact-name))
|
||||
contact
|
||||
(let ((uid (get-user-id jid))
|
||||
(wx-localpart (wa-jid-to-whatsxmpp-localpart ct-jid)))
|
||||
(assert uid () "No user ID for ~A!" jid)
|
||||
(with-prepared-statements
|
||||
((get-stmt "SELECT id, name, notify FROM user_contacts WHERE user_id = ? AND wa_jid = ?")
|
||||
(update-stmt "UPDATE user_contacts SET name = ?, notify = ? WHERE id = ?")
|
||||
(insert-stmt "INSERT INTO user_contacts (user_id, wa_jid, name, notify) VALUES (?, ?, ?, ?)"))
|
||||
(bind-parameters get-stmt uid wx-localpart)
|
||||
(if (sqlite:step-statement get-stmt)
|
||||
(with-bound-columns (id name notify) get-stmt
|
||||
(let ((notify (or ct-notify notify))
|
||||
(name (or ct-name name)))
|
||||
(bind-parameters update-stmt name notify id)
|
||||
(sqlite:step-statement update-stmt)))
|
||||
(progn
|
||||
(bind-parameters insert-stmt uid wx-localpart ct-name ct-notify)
|
||||
(sqlite:step-statement insert-stmt)))
|
||||
(handle-wa-contact-presence comp jid wx-localpart)))))
|
||||
|
||||
(defun wa-handle-contacts (comp conn jid contacts)
|
||||
(with-wa-handler-context (comp conn jid)
|
||||
(format *debug-io* "~&got ~A contacts for ~A~%" (length contacts) jid)
|
||||
(loop
|
||||
for contact in contacts
|
||||
do (add-wa-contact comp jid contact))))
|
||||
|
||||
(defun bind-wa-handlers (comp conn jid)
|
||||
(on :ws-open conn (lambda () (wa-handle-ws-open comp conn jid)))
|
||||
(on :ws-close conn (lambda (&rest args)
|
||||
|
|
@ -854,6 +955,7 @@ WhatsXMPP represents users as u440123456789 and groups as g1234-5678."
|
|||
(on :error-status-code conn (lambda (e) (wa-handle-error-status-code comp conn jid e)))
|
||||
(on :qrcode conn (lambda (text) (wa-handle-ws-qrcode comp conn jid text)))
|
||||
(on :message conn (lambda (msg dt) (wa-handle-message comp conn jid msg dt)))
|
||||
(on :contacts conn (lambda (contacts) (wa-handle-contacts comp conn jid contacts)))
|
||||
(on :connected conn (lambda (waj) (wa-handle-ws-connected comp conn jid waj))))
|
||||
|
||||
(defun handle-setup-user (comp jid)
|
||||
|
|
@ -935,6 +1037,57 @@ WhatsXMPP represents users as u440123456789 and groups as g1234-5678."
|
|||
(t
|
||||
(reply "Unknown command. Try `help` for a list of supported commands."))))))
|
||||
|
||||
(defun whatsxmpp-vcard-temp-handler (comp &key to from &allow-other-keys)
|
||||
"Handles a vcard-temp IQ request."
|
||||
(format *debug-io* "~&vcard-temp: ~A (from ~A)~%" to from)
|
||||
(with-component-data-lock (comp)
|
||||
(let* ((uid (get-user-id from))
|
||||
(to-localpart (nth-value 1 (parse-jid to)))
|
||||
(name
|
||||
(cond
|
||||
((equal to-localpart "admin")
|
||||
"whatsxmpp admin")
|
||||
((not uid)
|
||||
(error 'stanza-error
|
||||
:defined-condition "registration-required"
|
||||
:text "You must register with the bridge admin to view contact details."
|
||||
:type "auth"))
|
||||
(t
|
||||
(let ((name (get-contact-name uid to-localpart)))
|
||||
(unless name
|
||||
(error 'stanza-error
|
||||
:defined-condition "item-not-found"
|
||||
:text "No vCard for that JID is available at this time."
|
||||
:type "modify"))
|
||||
name)))))
|
||||
`((cxml:with-element "vCard"
|
||||
(cxml:attribute "xmlns" +vcard-temp-ns+)
|
||||
(cxml:with-element "FN"
|
||||
(cxml:text ,name))
|
||||
(cxml:with-element "NICKNAME"
|
||||
(cxml:text ,name)))))))
|
||||
|
||||
(defun whatsxmpp-presence-subscribe-handler (comp &key from to id &allow-other-keys)
|
||||
"Handles a presence subscription request."
|
||||
(with-component-data-lock (comp)
|
||||
(multiple-value-bind (to-hostname to-localpart)
|
||||
(parse-jid to)
|
||||
(unless (equal to-hostname (component-name comp))
|
||||
(warn "Got presence subscribe addressed to ~A!" to)
|
||||
(return-from whatsxmpp-presence-subscribe-handler))
|
||||
(format *debug-io* "~&presence subscribe from: ~A~%" from)
|
||||
(if (or (equal to-localpart "admin") (whatsxmpp-localpart-to-wa-jid to-localpart))
|
||||
(with-presence (comp (strip-resource from)
|
||||
:from to
|
||||
:type "subscribed"))
|
||||
(send-stanza-error comp
|
||||
:stanza-type "presence"
|
||||
:id id :to from :from to
|
||||
:e (make-condition 'stanza-error
|
||||
:defined-condition "item-not-found"
|
||||
:text "That user's JID isn't in a recognizable format."
|
||||
:type "modify"))))))
|
||||
|
||||
(defun whatsxmpp-message-handler (comp &key from to body id &allow-other-keys)
|
||||
"Handles a message sent to the whatsxmpp bridge."
|
||||
(with-component-data-lock (comp)
|
||||
|
|
@ -944,12 +1097,8 @@ WhatsXMPP represents users as u440123456789 and groups as g1234-5678."
|
|||
(warn "Got message addressed to ~A!" to)
|
||||
(return-from whatsxmpp-message-handler))
|
||||
(format *debug-io* "~&message from: ~A~%" from)
|
||||
(with-prepared-statement
|
||||
(get-user "SELECT id FROM users WHERE jid = ?")
|
||||
(let ((stripped (strip-resource from)))
|
||||
(bind-parameters get-user stripped)
|
||||
(let ((uid (when (sqlite:step-statement get-user)
|
||||
(first (column-values get-user))))
|
||||
(let* ((stripped (strip-resource from))
|
||||
(uid (get-user-id stripped))
|
||||
(conn (gethash stripped (component-whatsapps comp)))
|
||||
(wa-jid (whatsxmpp-localpart-to-wa-jid to-localpart)))
|
||||
(labels
|
||||
|
|
@ -977,7 +1126,7 @@ WhatsXMPP represents users as u440123456789 and groups as g1234-5678."
|
|||
:text "You're currently not connected to WhatsApp."
|
||||
:type "wait")))
|
||||
(t
|
||||
(whatscl::send-simple-text-message conn wa-jid body))))))))))
|
||||
(whatscl::send-simple-text-message conn wa-jid body))))))))
|
||||
|
||||
(defun whatsxmpp-load-users (comp)
|
||||
(with-component-data-lock (comp)
|
||||
|
|
@ -988,6 +1137,11 @@ WhatsXMPP represents users as u440123456789 and groups as g1234-5678."
|
|||
do (with-bound-columns (jid) stmt
|
||||
(setf (gethash jid (component-whatsapps comp)) nil))))))
|
||||
|
||||
(defun register-whatsxmpp-handlers (comp)
|
||||
(register-component-iq-handler comp :disco-info #'disco-info-handler)
|
||||
(register-component-iq-handler comp :vcard-temp-get #'whatsxmpp-vcard-temp-handler)
|
||||
(register-component-iq-handler comp :disco-items #'disco-items-handler))
|
||||
|
||||
(defun whatsxmpp-init ()
|
||||
"Initialise the whatsxmpp bridge."
|
||||
(connect-database)
|
||||
|
|
@ -1001,6 +1155,8 @@ WhatsXMPP represents users as u440123456789 and groups as g1234-5678."
|
|||
:upload-component-name upload-name)))
|
||||
(on :text-message ret (lambda (&rest args)
|
||||
(apply #'whatsxmpp-message-handler ret args)))
|
||||
(on :presence-subscribe ret (lambda (&rest args)
|
||||
(apply #'whatsxmpp-presence-subscribe-handler ret args)))
|
||||
(register-whatsxmpp-handlers ret)
|
||||
(whatsxmpp-load-users ret)
|
||||
(setf (component-reconnect-timer ret) (trivial-timers:make-timer
|
||||
|
|
|
|||
Loading…
Reference in a new issue