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