factor-work/mail/multipart/multipart.factor

162 lines
4.5 KiB
Factor

! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors ascii assocs byte-arrays combinators fry
hashtables http http.parsers io io.encodings.binary io.files
io.files.temp io.files.unique io.streams.string kernel math
quoting sequences splitting namespaces sequences.parser arrays regexp ;
USING: prettyprint ;
IN: mail.multipart
CONSTANT: buffer-size 65536
CONSTANT: separator-prefix "\r\n--"
SYMBOL: current-boundary
TUPLE: multipart
end-of-stream?
current-separator mime-separator
header
content-disposition bytes
filename temp-file
name name-content
mime-parts ;
TUPLE: mime-file headers filename temporary-path ;
C: <mime-file> mime-file
TUPLE: mime-variable headers key value ;
C: <mime-variable> mime-variable
: <multipart> ( mime-separator -- multipart )
multipart new
swap >>mime-separator
{ } clone >>mime-parts ;
: mime-write ( sequence -- )
>byte-array write ;
: parse-headers ( string -- hashtable )
string-lines harvest [ parse-header-line ] map >hashtable ;
: fill-bytes ( multipart -- multipart )
buffer-size read
[ '[ _ B{ } append-as ] change-bytes ]
[ t >>end-of-stream? ] if* ;
ERROR: mime-decoding-ran-out-of-bytes ;
: dump-until-separator ( multipart -- multipart )
[ ] [ current-separator>> ] [ bytes>> ] tri
dup [ mime-decoding-ran-out-of-bytes ] unless
2dup subseq-start [
cut-slice
[ mime-write ]
[ swap length tail-slice >>bytes ] bi*
] [
tuck [ length ] bi@ - 1 - cut-slice
[ mime-write ]
[ >>bytes ] bi* fill-bytes
dup end-of-stream?>> [ dump-until-separator ] unless
] if* ;
: dump-string ( multipart separator -- multipart string )
>>current-separator
[ dump-until-separator ] with-string-writer ;
: read-header ( multipart -- multipart )
dup bytes>> "--\r\n" sequence= [
t >>end-of-stream?
] [
"\r\n\r\n" dump-string parse-headers >>header
] if ;
: empty-name? ( string -- ? )
{ "''" "\"\"" "" f } member? ;
: save-uploaded-file ( multipart -- )
dup filename>> empty-name? [
drop
] [
[ [ header>> ] [ filename>> ] [ temp-file>> ] tri <mime-file> ]
[ content-disposition>> "name" of unquote ]
[ mime-parts>> set-at ] tri
] if ;
: save-mime-part ( multipart -- )
dup name>> empty-name? [
drop
] [
[ name-content>> ]
[ name>> unquote ]
[ mime-parts>> set-at ] tri
] if ;
: 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" unique-file ] with-temp-directory
[ >>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 [
unquote
>>filename
[ dump-file ] [ save-uploaded-file ] bi
] [
"name" lookup-disposition [
[ dup mime-separator>> dump-string >>name-content ] dip
>>name dup save-mime-part
] [
unknown-content-disposition
] if*
] if* ;
ERROR: no-content-disposition multipart ;
: process-header ( multipart -- multipart )
dup "content-disposition" header ";" split1 swap {
{ "form-data" [
parse-content-disposition-form-data >>content-disposition
parse-form-data
] }
[ no-content-disposition ]
} case ;
: read-assert-sequence= ( sequence -- )
[ length read ] keep assert-sequence= ;
! : with-boundary ( boundary quote -- )
! [] dip
! current-boundary swap with-variable ; inline
: parse-beginning ( str boundary -- str' )
[ <sequence-parser> ] dip
[ take-sequence drop ] curry
[ take-rest ] bi ;
: parse-header ( str -- header str' )
[
[
"\r\n\r\n" take-until-sequence*
string-lines harvest [ parse-header-line
parse-content-disposition-form-data ] map >hashtable
]
[ take-rest ] bi
] parse-sequence ;
: parse-multipart ( str separator -- seq )
"--" prepend "\r\n" append dup <regexp> [ parse-beginning ] dip re-split
[ [ from>> ] [ to>> ] [ seq>> ] tri subseq parse-header 2array ] map ;