1 ! Copyright (C) 2009 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors ascii assocs byte-arrays combinators hashtables
4 http http.parsers io io.encodings.binary io.files io.files.temp
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 split-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 ERROR: mime-decoding-ran-out-of-bytes ;
44 : dump-until-separator ( multipart -- multipart )
45 [ ] [ current-separator>> ] [ bytes>> ] tri
46 dup [ mime-decoding-ran-out-of-bytes ] unless
47 2dup swap subseq-index [
50 [ swap length tail-slice >>bytes ] bi*
52 tuck [ length ] bi@ - 1 - cut-slice
54 [ >>bytes ] bi* fill-bytes
55 dup end-of-stream?>> [ dump-until-separator ] unless
58 : dump-string ( multipart separator -- multipart string )
60 [ dump-until-separator ] with-string-writer ;
62 : read-header ( multipart -- multipart )
63 dup bytes>> "--\r\n" sequence= [
66 "\r\n\r\n" dump-string parse-headers >>header
69 : empty-name? ( string -- ? )
70 { "''" "\"\"" "" f } member? ;
72 : save-uploaded-file ( multipart -- )
73 dup filename>> empty-name? [
76 [ [ header>> ] [ filename>> ] [ temp-file>> ] tri <mime-file> ]
77 [ content-disposition>> "name" of unquote ]
78 [ mime-parts>> set-at ] tri
81 : save-mime-part ( multipart -- )
82 dup name>> empty-name? [
87 [ mime-parts>> set-at ] tri
90 : dump-mime-file ( multipart filename -- multipart )
91 binary <file-writer> [
92 dup mime-separator>> >>current-separator dump-until-separator
93 ] with-output-stream ;
95 : dump-file ( multipart -- multipart )
96 [ "factor-" "-upload" unique-file ] with-temp-directory
97 [ >>temp-file ] [ dump-mime-file ] bi ;
99 : parse-content-disposition-form-data ( string -- hashtable )
101 [ "=" split1 [ [ blank? ] trim ] bi@ ] H{ } map>assoc ;
103 : lookup-disposition ( multipart string -- multipart value/f )
104 over content-disposition>> at ;
106 ERROR: unknown-content-disposition multipart ;
108 : parse-form-data ( multipart -- multipart )
109 "filename" lookup-disposition [
112 [ dump-file ] [ save-uploaded-file ] bi
114 "name" lookup-disposition [
115 [ dup mime-separator>> dump-string >>name-content ] dip
116 >>name dup save-mime-part
118 unknown-content-disposition
122 ERROR: no-content-disposition multipart ;
124 : process-header ( multipart -- multipart )
125 dup "content-disposition" header ";" split1 swap {
127 parse-content-disposition-form-data >>content-disposition
130 [ no-content-disposition ]
133 : read-assert-sequence= ( sequence -- )
134 [ length read ] keep assert-sequence= ;
136 : parse-beginning ( multipart -- multipart )
137 "--" read-assert-sequence=
139 [ read-assert-sequence= ]
140 [ separator-prefix prepend >>mime-separator ] bi ;
142 : parse-multipart-loop ( multipart -- multipart )
144 dup end-of-stream?>> [ process-header parse-multipart-loop ] unless ;
146 : parse-multipart ( separator -- mime-parts )
147 <multipart> parse-beginning fill-bytes
148 parse-multipart-loop mime-parts>> ;