basis/http/server/requests/requests.factor

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