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 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 TUPLE: mime-variable headers key value ;
  23
  24 : <multipart> ( mime-separator -- multipart )
  25     multipart new
  26         swap >>mime-separator
  27         H{ } clone >>mime-parts ;
  28
  29 ERROR: bad-header bytes ;
  30
  31 : mime-write ( sequence -- )
  32     >byte-array write ;
  33
  34 : parse-headers ( string -- hashtable )
  35     string-lines harvest [ parse-header-line ] map >hashtable ;
  36
  37 ERROR: end-of-stream multipart ;
  38
  39 : fill-bytes ( multipart -- multipart )
  40     buffer-size read
  41     [ '[ _ append ] change-bytes ]
  42     [ t >>end-of-stream? ] if* ;
  43
  44 : maybe-fill-bytes ( multipart -- multipart )
  45     dup bytes>> [ fill-bytes ] unless  ;
  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 : quote? ( ch -- ? ) "'\"" member? ;
  78
  79 : quoted? ( str -- ? )
  80     {
  81         [ length 1 > ]
  82         [ first quote? ]
  83         [ [ first ] [ peek ] bi = ]
  84     } 1&& ;
  85
  86 : unquote ( str -- newstr )
  87     dup quoted? [ but-last-slice rest-slice >string ] when ;
  88
  89 : save-uploaded-file ( multipart -- )
  90     dup filename>> empty-name? [
  91         drop
  92     ] [
  93         [ [ header>> ] [ filename>> ] [ temp-file>> ] tri mime-file boa ]
  94         [ content-disposition>> "name" swap at unquote ]
  95         [ mime-parts>> set-at ] tri
  96     ] if ;
  97
  98 : save-mime-part ( multipart -- )
  99     dup name>> empty-name? [
 100         drop
 101     ] [
 102         [ [ header>> ] [ name>> unquote ] [ name-content>> ] tri mime-variable boa ]
 103         [ name>> unquote ]
 104         [ mime-parts>> set-at ] tri
 105     ] if ;
 106
 107 : dump-mime-file ( multipart filename -- multipart )
 108     binary <file-writer> [
 109         dup mime-separator>> >>current-separator dump-until-separator
 110     ] with-output-stream ;
 111
 112 : dump-file ( multipart -- multipart )
 113     "factor-" "-upload" make-unique-file
 114     [ >>temp-file ] [ dump-mime-file ] bi ;
 115
 116 : parse-content-disposition-form-data ( string -- hashtable )
 117     ";" split
 118     [ "=" split1 [ [ blank? ] trim ] bi@ ] H{ } map>assoc ;
 119
 120 : lookup-disposition ( multipart string -- multipart value/f )
 121     over content-disposition>> at ;
 122
 123 ERROR: unknown-content-disposition multipart ;
 124
 125 : parse-form-data ( multipart -- multipart )
 126     "filename" lookup-disposition [
 127         unquote
 128         >>filename
 129         [ dump-file ] [ save-uploaded-file ] bi
 130     ] [
 131         "name" lookup-disposition [
 132             [ dup mime-separator>> dump-string >>name-content ] dip
 133             >>name dup save-mime-part
 134         ] [
 135              unknown-content-disposition
 136         ] if*
 137     ] if* ;
 138
 139 ERROR: no-content-disposition multipart ;
 140
 141 : process-header ( multipart -- multipart )
 142     "content-disposition" over header>> at ";" split1 swap {
 143         { "form-data" [
 144             parse-content-disposition-form-data >>content-disposition
 145             parse-form-data
 146         ] }
 147         [ no-content-disposition ]
 148     } case ;
 149
 150 : assert-sequence= ( a b -- )
 151     2dup sequence= [ 2drop ] [ assert ] if ;
 152
 153 : read-assert-sequence= ( sequence -- )
 154     [ length read ] keep assert-sequence= ;
 155
 156 : parse-beginning ( multipart -- multipart )
 157     "--" read-assert-sequence=
 158     dup mime-separator>>
 159     [ read-assert-sequence= ]
 160     [ separator-prefix prepend >>mime-separator ] bi ;
 161
 162 : parse-multipart-loop ( multipart -- multipart )
 163     read-header
 164     dup end-of-stream?>> [ process-header parse-multipart-loop ] unless ;
 165
 166 : parse-multipart ( separator -- mime-parts )
 167     <multipart> parse-beginning fill-bytes parse-multipart-loop
 168     mime-parts>> ;