Handle avatars (!) and various types of presence requests

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
+);

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)))))))

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)
+(defun sha1-octets (buf)
-  "Returns the SHA1 of STR, a string, in lowercase hex."
+  "Returns the SHA1 of BUF, a vector of octets, in lowercase hex."
   (format nil "~(~{~2,'0X~}~)"
           (coerce
-           (ironclad:digest-sequence :sha1
+           (ironclad:digest-sequence :sha1 buf)
-                                     (babel:string-to-octets str))
            '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 <show/> 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)
+         (reply (get-admin-status comp stripped)))
-             (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).")))))
         ((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)))
+           (to-localpart (nth-value 1 (parse-jid to))))
-           (name
+      (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)))))
+                  (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)))))))
+              (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))
+      (declare (ignore to-hostname))
-        (warn "Got message addressed to ~A!" to)
-        (return-from whatsxmpp-marker-handler))
       (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))
+      (declare (ignore to-hostname))
-        (warn "Got message addressed to ~A!" to)
-        (return-from whatsxmpp-message-handler))
       (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