add tests for multipart. it's mostly finished, just needs some cleanups and integration with the web server
parent
b9432c3d01
commit
eb7a344e00
File diff suppressed because it is too large
Load Diff
|
@ -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 -- ? )
|
||||
bytes [
|
||||
quot unless-empty
|
||||
] [
|
||||
stream (>>leftover)
|
||||
quot unless-empty
|
||||
] if-empty f quot call f ;
|
||||
:: multipart-step-found ( bytes stream quot: ( bytes -- ) -- ? )
|
||||
bytes [ quot unless-empty ]
|
||||
[ stream (>>leftover) quot unless-empty ] if-empty f ; inline
|
||||
|
||||
:: multipart-step-not-found ( stream end-stream? separator quot -- ? )
|
||||
end-stream? [
|
||||
:: multipart-step-not-found ( bytes stream end-stream? separator quot: ( bytes -- ) -- ? )
|
||||
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: ( -- ) -- ? )
|
||||
stream dup [ read-n ] [ separator>> ] bi quot1 multipart-step
|
||||
swap [ drop stream quot1 quot2 multipart-step-loop ] quot2 if ;
|
||||
SYMBOL: header
|
||||
SYMBOL: parsed-header
|
||||
SYMBOL: magic-separator
|
||||
|
||||
: multipart-loop-all ( stream quot1: ( bytes -- ) quot2: ( -- ) -- )
|
||||
3dup multipart-step-loop
|
||||
[ multipart-loop-all ] [ 3drop ] if ;
|
||||
: trim-blanks ( str -- str' ) [ blank? ] trim ;
|
||||
|
||||
: 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 ;
|
||||
|
|
Loading…
Reference in New Issue