From 8bcb8fb88f7039404e01eeac8814564062ecf350 Mon Sep 17 00:00:00 2001
From: Coin Okay <cbeok@protonmail.com>
Date: Wed, 22 Apr 2020 21:06:03 -0500
Subject: multipart/form-data decoder

---
 decoders.lisp | 109 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 109 insertions(+)
 create mode 100644 decoders.lisp

(limited to 'decoders.lisp')

diff --git a/decoders.lisp b/decoders.lisp
new file mode 100644
index 0000000..e4dcc8c
--- /dev/null
+++ b/decoders.lisp
@@ -0,0 +1,109 @@
+
+(in-package #:lazybones.decoders)
+
+(defun read-body-to-string (stream content-length)
+  "Reads CONTENT-LENGTH characters from STREAM and returns a string."
+  (let ((string (make-string content-length)))
+    (read-sequence string stream)
+    string))
+
+
+;;; JSON DECODER
+
+(defun decode-json-body (stream content-type content-length)
+  "Reads LEN characters from stream and decodes them as JSON, returning a PLIST"
+  (declare (ignore content-type))
+  (jonathan:parse (read-body-to-string stream content-length)))
+
+(add-decoder "application/json" #'decode-json-body)
+
+
+;;; MULTIPART/FORM-DATA DECODER
+
+
+(defun butlast-to-string (res)
+  (map 'string 'identity (butlast res)))
+
+(defun make-keyword (str)
+  (read-from-string (format nil ":~a" str)))
+
+(defun write-image-to-tmp-file (body)
+  (cl-fad:with-output-to-temporary-file (out-file :element-type '(unsigned-byte 8))
+    (loop :for char :across body :do (write-byte (char-int char) out-file))))
+
+(defun dump-stream-to-text (stream)
+  (with-output-to-string (out)
+    (loop :for char = (read-char stream nil nil)
+         :while char :do (write-char char out))))
+
+(<<def <crlf< (<<and (<<char #\Return)
+                     (<<char #\Newline))
+       "Matches the standard CRLF line ending used by HTTP")
+
+
+(<<def <word-plus<
+       (<<to-string (<<+  (<<or parzival:<alphanum< (<<any-char "-_/. "))))
+       "parses a word like foo-bar or foo-bar-zoo4")
+
+
+(<<def <key-equal-val<
+       (<<let ((key (<<and parzival:<whitespace< <word-plus<))
+               (val (<<and (<<char #\=)
+                           (<<char-brackets #\" <word-plus< #\"))))
+              (<<result (list (make-keyword key) val)))
+       "Parses strings that look like foo-bar=\"goo\" and returns a list (:foo-bar \"goo\")")
+
+
+(<<def <multipart-header-content-disposition<
+       (<<map
+        (lambda (pairs)  (apply 'append pairs))
+        (<<and (<<string "Content-Disposition: form-data; ")
+               (<<sep-by <key-equal-val<  (<<string "; "))))
+       
+       "Parses a Content-Disposition header in a multipart/form-data block. 
+Returns a PLIST with one property, the value of which is also a PLIST.
+
+E.g.      Content-Disposition: form-data; name=\"file\"; filename=\"mypic.png\" 
+becomes   (:content-disposition (:name \"file\" :filename \"mypic.png\"))")
+
+(<<def <multipart-header<
+       (<<let ((header <word-plus<)
+               (value  (<<map #'butlast-to-string
+                              (<<and (<<char #\:)
+                                     (<<until <crlf<)))))
+              (<<result (list (make-keyword header)
+                              (string-trim '(#\Space) value)))))
+
+
+(defun <<multipart/form-data-part (stop-seq)
+  (<<let ((disp (<<and (<<? <crlf<)
+                       <multipart-header-content-disposition<))
+          (headers (<<and <crlf<  (<<* <multipart-header<)))
+          (body (<<and <crlf<
+                       (<<map #'butlast-to-string
+                              (<<until (<<and <crlf<
+                                              (<<string stop-seq)))))))
+         (<<result
+          (let ((all-headers (nconc disp (apply 'append  headers))))
+            (if (getf all-headers :content-type)
+                (nconc all-headers (list :body (write-image-to-tmp-file body)))
+                (nconc all-headers (list :body body)))))))
+
+
+
+(defun <<multipart/form-data (boundary)
+  (<<let ((parts (<<and (<<string boundary)
+                        <crlf<
+                        (<<+ (<<multipart/form-data-part boundary))))
+          (ending (<<and (<<string "--") <crlf<)) )
+         (<<result parts)))
+
+(defun decode-multipart/form-data (stream content-type content-length)
+  (declare (ignore content-length))
+  (let* ((boundary (concatenate 'string "--"
+                                (second (split-sequence:split-sequence #\= content-type))))
+         (stream (make-instance 'replay-streams:static-text-replay-stream
+                                :text (dump-stream-to-text stream))))
+    (parse stream (<<multipart/form-data boundary))))
+
+(add-decoder "multipart/form-data" #'decode-multipart/form-data)
-- 
cgit v1.2.3