redo mime.multipart
U-C4\Administrator
parent
e4d3472ad3
commit
07fc5f3ff4
File diff suppressed because it is too large
Load Diff
|
|
@ -1,105 +1,164 @@
|
||||||
! Copyright (C) 2008 Doug Coleman.
|
! Copyright (C) 2009 Doug Coleman.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors combinators io kernel locals math multiline
|
USING: multiline kernel sequences io splitting fry namespaces
|
||||||
sequences splitting prettyprint namespaces http.parsers
|
http.parsers hashtables assocs combinators ascii io.files.unique
|
||||||
ascii assocs unicode.case io.files.unique io.files io.encodings.binary
|
accessors io.encodings.binary io.files byte-arrays math
|
||||||
byte-arrays io.encodings make fry ;
|
io.streams.string combinators.short-circuit strings ;
|
||||||
IN: mime.multipart
|
IN: mime.multipart
|
||||||
|
|
||||||
TUPLE: multipart-stream stream n leftover separator ;
|
CONSTANT: buffer-size 65536
|
||||||
|
CONSTANT: separator-prefix "\r\n--"
|
||||||
|
|
||||||
: <multipart-stream> ( stream separator -- multipart-stream )
|
TUPLE: multipart
|
||||||
multipart-stream new
|
end-of-stream?
|
||||||
swap >>separator
|
current-separator mime-separator
|
||||||
swap >>stream
|
header
|
||||||
16 2^ >>n ;
|
content-disposition bytes
|
||||||
|
filename temp-file
|
||||||
|
name name-content
|
||||||
|
uploaded-files
|
||||||
|
form-variables ;
|
||||||
|
|
||||||
<PRIVATE
|
TUPLE: mime-file headers filename temporary-path ;
|
||||||
|
TUPLE: mime-variable headers key value ;
|
||||||
|
|
||||||
: ?append ( seq1 seq2 -- newseq/seq2 )
|
: <multipart> ( mime-separator -- multipart )
|
||||||
over [ append ] [ nip ] if ;
|
multipart new
|
||||||
|
swap >>mime-separator
|
||||||
|
H{ } clone >>uploaded-files
|
||||||
|
H{ } clone >>form-variables ;
|
||||||
|
|
||||||
: ?cut* ( seq n -- before after )
|
ERROR: bad-header bytes ;
|
||||||
over length over <= [ drop f swap ] [ cut* ] if ;
|
|
||||||
|
|
||||||
: read-n ( stream -- bytes end-stream? )
|
: mime-write ( sequence -- )
|
||||||
[ f ] change-leftover
|
>byte-array write ;
|
||||||
[ n>> ] [ stream>> ] bi stream-read [ ?append ] keep not ;
|
|
||||||
|
|
||||||
: multipart-split ( bytes separator -- before after seq=? )
|
: parse-headers ( string -- sequence )
|
||||||
2dup sequence= [ 2drop f f t ] [ split1 f ] if ;
|
string-lines harvest [ parse-header-line ] map ;
|
||||||
|
|
||||||
:: multipart-step-found ( bytes stream quot: ( bytes -- ) -- ? )
|
ERROR: end-of-stream multipart ;
|
||||||
bytes [ quot unless-empty ]
|
|
||||||
[ stream (>>leftover) quot unless-empty ] if-empty f ; inline
|
|
||||||
|
|
||||||
:: multipart-step-not-found ( bytes stream end-stream? separator quot: ( bytes -- ) -- ? )
|
: fill-bytes ( multipart -- multipart )
|
||||||
bytes end-stream? [
|
buffer-size read
|
||||||
quot unless-empty f
|
[ '[ _ append ] change-bytes ]
|
||||||
|
[ t >>end-of-stream? ] if* ;
|
||||||
|
|
||||||
|
: maybe-fill-bytes ( multipart -- multipart )
|
||||||
|
dup bytes>> [ fill-bytes ] unless ;
|
||||||
|
|
||||||
|
: split-bytes ( bytes separator -- leftover-bytes safe-to-dump )
|
||||||
|
2dup [ length ] [ length 1- ] bi* < [
|
||||||
|
drop f
|
||||||
] [
|
] [
|
||||||
separator length 1- ?cut* stream (>>leftover)
|
length 1- cut-slice swap
|
||||||
quot unless-empty t
|
|
||||||
] if ; inline
|
|
||||||
|
|
||||||
:: multipart-step ( stream bytes end-stream? separator quot: ( bytes -- ) -- ? end-stream? )
|
|
||||||
#! return t to loop again
|
|
||||||
bytes separator multipart-split
|
|
||||||
[ 2drop f ]
|
|
||||||
[
|
|
||||||
[ stream quot multipart-step-found ]
|
|
||||||
[ stream end-stream? separator quot multipart-step-not-found ] if*
|
|
||||||
] 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
|
|
||||||
|
|
||||||
SYMBOL: header
|
|
||||||
SYMBOL: parsed-header
|
|
||||||
SYMBOL: magic-separator
|
|
||||||
|
|
||||||
: 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 ;
|
] if ;
|
||||||
|
|
||||||
PRIVATE>
|
: dump-until-separator ( multipart -- multipart )
|
||||||
|
dup [ current-separator>> ] [ bytes>> ] bi tuck start [
|
||||||
|
cut-slice
|
||||||
|
[ mime-write ]
|
||||||
|
[ over current-separator>> length tail-slice >>bytes ] bi*
|
||||||
|
] [
|
||||||
|
drop
|
||||||
|
dup [ bytes>> ] [ current-separator>> ] bi split-bytes
|
||||||
|
[ mime-write ] when*
|
||||||
|
>>bytes fill-bytes dup end-of-stream?>> [ dump-until-separator ] unless
|
||||||
|
] if* ;
|
||||||
|
|
||||||
: parse-multipart ( stream -- array )
|
: dump-string ( multipart separator -- multipart string )
|
||||||
[
|
>>current-separator
|
||||||
"\r\n" <multipart-stream>
|
[ dump-until-separator ] with-string-writer ;
|
||||||
magic-separator off
|
|
||||||
dup [ magic-separator [ prepend ] change ]
|
: read-header ( multipart -- multipart )
|
||||||
multipart-step-loop drop
|
"\r\n\r\n" dump-string dup "--\r" = [
|
||||||
'[ [ _ (parse-multipart) ] loop ] { } make
|
drop
|
||||||
] with-scope ;
|
] [
|
||||||
|
parse-headers >hashtable >>header
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
: quote? ( ch -- ? ) "'\"" member? ;
|
||||||
|
|
||||||
|
: quoted? ( str -- ? )
|
||||||
|
{
|
||||||
|
[ length 1 > ]
|
||||||
|
[ first quote? ]
|
||||||
|
[ [ first ] [ peek ] bi = ]
|
||||||
|
} 1&& ;
|
||||||
|
|
||||||
|
: unquote ( string -- string' )
|
||||||
|
dup quoted? [ but-last-slice rest-slice >string ] when ;
|
||||||
|
|
||||||
|
: save-uploaded-file ( multipart -- )
|
||||||
|
[ unquote ] change-filename
|
||||||
|
dup filename>> empty? [
|
||||||
|
drop
|
||||||
|
] [
|
||||||
|
[ [ header>> ] [ filename>> ] [ temp-file>> ] tri mime-file boa ]
|
||||||
|
[ filename>> ]
|
||||||
|
[ uploaded-files>> set-at ] tri
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
: save-form-variable ( multipart -- )
|
||||||
|
[ unquote ] change-name
|
||||||
|
[ [ header>> ] [ name>> ] [ name-content>> ] tri mime-variable boa ]
|
||||||
|
[ name>> ]
|
||||||
|
[ form-variables>> set-at ] tri ;
|
||||||
|
|
||||||
|
: dump-mime-file ( multipart filename -- multipart )
|
||||||
|
binary <file-writer> [
|
||||||
|
dup mime-separator>> >>current-separator dump-until-separator
|
||||||
|
] with-output-stream ;
|
||||||
|
|
||||||
|
: dump-file ( multipart -- multipart )
|
||||||
|
"factor-" "-upload" make-unique-file
|
||||||
|
[ >>temp-file ] [ dump-mime-file ] bi ;
|
||||||
|
|
||||||
|
: parse-content-disposition-form-data ( string -- hashtable )
|
||||||
|
";" split
|
||||||
|
[ "=" split1 [ [ blank? ] trim ] bi@ ] H{ } map>assoc ;
|
||||||
|
|
||||||
|
: lookup-disposition ( multipart string -- multipart value/f )
|
||||||
|
over content-disposition>> at ;
|
||||||
|
|
||||||
|
ERROR: unknown-content-disposition multipart ;
|
||||||
|
|
||||||
|
: parse-form-data ( multipart -- multipart )
|
||||||
|
"filename" lookup-disposition [
|
||||||
|
>>filename
|
||||||
|
[ dump-file ] [ save-uploaded-file ] bi
|
||||||
|
] [
|
||||||
|
"name" lookup-disposition [
|
||||||
|
[ dup mime-separator>> dump-string >>name-content ] dip
|
||||||
|
>>name dup save-form-variable
|
||||||
|
] [
|
||||||
|
unknown-content-disposition
|
||||||
|
] if*
|
||||||
|
] if* ;
|
||||||
|
|
||||||
|
ERROR: no-content-disposition multipart ;
|
||||||
|
|
||||||
|
: process-header ( multipart -- multipart )
|
||||||
|
"content-disposition" over header>> at ";" split1 swap {
|
||||||
|
{ "form-data" [
|
||||||
|
parse-content-disposition-form-data >>content-disposition
|
||||||
|
parse-form-data
|
||||||
|
] }
|
||||||
|
[ no-content-disposition ]
|
||||||
|
} case ;
|
||||||
|
|
||||||
|
: read-assert= ( string -- )
|
||||||
|
[ length read ] keep assert= ;
|
||||||
|
|
||||||
|
: parse-beginning ( multipart -- multipart )
|
||||||
|
"--" read-assert=
|
||||||
|
dup mime-separator>>
|
||||||
|
[ read-assert= ]
|
||||||
|
[ separator-prefix prepend >>mime-separator ] bi ;
|
||||||
|
|
||||||
|
: parse-multipart-loop ( multipart -- multipart )
|
||||||
|
read-header
|
||||||
|
dup end-of-stream?>> [ process-header parse-multipart-loop ] unless ;
|
||||||
|
|
||||||
|
: parse-multipart ( sep -- uploaded-files form-variables )
|
||||||
|
<multipart> parse-beginning parse-multipart-loop
|
||||||
|
[ uploaded-files>> ] [ form-variables>> ] bi ;
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue