From 83d172f8991664937425385e6c5bed5166823b0a Mon Sep 17 00:00:00 2001 From: eta Date: Tue, 1 Sep 2020 20:01:02 +0100 Subject: [PATCH] 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 | 13 ++- default.nix | 309 ++++++++++++++++++++++++++++++++++++++++++++++++- media.lisp | 103 +++++++++++++---- stuff.lisp | 30 +++-- whatsxmpp.asd | 2 +- xmpp.lisp | 7 ++ 6 files changed, 425 insertions(+), 39 deletions(-) diff --git a/component.lisp b/component.lisp index d058709..4fa3a88 100644 --- a/component.lisp +++ b/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)) - (text (if (> (length child-nodes) 0) - (dom:node-value (elt child-nodes 0)) - ""))) - (emit :text-message comp :from from :to to :body text :id id :stanza stanza))) + (let* ((text (get-node-text body)) + (oob-url (when oob-url-element + (get-node-text oob-url-element)))) + (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"))) diff --git a/default.nix b/default.nix index f686b82..8845dfc 100644 --- a/default.nix +++ b/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" diff --git a/media.lisp b/media.lisp index 0f4361a..36057e3 100644 --- a/media.lisp +++ b/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,28 +169,29 @@ MEDIA-TYPE is one of (:image :video :audio :document)." (file-length stream) "image/png") (lambda (slot) - (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) - (drakma:http-request put-url - :additional-headers headers - :content-type "image/png" - :content-length content-length - :method :put - :content path) - (unless (and (>= status-code 200) (< status-code 300)) - (format *debug-io* "~&upload failed! status ~A, body ~A~%" status-code body) - (error "HTTP upload failed with status ~A" status-code)) - (with-component-data-lock (comp) - (let ((ajid (admin-jid comp))) - (admin-msg comp jid "WhatsApp Web registration: Scan the following QR code with your device! (Menu -> WhatsApp Web)") - (with-message (comp jid :from ajid) - (cxml:with-element "body" - (cxml:text get-url)) - (cxml:with-element "x" - (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`.)")))))))) + (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) + (drakma:http-request put-url + :additional-headers headers + :content-type "image/png" + :content-length content-length + :method :put + :content path) + (unless (and (>= status-code 200) (< status-code 300)) + (format *debug-io* "~&upload failed! status ~A, body ~A~%" status-code body) + (error "HTTP upload failed with status ~A" status-code)) + (with-component-data-lock (comp) + (let ((ajid (admin-jid comp))) + (admin-msg comp jid "WhatsApp Web registration: Scan the following QR code with your device! (Menu -> WhatsApp Web)") + (with-message (comp jid :from ajid) + (cxml:with-element "body" + (cxml:text get-url)) + (cxml:with-element "x" + (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`.)"))))))))) (t (e) (admin-msg comp jid (format nil "Failed to upload QR code!~%Report the following error to the bridge admin: `~A`" e))))))) diff --git a/stuff.lisp b/stuff.lisp index 3d6f89e..8b744ea 100644 --- a/stuff.lisp +++ b/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))) - (msgid (whatscl::send-simple-text-message conn wa-jid body callback))) - (whatscl::send-presence conn :available) - (insert-user-message uid id msgid))))))))) + :result result)))) + (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)))) + (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) diff --git a/whatsxmpp.asd b/whatsxmpp.asd index b691020..5d14756 100644 --- a/whatsxmpp.asd +++ b/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" diff --git a/xmpp.lisp b/xmpp.lisp index 3fd224d..0cfa4bb 100644 --- a/xmpp.lisp +++ b/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+))