1 ! Copyright (C) 2009 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors ascii assocs byte-arrays combinators fry
4 hashtables http http.parsers io io.encodings.binary io.files
5 io.files.unique io.streams.string kernel math quoting sequences
9 CONSTANT: buffer-size 65536
10 CONSTANT: separator-prefix "\r\n--"
14 current-separator mime-separator
16 content-disposition bytes
21 TUPLE: mime-file headers filename temporary-path ;
22 C: <mime-file> mime-file
24 TUPLE: mime-variable headers key value ;
25 C: <mime-variable> mime-variable
27 : <multipart> ( mime-separator -- multipart )
30 H{ } clone >>mime-parts ;
32 : mime-write ( sequence -- )
35 : parse-headers ( string -- hashtable )
36 string-lines harvest [ parse-header-line ] map >hashtable ;
38 : fill-bytes ( multipart -- multipart )
40 [ '[ _ B{ } append-as ] change-bytes ]
41 [ t >>end-of-stream? ] if* ;
43 : split-bytes ( bytes separator -- leftover-bytes safe-to-dump )
44 dupd [ length ] bi@ 1 - - short cut-slice swap ;
46 : dump-until-separator ( multipart -- multipart )
48 [ current-separator>> ] [ bytes>> ] bi
49 [ nip ] [ start ] 2bi [
52 [ over current-separator>> length short tail-slice >>bytes ] bi*
55 dup [ bytes>> ] [ current-separator>> ] bi split-bytes mime-write
56 >>bytes fill-bytes dup end-of-stream?>> [ dump-until-separator ] unless
59 : dump-string ( multipart separator -- multipart string )
61 [ dump-until-separator ] with-string-writer ;
63 : read-header ( multipart -- multipart )
64 dup bytes>> "--\r\n" sequence= [
67 "\r\n\r\n" dump-string parse-headers >>header
70 : empty-name? ( string -- ? )
71 { "''" "\"\"" "" f } member? ;
73 : save-uploaded-file ( multipart -- )
74 dup filename>> empty-name? [
77 [ [ header>> ] [ filename>> ] [ temp-file>> ] tri <mime-file> ]
78 [ content-disposition>> "name" of unquote ]
79 [ mime-parts>> set-at ] tri
82 : save-mime-part ( multipart -- )
83 dup name>> empty-name? [
88 [ mime-parts>> set-at ] tri
91 : dump-mime-file ( multipart filename -- multipart )
92 binary <file-writer> [
93 dup mime-separator>> >>current-separator dump-until-separator
94 ] with-output-stream ;
96 : dump-file ( multipart -- multipart )
97 "factor-" "-upload" make-unique-file
98 [ >>temp-file ] [ dump-mime-file ] bi ;
100 : parse-content-disposition-form-data ( string -- hashtable )
102 [ "=" split1 [ [ blank? ] trim ] bi@ ] H{ } map>assoc ;
104 : lookup-disposition ( multipart string -- multipart value/f )
105 over content-disposition>> at ;
107 ERROR: unknown-content-disposition multipart ;
109 : parse-form-data ( multipart -- multipart )
110 "filename" lookup-disposition [
113 [ dump-file ] [ save-uploaded-file ] bi
115 "name" lookup-disposition [
116 [ dup mime-separator>> dump-string >>name-content ] dip
117 >>name dup save-mime-part
119 throw-unknown-content-disposition
123 ERROR: no-content-disposition multipart ;
125 : process-header ( multipart -- multipart )
126 dup "content-disposition" header ";" split1 swap {
128 parse-content-disposition-form-data >>content-disposition
131 [ throw-no-content-disposition ]
134 : read-assert-sequence= ( sequence -- )
135 [ length read ] keep assert-sequence= ;
137 : parse-beginning ( multipart -- multipart )
138 "--" read-assert-sequence=
140 [ read-assert-sequence= ]
141 [ separator-prefix prepend >>mime-separator ] bi ;
143 : parse-multipart-loop ( multipart -- multipart )
145 dup end-of-stream?>> [ process-header parse-multipart-loop ] unless ;
147 : parse-multipart ( separator -- mime-parts )
148 <multipart> parse-beginning fill-bytes
149 parse-multipart-loop mime-parts>> ;