Upload and send images natively (!); don't block on QR code

- This commit contains initial support for uploading and sending images natively
  -- i.e. a WhatsApp image upload, instead of sending through a bare link.
- All images supported by the OPTICL library are supported; this is because WA
  needs us to generate a jpeg thumbnail for the image (which can probably be
  made smaller)
- Importantly, this functionality is currently a trivial DoS vector: simply send
  a large file (or an infinite file, like time.gif) and it ALL gets downloaded
  and buffered into RAM...!
  - At least this is limited to users who have actually registered with the
    bridge.
- Failing to send the image in any way results in an XMPP error getting reported
  back to the sender.
- Also, the initial registration QR code upload thing now happens in another
  thread.

component.lisp

@@ -296,14 +296,17 @@
          (children (child-elements stanza))
          (body (get-node-named children "body"))
          (marker (get-node-with-xmlns children +chat-markers-ns+))
+         (oob-element (get-node-with-xmlns children +oob-ns+))
+         (oob-url-element (when oob-element
+                            (get-node-named (child-elements oob-element) "url")))
          (chat-state (get-node-with-xmlns children +chat-states-ns+)))
     (cond
       (body
-       (let* ((child-nodes (dom:child-nodes body))
+       (let* ((text (get-node-text body))
-              (text (if (> (length child-nodes) 0)
+              (oob-url (when oob-url-element
-                        (dom:node-value (elt child-nodes 0))
+                         (get-node-text oob-url-element))))
-                        "")))
+         (emit :text-message comp :from from :to to :body text :id id :stanza stanza
-         (emit :text-message comp :from from :to to :body text :id id :stanza stanza)))
+               :oob-url oob-url)))
       (marker
        (let ((marker-type (dom:tag-name marker))
              (msgid (dom:get-attribute marker "id")))

default.nix

@@ -153,6 +153,40 @@ let
         "png.lisp"
       ];
     };
+    zpb-exif = let
+      src = builtins.fetchTarball {
+        url = "https://www.xach.com/lisp/zpb-exif.tgz";
+        sha256 = "15s227jhby55cisz14xafb0p1ws2jmrg2rrbbd00lrb97im84hy6";
+      };
+    in buildLisp.library {
+      name = "zpb-exif";
+      deps = [ salza2 ];
+      srcs = map (f: src + ("/" + f)) [
+        "exif.lisp"
+      ];
+    };
+    skippy = let
+      src = builtins.fetchTarball {
+        url = "https://www.xach.com/lisp/skippy.tgz";
+        sha256 = "1n8925qz19w00qc67z3hc97fpmfhi0r54dd50fzqm24vhyb7qwc2";
+      };
+    in buildLisp.library {
+      name = "skippy";
+      deps = [ salza2 ];
+      srcs = map (f: src + ("/" + f)) [
+        "package.lisp"
+        "conditions.lisp"
+        "types.lisp"
+        "bitstream.lisp"
+        "lzw.lisp"
+        "color-table.lisp"
+        "canvas.lisp"
+        "data-stream.lisp"
+        "image.lisp"
+        "gif89a.lisp"
+        "load-gif.lisp"
+      ];
+    };
     puri = let
       src = builtins.fetchTarball {
         url = "http://files.kpe.io/puri/puri-1.5.7.tar.gz";
@@ -515,6 +549,279 @@ let
         "util.lisp"
       ];
     };
