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