diff --git a/schema.sql b/schema.sql index 737ae04..64b6a75 100644 --- a/schema.sql +++ b/schema.sql @@ -30,3 +30,9 @@ CREATE TABLE user_messages ( wa_id VARCHAR NOT NULL, UNIQUE(user_id, wa_id) ); + +CREATE TABLE avatar_data ( + avatar_url VARCHAR NOT NULL PRIMARY KEY, + sha1 VARCHAR NOT NULL, + image BLOB NOT NULL +); diff --git a/sqlite.lisp b/sqlite.lisp index 6651aeb..7d71d38 100644 --- a/sqlite.lisp +++ b/sqlite.lisp @@ -43,7 +43,7 @@ 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 + (multiple-value-prog1 (unwind-protect (progn ,@forms) (ignore-errors (sqlite:reset-statement ,name))))))) @@ -56,7 +56,7 @@ 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 + (multiple-value-prog1 (unwind-protect (progn ,@forms)) (ignore-errors (progn ,@reset-forms))))))) diff --git a/stuff.lisp b/stuff.lisp index 85eacaf..3b9b22c 100644 --- a/stuff.lisp +++ b/stuff.lisp @@ -12,6 +12,7 @@ (defparameter +chat-markers-ns+ "urn:xmpp:chat-markers:0") (defparameter +delivery-delay-ns+ "urn:xmpp:delay") (defparameter +vcard-temp-ns+ "vcard-temp") +(defparameter +vcard-avatar-ns+ "vcard-temp:x:update") (defparameter +nick-ns+ "http://jabber.org/protocol/nick") (defparameter +roster-exchange-ns+ "http://jabber.org/protocol/rosterx") (defparameter +delivery-receipts-ns+ "urn:xmpp:receipts") @@ -202,14 +203,17 @@ (cxml:attribute "xmlns" +component-ns+) (cxml:attribute "to" (component-name comp)))))) -(defun sha1-hex (str) - "Returns the SHA1 of STR, a string, in lowercase hex." +(defun sha1-octets (buf) + "Returns the SHA1 of BUF, a vector of octets, in lowercase hex." (format nil "~(~{~2,'0X~}~)" (coerce - (ironclad:digest-sequence :sha1 - (babel:string-to-octets str)) + (ironclad:digest-sequence :sha1 buf) 'list))) +(defun sha1-hex (str) + "Returns the SHA1 of STR, a string, in lowercase hex." + (sha1-octets (babel:string-to-octets str))) + (defun component-stream-started (comp) (with-component-xml-output (comp) (cxml:with-element "handshake" @@ -260,12 +264,13 @@ :id ,id) ,@body)) -(defmacro with-presence ((comp to &key type from) &body 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) + :from ,from + :id ,id) ,@body)) (defun get-node-named (nodes name) @@ -535,7 +540,7 @@ ((equal type "probe") :presence-probe) ((equal type "unavailable") :presence-unavailable) (t :presence)))) - (emit event-name comp :from from :to to :stanza stanza))) + (emit event-name comp :from from :to to :type type :stanza stanza))) (defun handle-message (comp stanza) "Handles a message STANZA for component COMP." @@ -898,8 +903,75 @@ WhatsXMPP represents users as u440123456789 and groups as g1234-5678." (with-bound-columns (name notify) get-stmt (or name notify (substitute #\+ #\u localpart)))))) +(defun get-avatar-data (avatar-url) + "Fetches AVATAR-URL, using the database as a cache. Returns the SHA1 hash (lowercase) of the avatar data as first argument, and the actual octets as second." + (with-prepared-statements + ((get-stmt "SELECT sha1, image FROM avatar_data WHERE avatar_url = ?") + (insert-stmt "INSERT INTO avatar_data (avatar_url, sha1, image) VALUES (?, ?, ?)")) + (bind-parameters get-stmt avatar-url) + (if (sqlite:step-statement get-stmt) + (with-bound-columns (sha1 image) get-stmt + (values sha1 image)) + (progn + (format *debug-io* "~&fetching avatar url: ~A~%" avatar-url) + (multiple-value-bind (data status-code) + (drakma:http-request avatar-url) + (format *debug-io* "~&fetch resulted in status ~A~%" status-code) + (when (eql status-code 200) + (let ((sha1 (sha1-octets data))) + (bind-parameters insert-stmt avatar-url sha1 data) + (sqlite:step-statement insert-stmt) + (values sha1 data)))))))) + +(defun get-contact-avatar-data (uid localpart) + "Get a set of avatar data (returned by GET-AVATAR-DATA) for LOCALPART, a possible contact for the user with ID UID." + (with-prepared-statements + ((get-stmt "SELECT avatar_url FROM user_contacts WHERE user_id = ? AND wa_jid = ?")) + (bind-parameters get-stmt uid localpart) + (when (sqlite:step-statement get-stmt) + (with-bound-columns (avatar-url) get-stmt + (when (and avatar-url (> (length avatar-url) 0) (not (equal avatar-url "NO-AVATAR"))) + (get-avatar-data avatar-url)))))) + +(defun handle-wa-contact-avatar (comp conn jid localpart &key noretry) + "Check whether we need to request an avatar for LOCALPART, or send an update out about one." + (when (uiop:string-prefix-p "other-" localpart) + (return-from handle-wa-contact-avatar)) + (let ((uid (get-user-id jid))) + (assert uid () "No user ID for ~A!" jid) + (with-prepared-statements + ((get-stmt "SELECT avatar_url FROM user_contacts WHERE user_id = ? AND wa_jid = ?")) + (bind-parameters get-stmt uid localpart) + (unless (sqlite:step-statement get-stmt) + (error "No contact with localpart ~A exists!" localpart)) + (with-bound-columns (avatar-url) get-stmt + (if (and avatar-url (> (length avatar-url) 0)) + (with-presence (comp jid + :from (concatenate 'string + localpart + "@" + (component-name comp))) + (cxml:with-element "x" + (cxml:attribute "xmlns" +vcard-avatar-ns+) + (if (equal avatar-url "NO-AVATAR") + (cxml:with-element "photo") + (let ((sha1 (get-avatar-data avatar-url))) + (when sha1 + (cxml:with-element "photo" + (cxml:text sha1))))))) + (progn + (when noretry + (warn "Warning: Not retrying failed avatar request for ~A from ~A" localpart jid) + (return-from handle-wa-contact-avatar)) + (format *debug-io* "~&requesting avatar for ~A from ~A~%" localpart jid) + (whatscl::get-profile-picture conn (whatsxmpp-localpart-to-wa-jid localpart) + (lambda (conn result) + (wa-handle-avatar-result comp conn jid localpart result))))))))) + (defun handle-wa-contact-presence (comp jid localpart) "Check if we need to send out presence subscriptions for LOCALPART." + (when (uiop:string-prefix-p "other-" localpart) + (return-from handle-wa-contact-presence)) (let ((uid (get-user-id jid))) (assert uid () "No user ID for ~A!" jid) (with-prepared-statements @@ -950,7 +1022,16 @@ WhatsXMPP represents users as u440123456789 and groups as g1234-5678." (with-bound-columns (wid) get-stmt wid)))) -(defun add-wa-contact (comp jid contact) +(defun get-contact-localparts (uid) + "Get a list of contact localparts for the user with ID UID." + (with-prepared-statements + ((get-stmt "SELECT wa_jid FROM user_contacts WHERE user_id = ?")) + (bind-parameters get-stmt uid) + (loop + while (sqlite:step-statement get-stmt) + collect (with-bound-columns (localpart) get-stmt localpart)))) + +(defun add-wa-contact (comp conn 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) @@ -958,6 +1039,8 @@ WhatsXMPP represents users as u440123456789 and groups as g1234-5678." contact (let ((uid (get-user-id jid)) (wx-localpart (wa-jid-to-whatsxmpp-localpart ct-jid))) + (unless (uiop:string-prefix-p "u" wx-localpart) + (return-from add-wa-contact)) (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 = ?") @@ -973,19 +1056,20 @@ WhatsXMPP represents users as u440123456789 and groups as g1234-5678." (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))))) + (handle-wa-contact-presence comp jid wx-localpart) + (handle-wa-contact-avatar comp conn 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)))) + do (add-wa-contact comp conn jid contact)))) (defun wa-handle-contact (comp conn jid contact) (with-wa-handler-context (comp conn jid) (format *debug-io* "~&got contact ~A for ~A~%" contact jid) - (add-wa-contact comp jid contact))) + (add-wa-contact comp conn jid contact))) (defun wa-handle-message-ack (comp conn jid &key id ack from to &allow-other-keys) (with-wa-handler-context (comp conn jid) @@ -1033,6 +1117,17 @@ WhatsXMPP represents users as u440123456789 and groups as g1234-5678." :type "modify" :text (write-to-string e))))))) +(defun wa-handle-avatar-result (comp conn jid for-localpart result) + (with-wa-handler-context (comp conn jid) + (format *debug-io* "~&avatar result for ~A from ~A: ~A~%" for-localpart jid result) + (let ((avatar-url (or result "NO-AVATAR")) + (uid (get-user-id jid))) + (with-prepared-statements + ((update-stmt "UPDATE user_contacts SET avatar_url = ? WHERE user_id = ? AND wa_jid = ?")) + (bind-parameters update-stmt avatar-url uid for-localpart) + (sqlite:step-statement update-stmt) + (handle-wa-contact-avatar comp conn jid for-localpart :noretry t))))) + (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) @@ -1088,9 +1183,29 @@ WhatsXMPP represents users as u440123456789 and groups as g1234-5678." (insert-stmt "INSERT INTO users (jid) VALUES (?) ON CONFLICT (jid) DO UPDATE SET session_data = ''") (bind-parameters insert-stmt stripped) (sqlite:step-statement insert-stmt)) + (with-presence (comp stripped + :type "subscribe" + :from (admin-jid comp)) + (cxml:with-element "status" + (cxml:text "Please add the whatsxmpp admin user to your roster; if you don't, things will probably break in various fun ways.") + (cxml:with-element "nick" + (cxml:attribute "xmlns" +nick-ns+) + (cxml:text "whatsxmpp admin")))) (admin-msg comp jid "WhatsApp connection should begin shortly...") (handle-setup-user comp stripped)))) +(defun get-admin-status (comp jid) + "Get the status text of the admin user for the user with ID JID. Returns a value as second value." + (multiple-value-bind (conn exists-p) + (gethash jid (component-whatsapps comp)) + (cond + ((and conn (whatscl::wac-jid conn)) + (format nil "Connected and logged in as ~A." + (whatscl::wac-jid conn))) + (conn (values "Connected, but not logged in." "away")) + (exists-p (values "Temporarily disconnected." "away")) + (t (values "Disconnected (automatic reconnections disabled)." "xa"))))) + (defun handle-admin-command (comp from body uid) "Handles an admin command sent to COMP." (labels ((reply (text) @@ -1109,16 +1224,7 @@ WhatsXMPP represents users as u440123456789 and groups as g1234-5678." ((not uid) (reply "You're not registered with this bridge. Try `register` or `help`.")) ((equal body "status") - (multiple-value-bind (conn exists-p) - (gethash stripped (component-whatsapps comp)) - (reply - (cond - ((and conn (whatscl::wac-jid conn)) - (format nil "Connected and logged in as ~A." - (whatscl::wac-jid conn))) - (conn "Connected, but not logged in.") - (exists-p "Temporarily disconnected.") - (t "Disconnected (automatic reconnections disabled)."))))) + (reply (get-admin-status comp stripped))) ((equal body "connect") (handle-setup-user comp stripped)) ((equal body "stop") @@ -1135,8 +1241,8 @@ WhatsXMPP represents users as u440123456789 and groups as g1234-5678." (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 + (to-localpart (nth-value 1 (parse-jid to)))) + (multiple-value-bind (name avatar-data) (cond ((equal to-localpart "admin") "whatsxmpp admin") @@ -1152,22 +1258,75 @@ WhatsXMPP represents users as u440123456789 and groups as g1234-5678." :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))))))) + (values name + (nth-value 1 (get-contact-avatar-data uid to-localpart)))))) + `((cxml:with-element "vCard" + (cxml:attribute "xmlns" +vcard-temp-ns+) + (cxml:with-element "FN" + (cxml:text ,name)) + (cxml:with-element "NICKNAME" + (cxml:text ,name)) + ,(when avatar-data + `(cxml:with-element "PHOTO" + (cxml:with-element "TYPE" + (cxml:text "image/jpeg")) + (cxml:with-element "BINVAL" + (cxml:text ,(qbase64:encode-bytes avatar-data))))))))))) + +(defun whatsxmpp-presence-handler (comp &key from to type &allow-other-keys) + "Handles a presence broadcast." + (unless (or (not type) (eql (length type) 0)) + (return-from whatsxmpp-presence-handler)) + (with-component-data-lock (comp) + (multiple-value-bind (to-hostname to-localpart) + (parse-jid to) + (declare (ignore to-hostname)) + (format *debug-io* "~&presence to: ~A from: ~A~%" to from) + (when (equal to-localpart "admin") + (let* ((stripped (strip-resource from)) + (conn (gethash stripped (component-whatsapps comp))) + (uid (get-user-id stripped))) + (unless uid + (return-from whatsxmpp-presence-handler)) + (multiple-value-bind (admin-status admin-show) + (get-admin-status comp stripped) + (format *debug-io* "~&sending presences of everyone to ~A~%" from) + (admin-presence comp from admin-status admin-show) + (when conn + (loop + for localpart in (get-contact-localparts uid) + do (handle-wa-contact-avatar comp conn stripped localpart))))))))) + +(defun whatsxmpp-presence-probe-handler (comp &key from to id &allow-other-keys) + "Handles presence probe requests." + (with-component-data-lock (comp) + (multiple-value-bind (to-hostname to-localpart) + (parse-jid to) + (declare (ignore to-hostname)) + (format *debug-io* "~&presence probe to: ~A from: ~A~%" to from) + (let* ((stripped (strip-resource from)) + (uid (get-user-id stripped)) + (conn (gethash stripped (component-whatsapps comp)))) + (flet ((respond-with-unavailable () + (with-presence (comp from + :from to + :type "unavailable" + :id id)))) + (cond + ((equal to-localpart "admin") + (multiple-value-bind (admin-status admin-show) + (get-admin-status comp stripped) + (admin-presence comp from admin-status admin-show))) + ((or (not uid) (not conn)) (respond-with-unavailable)) + ((get-contact-name uid to-localpart) + (handle-wa-contact-avatar comp conn stripped to-localpart)) + (t (respond-with-unavailable)))))))) (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) @@ -1186,9 +1345,7 @@ WhatsXMPP represents users as u440123456789 and groups as g1234-5678." (with-component-data-lock (comp) (multiple-value-bind (to-hostname to-localpart) (parse-jid to) - (unless (equal to-hostname (component-name comp)) - (warn "Got message addressed to ~A!" to) - (return-from whatsxmpp-marker-handler)) + (declare (ignore to-hostname)) (format *debug-io* "~&marker: ~A on ~A from ~A~%" type marker-id from) (unless (equal type "displayed") (return-from whatsxmpp-marker-handler)) @@ -1199,6 +1356,8 @@ WhatsXMPP represents users as u440123456789 and groups as g1234-5678." (unless uid (warn "Got marker for user that isn't registered") (return-from whatsxmpp-marker-handler)) + (unless wa-jid + (return-from whatsxmpp-marker-handler)) (unless conn (warn "Can't send marker, since user connection is offline") (send-stanza-error comp @@ -1221,9 +1380,7 @@ WhatsXMPP represents users as u440123456789 and groups as g1234-5678." (with-component-data-lock (comp) (multiple-value-bind (to-hostname to-localpart) (parse-jid to) - (unless (equal to-hostname (component-name comp)) - (warn "Got message addressed to ~A!" to) - (return-from whatsxmpp-message-handler)) + (declare (ignore to-hostname)) (format *debug-io* "~&message from: ~A~%" from) (let* ((stripped (strip-resource from)) (uid (get-user-id stripped)) @@ -1294,6 +1451,10 @@ WhatsXMPP represents users as u440123456789 and groups as g1234-5678." (apply #'whatsxmpp-marker-handler ret args))) (on :presence-subscribe ret (lambda (&rest args) (apply #'whatsxmpp-presence-subscribe-handler ret args))) + (on :presence-probe ret (lambda (&rest args) + (apply #'whatsxmpp-presence-probe-handler ret args))) + (on :presence ret (lambda (&rest args) + (apply #'whatsxmpp-presence-handler ret args))) (register-whatsxmpp-handlers ret) (whatsxmpp-load-users ret) (setf (component-reconnect-timer ret) (trivial-timers:make-timer