basis/http/server/requests/requests.factor

   1 USING: accessors combinators continuations http http.parsers io
   2 io.crlf io.encodings io.encodings.binary io.streams.limited
   3 kernel math.order math.parser namespaces sequences splitting
   4 urls urls.encoding ;
   5 FROM: mime.multipart => parse-multipart ;
   6 IN: http.server.requests
   7
   8 ERROR: request-error ;
   9
  10 ERROR: no-boundary < request-error ;
  11
  12 ERROR: invalid-path < request-error path ;
  13
  14 ERROR: invalid-content-length < request-error content-length ;
  15
  16 ERROR: content-length-missing < request-error ;
  17
  18 ERROR: bad-request-line < request-error parse-error ;
  19
  20 : check-absolute ( url -- )
  21     path>> dup "/" head? [ drop ] [ invalid-path ] if ; inline
  22
  23 : parse-request-line-safe ( string -- triple )
  24     [ parse-request-line ] [ nip bad-request-line ] recover ;
  25
  26 : read-request-line ( request -- request )
  27     read-?crlf [ dup "" = ] [ drop read-?crlf ] while
  28     parse-request-line-safe first3
  29     [ >>method ] [ >url dup check-absolute >>url ] [ >>version ] tri* ;
  30
  31 : read-request-header ( request -- request )
  32     read-header >>header ;
  33
  34 SYMBOL: upload-limit
  35
  36 upload-limit [ 200,000,000 ] initialize
  37
  38 : parse-multipart-form-data ( string -- separator )
  39     ";" split1 nip
  40     "=" split1 nip [ no-boundary ] unless* ;
  41
  42 : maybe-limit-input ( content-length -- )
  43     unlimited-input upload-limit get [ min ] when* limited-input ;
  44
  45 : read-multipart-data ( request content-length -- mime-parts )
  46     maybe-limit-input binary decode-input
  47     "content-type" header parse-multipart-form-data parse-multipart ;
  48
  49 : parse-content-length-safe ( request -- content-length )
  50     "content-length" header [
  51         dup string>number [
  52             nip dup 0 upload-limit get between? [
  53                 invalid-content-length
  54             ] unless
  55         ] [ invalid-content-length ] if*
  56     ] [ content-length-missing ] if* ;
  57
  58 : parse-content ( request content-type -- post-data )
  59     dup <post-data> -rot over parse-content-length-safe swap
  60     {
  61         { "multipart/form-data" [ read-multipart-data >>params ] }
  62         { "application/x-www-form-urlencoded" [
  63             nip read query>assoc >>params
  64         ] }
  65         [ drop nip read >>data ]
  66     } case ;
  67
  68 : read-post-data ( request -- request )
  69     dup method>> "POST" = [
  70         dup dup "content-type" header
  71         ";" split1 drop parse-content >>post-data
  72     ] when ;
  73
  74 : extract-host ( request -- request )
  75     [ ] [ url>> ] [ "host" header parse-host ] tri
  76     [ >>host ] [ >>port ] bi*
  77     drop ;
  78
  79 : extract-cookies ( request -- request )
  80     dup "cookie" header [ parse-cookie >>cookies ] when* ;
  81
  82 : read-request ( -- request )
  83     <request>
  84     read-request-line
  85     read-request-header
  86     read-post-data
  87     extract-host
  88     extract-cookies ;