a3x
/
whatsxmpp
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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.
This commit is contained in:
eta 2020-09-01 20:01:02 +01:00
parent acfa5c236d
commit 83d172f899
6 changed files with 425 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
component.lisp
View File

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

309
default.nix
View File

@ -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"

103
media.lisp
View File

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

30
stuff.lisp
View File

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

2
whatsxmpp.asd
View File

@ -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"

7
xmpp.lisp
View File

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