add tests for multipart. it's mostly finished, just needs some cleanups and integration with the web server

basis/mime/multipart/multipart.factor

@@ -1,7 +1,9 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors combinators io kernel locals math multiline
-sequences splitting prettyprint ;
+sequences splitting prettyprint namespaces http.parsers
+ascii assocs unicode.case io.files.unique io.files io.encodings.binary
+byte-arrays io.encodings make fry ;
 IN: mime.multipart
 
 TUPLE: multipart-stream stream n leftover separator ;
@@ -27,37 +29,77 @@ TUPLE: multipart-stream stream n leftover separator ;
 : multipart-split ( bytes separator -- before after seq=? )
     2dup sequence= [ 2drop f f t ] [ split1 f ] if ;
 
-:: multipart-step-found ( bytes stream quot -- ? )
+:: multipart-step-found ( bytes stream quot: ( bytes -- ) -- ? )
-    bytes [
+    bytes [ quot unless-empty ]
-        quot unless-empty
+    [ stream (>>leftover) quot unless-empty ] if-empty f ; inline
-    ] [
-        stream (>>leftover)
-        quot unless-empty
-    ] if-empty f quot call f ;
 
-:: multipart-step-not-found ( stream end-stream? separator quot -- ? )
+:: multipart-step-not-found ( bytes stream end-stream? separator quot: ( bytes -- ) -- ? )
-    end-stream? [
+    bytes end-stream? [
         quot unless-empty f
     ] [
         separator length 1- ?cut* stream (>>leftover)
         quot unless-empty t
-    ] if ;
+    ] if ; inline
 
 :: multipart-step ( stream bytes end-stream? separator quot: ( bytes -- ) -- ? end-stream? )
     #! return t to loop again
     bytes separator multipart-split
-    [ 2drop f quot call f ]
+    [ 2drop f ]
     [
         [ stream quot multipart-step-found ]
         [ stream end-stream? separator quot multipart-step-not-found ] if*
-    ] if stream leftover>> end-stream? not or ;
+    ] if stream leftover>> end-stream? not or >boolean ;
+
+
+:: multipart-step-loop ( stream quot1: ( bytes -- ) -- ? )
+    stream dup [ read-n ] [ separator>> ] bi quot1 multipart-step
+    swap [ drop stream quot1 multipart-step-loop ] when ; inline recursive
 
 PRIVATE>
 
-:: multipart-step-loop ( stream quot1: ( bytes -- ) quot2: ( -- ) -- ? )
+SYMBOL: header
-    stream dup [ read-n ] [ separator>> ] bi quot1 multipart-step
+SYMBOL: parsed-header
-    swap [ drop stream quot1 quot2 multipart-step-loop ] quot2 if ;
+SYMBOL: magic-separator
 
-: multipart-loop-all ( stream quot1: ( bytes -- ) quot2: ( -- ) -- )
+: trim-blanks ( str -- str' ) [ blank? ] trim ;
-    3dup multipart-step-loop
+
-    [ multipart-loop-all ] [ 3drop ] if ;
+: trim-quotes ( str -- str' )
+    [ [ CHAR: " = ] [ CHAR: ' = ] bi or ] trim ;
+
+: parse-content-disposition ( str -- content-disposition hash )
+    ";" split [ first ] [ rest-slice ] bi [ "=" split ] map
+    [ [ trim-blanks ] [ trim-quotes ] bi* ] H{ } assoc-map-as ;
+
+: parse-multipart-header ( string -- headers )
+    "\r\n" split harvest
+    [ parse-header-line first2 ] H{ } map>assoc ;
+
+ERROR: expected-file ;
+
+TUPLE: uploaded-file path filename name ;
+
+: (parse-multipart) ( stream -- ? )
+    "\r\n\r\n" >>separator
+    header off
+    dup [ header [ prepend ] change ] multipart-step-loop drop
+    header get dup magic-separator get [ length ] bi@ < [
+        2drop f
+    ] [
+        parse-multipart-header
+        parsed-header set
+        "\r\n" magic-separator get append >>separator
+        "factor-upload" "httpd" make-unique-file tuck
+        binary [ [ write ] multipart-step-loop ] with-file-writer swap
+        "content-disposition" parsed-header get at parse-content-disposition
+        nip [ "filename" swap at ] [ "name" swap at ] bi
+        uploaded-file boa ,
+    ] if ;
+
+: parse-multipart ( stream -- array )
+    [
+        "\r\n" <multipart-stream>
+        magic-separator off
+        dup [ magic-separator [ prepend ] change ]
+            multipart-step-loop drop
+        '[ [ _ (parse-multipart) ] loop ] { } make
+    ] with-scope ;