basis/mime/multipart/multipart.factor

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