+    com-gigamonkeys-binary-data = let
+      src = depot.third_party.fetchFromGitHub {
+        owner = "gigamonkey";
+        repo = "monkeylib-binary-data";
+        rev = "22e908976d7f3e2318b7168909f911b4a00963ee";
+        sha256 = "072v417vmcnvmyh8ddq9vmwwrizm7zwz9dpzi14qy9nsw8q649zw";
+      };
+    in buildLisp.library {
+      name = "com.gigamonkeys.binary-data";
+      deps = [ alexandria ];
+      srcs = map (f: src + ("/" + f)) [
+        "packages.lisp"
+        "binary-data.lisp"
+        "common-datatypes.lisp"
+      ];
+    };
+    ieee-floats = let
+      src = depot.third_party.fetchFromGitHub {
+        owner = "marijnh";
+        repo = "ieee-floats";
+        rev = "566b51a005e81ff618554b9b2f0b795d3b29398d";
+        sha256 = "1xyj49j9x3lc84cv3dhbf9ja34ywjk1c46dklx425fxw9mkwm83m";
+      };
+    in buildLisp.library {
+      name = "ieee-floats";
+      deps = [];
+      srcs = map (f: src + ("/" + f)) [
+        "ieee-floats.lisp"
+      ];
+    };
+    cl-jpeg = let
+      src = depot.third_party.fetchFromGitHub {
+        owner = "sharplispers";
+        repo = "cl-jpeg";
+        rev = "ec557038128df6895fbfb743bfe8faf8ec2534af";
+        sha256 = "1bkkiqz8fqldlj1wbmrccjsvxcwj98h6s4b6gslr3cg2wmdv5xmy";
+      };
+    in buildLisp.library {
+      name = "cl-jpeg";
+      deps = [];
+      srcs = map (f: src + ("/" + f)) [
+        "package.lisp"
+        "jpeg.lisp"
+        "io.lisp"
+      ];
+    };
+    deflate = let
+      src = depot.third_party.fetchFromGitHub {
+        owner = "pmai";
+        repo = "deflate";
+        rev = "fb940e63b89a6c4d168153dbf046552e106eb8a5";
+        sha256 = "1jpdjnxh6cw2d8hk70r2sxn92is52s9b855irvwkdd777fdciids";
+      };
+    in buildLisp.library {
+      name = "deflate";
+      deps = [];
+      srcs = map (f: src + ("/" + f)) [
+        "deflate.lisp"
+      ];
+    };
+    trivial-features = let
+      src = depot.third_party.fetchFromGitHub {
+        owner = "trivial-features";
+        repo = "trivial-features";
+        rev = "e7bb968d1e0b00aaf06e0671a866a81dbfe99bee";
+        sha256 = "1iczrsl561fz9f71dzals16749fccznm4jn8nmxnqas1qk7b331k";
+      };
+    in buildLisp.library {
+      name = "trivial-features";
+      deps = [];
+      srcs = map (f: src + ("/src/" + f)) [
+        "tf-sbcl.lisp"
+      ];
+    };
+    opticl-core = let
+      src = depot.third_party.fetchFromGitHub {
+        owner = "slyrus";
+        repo = "opticl-core";
+        rev = "b7cd13d26df6b824b216fbc360dc27bfadf04999";
+        sha256 = "0458bllabcdjghfrqx6aki49c9qmvfmkk8jl75cfpi7q0i12kh95";
+      };
+    in buildLisp.library {
+      name = "opticl-core";
+      deps = [ alexandria ];
+      srcs = map (f: src + ("/" + f)) [
+        "package.lisp"
+        "opticl-core.lisp"
+      ];
+    };
+    retrospectiff = let
+      src = depot.third_party.fetchFromGitHub {
+        owner = "slyrus";
+        repo = "retrospectiff";
+        rev = "c2a69d77d5010f8cdd9045b3e36a08a73da5d321";
+        sha256 = "0qsn9hpd8j2kp43dk05j8dczz9zppdff5rrclbp45n3ksk9inw8i";
+      };
+    in buildLisp.library {
+      name = "retrospectiff";
+      deps = [ com-gigamonkeys-binary-data flexi-streams ieee-floats cl-jpeg deflate opticl-core ];
+      srcs = map (f: src + ("/" + f)) [
+        "package.lisp"
+        "constants.lisp"
+        "globals.lisp"
+        "util.lisp"
+        "bit-array.lisp"
+        "lzw.lisp"
+        "jpeg.lisp"
+        "deflate.lisp"
+        "packbits.lisp"
+        "compression.lisp"
+        "binary-types.lisp"
+        "ifd.lisp"
+        "tiff-image.lisp"
+        "retrospectiff.lisp"
+        "retrospectiff2.lisp"
+      ];
+    };
+    cl-tga = let
+      src = depot.third_party.fetchFromGitHub {
+        owner = "fisxoj";
+        repo = "cl-tga";
+        rev = "4dc2f7b8a259b9360862306640a07a23d4afaacc";
+        sha256 = "03k3npmn0xd3fd2m7vwxph82av2xrfb150imqrinlzqmzvz1v1br";
+      };
+    in buildLisp.library {
+      name = "cl-tga";
+      deps = [];
+      srcs = map (f: src + ("/" + f)) [
+        "package.lisp"
+        "cl-tga.lisp"
+      ];
+    };
+    mmap = let
+      src = depot.third_party.fetchFromGitHub {
+        owner = "Shinmera";
+        repo = "mmap";
+        rev = "ba2e98c67e25f0fb8ff838238561120a23903ce7";
+        sha256 = "0qd0xp20i1pcfn12kkapv9pirb6hd4ns7kz4zf1mmjwykpsln96q";
+      };
+    in buildLisp.library {
+      name = "mmap";
+      deps = [ cffi ];
+      srcs = map (f: src + ("/" + f)) [
+        "package.lisp"
+        "generic.lisp"
+        "posix.lisp"
+      ];
+    };
+    static-vectors = let
+      src = depot.third_party.fetchFromGitHub {
+        owner = "sionescu";
+        repo = "static-vectors";
+        rev = "67f2ed0da2244f3c2a69d3440eddcc14a3ad33f0";
+        sha256 = "0prdwkyggr9wqwr7blhrb3hprsvbcgwn7144f7v4iy7i8621d8pq";
+      };
+    in buildLisp.library {
+      name = "static-vectors";
+      deps = [ alexandria cffi ];
+      srcs = map (f: src + ("/src/" + f)) [
+        "pkgdcl.lisp"
+        "constantp.lisp"
+        "impl-sbcl.lisp"
+        "constructor.lisp"
+        "cffi-type-translator.lisp"
+      ];
+    };
+    swap-bytes = let
+      src = depot.third_party.fetchFromGitHub {
+        owner = "sionescu";
+        repo = "swap-bytes";
+        rev = "253ab928b91b8a1c3cea0434e87b8da5ce3c6014";
+        sha256 = "1rs1166rabdlws4pyvsrwl32x476dh2yw15p56097mp8ixmcb0ap";
+      };
+    in buildLisp.library {
+      name = "swap-bytes";
+      deps = [ trivial-features ];
+      srcs = map (f: src + ("/" + f)) [
+        "package.lisp"
+        "sbcl-defknowns.lisp"
+        "sbcl-vops.lisp"
+        "sbcl.lisp"
+        "network.lisp"
+        "endianness.lisp"
+      ];
+    };
+    threebz = let
+      src = depot.third_party.fetchFromGitHub {
+        owner = "3b";
+        repo = "3bz";
+        rev = "d6119083b5e0b0a6dd3abc2877936c51f3f3deed";
+        sha256 = "0fyxzyf2b6sc0w8d9g4nlva861565z6f3xszj0lw29x526dd9rhj";
+      };
+    in buildLisp.library {
+      name = "3bz";
+      deps = [ alexandria cffi mmap trivial-features nibbles babel ];
+      srcs = map (f: src + ("/" + f)) [
+        "package.lisp"
+        "tuning.lisp"
+        "util.lisp"
+        "constants.lisp"
+        "types.lisp"
+        "huffman-tree.lisp"
+        "ht-constants.lisp"
+        "io-common.lisp"
+        "io-mmap.lisp"
+        "io.lisp"
+        "deflate.lisp"
+        "checksums.lisp"
+        "zlib.lisp"
+        "gzip.lisp"
+        "api.lisp"
+      ];
+    };
+    pngload = let
+      src = depot.third_party.fetchFromGitHub {
+        owner = "bufferswap";
+        repo = "pngload";
+        rev = "b2e56733dd5d86a56b20c665676b86e566b4e223";
+        sha256 = "15dkm3ba7byxk8qs6d3xnd58ybvjl6cjz75392z5fq5cqygbgfq5";
+      };
+    in buildLisp.library {
+      name = "pngload";
+      deps = [ threebz alexandria cffi mmap parse-float static-vectors swap-bytes (buildLisp.bundled "uiop") zpb-exif ];
+      srcs = map (f: src + ("/src/" + f)) [
+        "package.lisp"
+        "common.lisp" # aha!
+        "source.lisp"
+        "source-ffi.lisp"
+        "properties.lisp"
+        "chunk.lisp"
+        "chunk-types.lisp"
+        "conditions.lisp"
+        "datastream.lisp"
+        "deinterlace.lisp"
+        "decode.lisp"
+        "metadata.lisp"
+        "png.lisp"
+        "png-mmap.lisp"
+      ];
+    };
+    opticl = let
+      src = depot.third_party.fetchFromGitHub {
+        owner = "slyrus";
+        repo = "opticl";
+        rev = "438881ae779fa4b113308a3c5c96783fd9618e02";
+        sha256 = "13sv7n1ry8yp3fawvpf3y3kf7abbqxqmk8zpx349k3wh063i7l1l";
+      };
+    in buildLisp.library {
+      name = "opticl";
+      deps = [ alexandria retrospectiff zpng pngload cl-jpeg skippy opticl-core cl-tga ];
+      srcs = map (f: src + ("/" + f)) [
+        "package.lisp"
+        "coerce.lisp"
+        # "colors.lisp"
+        "imageops.lisp"
+        "invert.lisp"
+        "transform.lisp"
+        "convolve.lisp"
+        "morphology.lisp"
+        "gamma.lisp"
+        "shapes.lisp"
+        "tiff.lisp"
+        "jpeg.lisp"
+        "png.lisp"
+        "pngload.lisp"
+        "pnm.lisp"
+        "gif.lisp"
+        "tga.lisp"
+        "io.lisp"
+        "cluster.lisp"
+        "thresholding.lisp"
+      ];
+    };
     nibbles = let
       src = depot.third_party.fetchFromGitHub {
         owner = "sharplispers";
@@ -667,7 +974,7 @@ in
 with lispPkgs;
 buildLisp.program {
   name = "whatsxmpp";
-  deps = [ whatscl blackbird cxml uuid cl-sqlite trivial-mimes drakma cl-qrencode trivial-backtrace ];
+  deps = [ whatscl blackbird cxml uuid cl-sqlite trivial-mimes drakma cl-qrencode trivial-backtrace opticl ];
   srcs = map (f: ./. + ("/" + f)) [
     "packages.lisp"
     "utils.lisp"

media.lisp

@@ -2,6 +2,58 @@
 
 (in-package :whatsxmpp)
 
+(defun squonch-image-to-jpeg-thumbnail (opticl-image)
+  "Resize the provided OPTICL-IMAGE to a small 640x480 thumbnail and return an octet vector of JPEG data for this thumbnail."
+  (check-type opticl-image opticl:image)
+  (let* ((image-out-stream (flexi-streams:make-in-memory-output-stream))
+         (resized-image (opticl:resize-image opticl-image 480 640))
+         (useless (opticl:write-jpeg-stream image-out-stream resized-image)) ; squonch
+         (image-thumbnail (flexi-streams:get-output-stream-sequence image-out-stream)))
+    (declare (ignore useless))
+    (concatenate '(vector (unsigned-byte 8)) image-thumbnail)))
+
+(defun maybe-upload-whatsapp-media (conn media-url)
+  "If the media at MEDIA-URL can be sent natively as a WhatsApp upload, download it and re-host it on WhatsApp.
+Returns a promise that resolves with either a STRING (if the media could not be rehosted or is ineligible) or WHATSCL:MESSAGE-CONTENTS-IMAGE (if the media pointed to is an image and it's been successfully re-uploaded)."
+  (check-type media-url string)
+  (let ((opticl-function (opticl::get-image-stream-reader (pathname-type media-url))))
+    (if opticl-function
+        (attach
+         (download-remote-media media-url)
+         (lambda (media-data)
+           (let* ((image-stream (flexi-streams:make-in-memory-input-stream media-data))
+                  (image-mime (or (trivial-mimes:mime-lookup media-url)
+                                  (error "Couldn't guess image MIME type for ~A" media-url)))
+                  (parsed-image (funcall opticl-function image-stream))
+                  (squonched-image (squonch-image-to-jpeg-thumbnail parsed-image)))
+             (opticl:with-image-bounds (image-y image-x) parsed-image
+               (attach
+                (put-whatsapp-media-file conn media-data :image image-mime)
+                (lambda (file-info)
+                  (make-instance 'whatscl::message-contents-image
+                                 :file-info file-info
+                                 :width-px image-x
+                                 :height-px image-y
+                                 :jpeg-thumbnail squonched-image)))))))
+        (promisify media-url))))
+
+(defun download-remote-media (media-url)
+  "Returns a promise that downloads the remote MEDIA-URL and resolves with an octet vector of the downloaded data."
+  ;; FIXME FIXME FIXME: this function is a trivial DoS vector, if you provide an infinite file like time.gif,
+  ;; or a file that's like 1GB.
+  (check-type media-url string)
+  (with-promise-from-thread ()
+    (format *debug-io* "~&downloading remote media: ~A~%" media-url)
+    (multiple-value-bind (response status-code)
+        (drakma:http-request media-url
+                             :force-binary t)
+      (unless (eql status-code 200)
+        (format *error-output* "~&downloading failed! status ~A~%" status-code)
+        (error "Remote media download failed with status code ~A~~%%" status-code))
+      (check-type response (simple-array (unsigned-byte 8)))
+      (format *debug-io* "~&downloaded ~A (length: ~A)~%" media-url (length response))
+      response)))
+
 (defun put-whatsapp-media-file (conn file-data media-type mime-type)
   "Encrypts and uploads FILE-DATA (an octet vector), a WhatsApp media file of type MEDIA-TYPE (one of :IMAGE, :VIDEO, :AUDIO, or :DOCUMENT) to WhatsApp, returning a promise that resolves with a WHATSCL:FILE-INFO when done."
   (check-type file-data (simple-array (unsigned-byte 8)))
@@ -47,11 +99,11 @@
                  (format *debug-io* "~&got whatsapp uploaded media url ~A~%" url)
                  (make-instance 'whatscl::file-info
                                 :media-key media-key
-                                :url url
+                                :url (pb:string-field url)
                                 :sha256 file-sha256
                                 :enc-sha256 file-enc-sha256
                                 :length-bytes (length encrypted-blob)
-                                :mime-type mime-type))))))))))
+                                :mime-type (pb:string-field mime-type)))))))))))
 
 (defun upload-whatsapp-media-file (comp file-info media-type &optional filename)
   "Downloads the WhatsApp media file specified by FILE-INFO, uploads it via COMP, and returns a promise which resolves to the URL of the uploaded media.
@@ -117,6 +169,7 @@ MEDIA-TYPE is one of (:image :video :audio :document)."
                                     (file-length stream)
                                     "image/png")
           (lambda (slot)
+            (with-promise-from-thread ()
               (destructuring-bind ((put-url . headers) get-url) slot
                 (format *debug-io* "~&got put-url: ~A~%   get-url: ~A~%" put-url get-url)
                 (multiple-value-bind (body status-code)
@@ -139,6 +192,6 @@ MEDIA-TYPE is one of (:image :video :audio :document)."
                           (cxml:attribute "xmlns" +oob-ns+)
                           (cxml:with-element "url"
                             (cxml:text get-url))))
-                    (admin-msg comp jid "(Code expired? Be faster next time. Get a new one with `connect`.)"))))))))
+                      (admin-msg comp jid "(Code expired? Be faster next time. Get a new one with `connect`.)")))))))))
        (t (e)
           (admin-msg comp jid (format nil "Failed to upload QR code!~%Report the following error to the bridge admin: `~A`" e)))))))

