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