basis/mime/multipart/multipart.factor

   1 ! Copyright (C) 2008 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors combinators io kernel locals math multiline
   4 sequences splitting prettyprint namespaces http.parsers
   5 ascii assocs unicode.case io.files.unique io.files io.encodings.binary
   6 byte-arrays io.encodings make fry ;
   7 IN: mime.multipart
   8
   9 TUPLE: multipart-stream stream n leftover separator ;
  10
  11 : <multipart-stream> ( stream separator -- multipart-stream )
  12     multipart-stream new
  13         swap >>separator
  14         swap >>stream
  15         16 2^ >>n ;
  16
  17 <PRIVATE
  18
  19 : ?append ( seq1 seq2 -- newseq/seq2 )
  20     over [ append ] [ nip ] if ;
  21
  22 : ?cut* ( seq n -- before after )
  23     over length over <= [ drop f swap ] [ cut* ] if ;
  24
  25 : read-n ( stream -- bytes end-stream? )
  26     [ f ] change-leftover
  27     [ n>> ] [ stream>> ] bi stream-read [ ?append ] keep not ;
  28
  29 : multipart-split ( bytes separator -- before after seq=? )
  30     2dup sequence= [ 2drop f f t ] [ split1 f ] if ;
  31
  32 :: multipart-step-found ( bytes stream quot: ( bytes -- ) -- ? )
  33     bytes [ quot unless-empty ]
  34     [ stream (>>leftover) quot unless-empty ] if-empty f ; inline
  35
  36 :: multipart-step-not-found ( bytes stream end-stream? separator quot: ( bytes -- ) -- ? )
  37     bytes end-stream? [
  38         quot unless-empty f
  39     ] [
  40         separator length 1- ?cut* stream (>>leftover)
  41         quot unless-empty t
  42     ] if ; inline
  43
  44 :: multipart-step ( stream bytes end-stream? separator quot: ( bytes -- ) -- ? end-stream? )
  45     #! return t to loop again
  46     bytes separator multipart-split
  47     [ 2drop f ]
  48     [
  49         [ stream quot multipart-step-found ]
  50         [ stream end-stream? separator quot multipart-step-not-found ] if*
  51     ] if stream leftover>> end-stream? not or >boolean ;
  52
  53
  54 :: multipart-step-loop ( stream quot1: ( bytes -- ) -- ? )
  55     stream dup [ read-n ] [ separator>> ] bi quot1 multipart-step
  56     swap [ drop stream quot1 multipart-step-loop ] when ; inline recursive
  57
  58 SYMBOL: header
  59 SYMBOL: parsed-header
  60 SYMBOL: magic-separator
  61
  62 : trim-blanks ( str -- str' ) [ blank? ] trim ;
  63
  64 : trim-quotes ( str -- str' )
  65     [ [ CHAR: " = ] [ CHAR: ' = ] bi or ] trim ;
  66
  67 : parse-content-disposition ( str -- content-disposition hash )
  68     ";" split [ first ] [ rest-slice ] bi [ "=" split ] map
  69     [ [ trim-blanks ] [ trim-quotes ] bi* ] H{ } assoc-map-as ;
  70
  71 : parse-multipart-header ( string -- headers )
  72     "\r\n" split harvest
  73     [ parse-header-line first2 ] H{ } map>assoc ;
  74
  75 ERROR: expected-file ;
  76
  77 TUPLE: uploaded-file path filename name ;
  78
  79 : (parse-multipart) ( stream -- ? )
  80     "\r\n\r\n" >>separator
  81     header off
  82     dup [ header [ prepend ] change ] multipart-step-loop drop
  83     header get dup magic-separator get [ length ] bi@ < [
  84         2drop f
  85     ] [
  86         parse-multipart-header
  87         parsed-header set
  88         "\r\n" magic-separator get append >>separator
  89         "factor-upload" "httpd" make-unique-file tuck
  90         binary [ [ write ] multipart-step-loop ] with-file-writer swap
  91         "content-disposition" parsed-header get at parse-content-disposition
  92         nip [ "filename" swap at ] [ "name" swap at ] bi
  93         uploaded-file boa ,
  94     ] if ;
  95
  96 PRIVATE>
  97
  98 : parse-multipart ( stream -- array )
  99     [
 100         "\r\n" <multipart-stream>
 101         magic-separator off
 102         dup [ magic-separator [ prepend ] change ]
 103             multipart-step-loop drop
 104         '[ [ _ (parse-multipart) ] loop ] { } make
 105     ] with-scope ;