multipart/form-data decoder

4 files changed, 114 insertions, 6 deletions

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)
diff --git a/lazybones.asd b/lazybones.asd
index d792750..d2c2de3 100644
--- a/lazybones.asd
+++ b/lazybones.asd
@@ -6,7 +6,7 @@
   :license  "Specify license here"
   :version "0.0.1"
   :serial t
-  :depends-on (#:clack #:jonathan  #:alexandria #:split-sequence)
+  :depends-on (#:clack #:jonathan  #:alexandria #:split-sequence #:parzival #:cl-fad)
   :components ((:file "package")
                (:file "lazybones")
                (:file "decoders")))
diff --git a/lazybones.lisp b/lazybones.lisp
index e762f03..f26e87a 100644
--- a/lazybones.lisp
+++ b/lazybones.lisp
@@ -44,16 +44,15 @@ definition."
           *decoders*)))
 
 
-
-
 (defun decode-body (stream content-type content-length)
   "Decodes the body according to the Content-Type header.
 
 If no matching decoder is found in the *DECODERS* ALIST, then the 
 STREAM itself is returned unaltered.
 "
-  (if-let ((decoder (assoc content-type *decoders* :test (lambda (ct key) (starts-with-subseq key ct)))))
-    (funcall (cdr decoder) stream  content-length)
+  (if-let ((decoder (assoc content-type *decoders*
+                           :test (lambda (ct key) (starts-with-subseq key ct)))))
+    (funcall (cdr decoder) stream  content-type content-length)
     stream))
 
 
diff --git a/package.lisp b/package.lisp
index 4a15d03..6e0ab3d 100644
--- a/package.lisp
+++ b/package.lisp
@@ -24,6 +24,6 @@
    ))
 
 (defpackage #:lazybones.decoders
-  (:use #:cl)
+  (:use #:cl #:parzival)
   (:import-from #:lazybones
                 #:add-decoder))