basis/mime/multipart/multipart.factor

   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
   6 splitting ;
   7 IN: mime.multipart
   8
   9 CONSTANT: buffer-size 65536
  10 CONSTANT: separator-prefix "\r\n--"
  11
  12 TUPLE: multipart
  13 end-of-stream?
  14 current-separator mime-separator
  15 header
  16 content-disposition bytes
  17 filename temp-file
  18 name name-content
  19 mime-parts ;
  20
  21 TUPLE: mime-file headers filename temporary-path ;
  22 C: <mime-file> mime-file
  23
  24 TUPLE: mime-variable headers key value ;
  25 C: <mime-variable> mime-variable
  26
  27 : <multipart> ( mime-separator -- multipart )
  28     multipart new
  29         swap >>mime-separator
  30         H{ } clone >>mime-parts ;
  31
  32 : mime-write ( sequence -- )
  33     >byte-array write ;
  34
  35 : parse-headers ( string -- hashtable )
  36     string-lines harvest [ parse-header-line ] map >hashtable ;
  37
  38 : fill-bytes ( multipart -- multipart )
  39     buffer-size read
  40     [ '[ _ B{ } append-as ] change-bytes ]
  41     [ t >>end-of-stream? ] if* ;
  42
  43 : split-bytes ( bytes separator -- leftover-bytes safe-to-dump )
  44     dupd [ length ] bi@ 1 - - short cut-slice swap ;
  45
  46 : dump-until-separator ( multipart -- multipart )
  47     dup
  48     [ current-separator>> ] [ bytes>> ] bi
  49     [ nip ] [ start ] 2bi [
  50         cut-slice
  51         [ mime-write ]
  52         [ over current-separator>> length short tail-slice >>bytes ] bi*
  53     ] [
  54         drop
  55         dup [ bytes>> ] [ current-separator>> ] bi split-bytes mime-write
  56         >>bytes fill-bytes dup end-of-stream?>> [ dump-until-separator ] unless
  57     ] if* ;
  58
  59 : dump-string ( multipart separator -- multipart string )
  60     >>current-separator
  61     [ dump-until-separator ] with-string-writer ;
  62
  63 : read-header ( multipart -- multipart )
  64     dup bytes>> "--\r\n" sequence= [
  65         t >>end-of-stream?
  66     ] [
  67         "\r\n\r\n" dump-string parse-headers >>header
  68     ] if ;
  69
  70 : empty-name? ( string -- ? )
  71     { "''" "\"\"" "" f } member? ;
  72
  73 : save-uploaded-file ( multipart -- )
  74     dup filename>> empty-name? [
  75         drop
  76     ] [
  77         [ [ header>> ] [ filename>> ] [ temp-file>> ] tri <mime-file> ]
  78         [ content-disposition>> "name" of unquote ]
  79         [ mime-parts>> set-at ] tri
  80     ] if ;
  81
  82 : save-mime-part ( multipart -- )
  83     dup name>> empty-name? [
  84         drop
  85     ] [
  86         [ name-content>> ]
  87         [ name>> unquote ]
  88         [ mime-parts>> set-at ] tri
  89     ] if ;
  90
  91 : dump-mime-file ( multipart filename -- multipart )
  92     binary <file-writer> [
  93         dup mime-separator>> >>current-separator dump-until-separator
  94     ] with-output-stream ;
  95
  96 : dump-file ( multipart -- multipart )
  97     "factor-" "-upload" make-unique-file
  98     [ >>temp-file ] [ dump-mime-file ] bi ;
  99
 100 : parse-content-disposition-form-data ( string -- hashtable )
 101     ";" split
 102     [ "=" split1 [ [ blank? ] trim ] bi@ ] H{ } map>assoc ;
 103
 104 : lookup-disposition ( multipart string -- multipart value/f )
 105     over content-disposition>> at ;
 106
 107 ERROR: unknown-content-disposition multipart ;
 108
 109 : parse-form-data ( multipart -- multipart )
 110     "filename" lookup-disposition [
 111         unquote
 112         >>filename
 113         [ dump-file ] [ save-uploaded-file ] bi
 114     ] [
 115         "name" lookup-disposition [
 116             [ dup mime-separator>> dump-string >>name-content ] dip
 117             >>name dup save-mime-part
 118         ] [
 119              throw-unknown-content-disposition
 120         ] if*
 121     ] if* ;
 122
 123 ERROR: no-content-disposition multipart ;
 124
 125 : process-header ( multipart -- multipart )
 126     dup "content-disposition" header ";" split1 swap {
 127         { "form-data" [
 128             parse-content-disposition-form-data >>content-disposition
 129             parse-form-data
 130         ] }
 131         [ throw-no-content-disposition ]
 132     } case ;
 133
 134 : read-assert-sequence= ( sequence -- )
 135     [ length read ] keep assert-sequence= ;
 136
 137 : parse-beginning ( multipart -- multipart )
 138     "--" read-assert-sequence=
 139     dup mime-separator>>
 140     [ read-assert-sequence= ]
 141     [ separator-prefix prepend >>mime-separator ] bi ;
 142
 143 : parse-multipart-loop ( multipart -- multipart )
 144     read-header
 145     dup end-of-stream?>> [ process-header parse-multipart-loop ] unless ;
 146
 147 : parse-multipart ( separator -- mime-parts )
 148     <multipart> parse-beginning fill-bytes
 149     parse-multipart-loop mime-parts>> ;