stuff.lisp

@@ -1237,7 +1237,7 @@ Returns three values: avatar data (as two values), and a generalized boolean spe
                 (whatscl::send-message-read conn wa-jid wa-msgid))
               (warn "Got marker for unknown XMPP message ID ~A" marker-id)))))))
 
-(defun whatsxmpp-message-handler (comp &key from to body id &allow-other-keys)
+(defun whatsxmpp-message-handler (comp &key from to body id oob-url &allow-other-keys)
   "Handles a message sent to the whatsxmpp bridge."
   (with-component-data-lock (comp)
     (multiple-value-bind (to-hostname to-localpart to-resource)
@@ -1247,7 +1247,8 @@ Returns three values: avatar data (as two values), and a generalized boolean spe
       (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)))
+             (wa-jid (whatsxmpp-localpart-to-wa-jid to-localpart))
+             (user-resource (get-user-chat-resource uid to-localpart)))
         (labels
             ((send-error (e)
                (send-stanza-error comp
@@ -1278,7 +1279,9 @@ Returns three values: avatar data (as two values), and a generalized boolean spe
                                          :text "MUC PMs are (deliberately) not implemented. Message the user directly instead."
                                          :type "cancel")))
             (t
-             (let* ((user-resource (get-user-chat-resource uid to-localpart))
+             (let* ((content-to-send (if oob-url
+                                        (maybe-upload-whatsapp-media conn oob-url)
+                                        (promisify body)))
                     (callback (lambda (conn result)
                                 (wa-handle-message-send-result comp conn stripped
                                                                :orig-from from
@@ -1286,10 +1289,23 @@ Returns three values: avatar data (as two values), and a generalized boolean spe
                                                                :orig-id id
                                                                :orig-body body
                                                                :muc-resource user-resource
-                                                               :result result)))
+                                                               :result result))))
-                    (msgid (whatscl::send-simple-text-message conn wa-jid body callback)))
+               (catcher
+                (attach
+                 content-to-send
+                 (lambda (content)
+                   (let ((msgid
+                           (etypecase content
+                             (whatscl::message-contents-image (whatscl::send-simple-image-message conn wa-jid content callback))
+                             (string (whatscl::send-simple-text-message conn wa-jid content callback)))))
                      (whatscl::send-presence conn :available)
-               (insert-user-message uid id msgid)))))))))
+                     (insert-user-message uid id msgid))))
+                (t (e)
+                   (format *error-output* "~&failed to send message! ~A~%" e)
+                   (send-error (make-condition 'stanza-error
+                                               :defined-condition "internal-server-error"
+                                               :text (princ-to-string e)
+                                               :type "wait"))))))))))))
 
 (defun whatsxmpp-load-users (comp)
   (with-component-data-lock (comp)

whatsxmpp.asd

@@ -1,5 +1,5 @@
 (defsystem "whatsxmpp"
-  :depends-on ("usocket" "bordeaux-threads" "event-emitter" "blackbird" "cxml" "ironclad" "uuid" "sqlite" "whatscl" "drakma" "local-time" "trivial-timers" "trivial-backtrace" "trivial-mimes")
+  :depends-on ("usocket" "bordeaux-threads" "event-emitter" "blackbird" "cxml" "ironclad" "uuid" "sqlite" "whatscl" "drakma" "local-time" "trivial-timers" "trivial-backtrace" "trivial-mimes" "opticl")
   :serial t
   :build-operation "program-op"
   :build-pathname "whatsxmpp"

xmpp.lisp

@@ -63,6 +63,13 @@
   (flet ((is-the-node (node) (and (dom:element-p node) (equal (dom:get-attribute node "xmlns") xmlns))))
     (find-if #'is-the-node nodes)))
 
+(defun get-node-text (node)
+  "Gets the node's text."
+  (let ((child-nodes (dom:child-nodes node)))
+    (if (> (length child-nodes) 0)
+        (dom:node-value (elt child-nodes 0))
+        "")))
+
 (defun handle-stream-error (comp stanza)
   (flet ((is-error-node (node)
            (equal (dom:namespace-uri node) +streams-ns+))