extra/http/http.factor

   1 ! Copyright (C) 2003, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors kernel combinators math namespaces
   4 assocs assocs.lib sequences splitting sorting sets debugger
   5 strings vectors hashtables quotations arrays byte-arrays
   6 math.parser calendar calendar.format present
   7
   8 io io.encodings io.encodings.iana io.encodings.binary
   9 io.encodings.8-bit
  10
  11 unicode.case unicode.categories qualified
  12
  13 urls
  14
  15 http.parsers ;
  16
  17 EXCLUDE: fry => , ;
  18
  19 IN: http
  20
  21 : crlf ( -- ) "\r\n" write ;
  22
  23 : read-crlf ( -- bytes )
  24     "\r" read-until
  25     [ CHAR: \r assert= read1 CHAR: \n assert= ] when* ;
  26
  27 : (read-header) ( -- alist )
  28     [ read-crlf dup f like ] [ parse-header-line ] [ drop ] unfold ;
  29
  30 : process-header ( alist -- assoc )
  31     f swap [ [ swap or dup ] dip swap ] assoc-map nip
  32     [ ?push ] histogram [ "; " join ] assoc-map
  33     >hashtable ;
  34
  35 : read-header ( -- assoc )
  36     (read-header) process-header ;
  37
  38 : header-value>string ( value -- string )
  39     {
  40         { [ dup timestamp? ] [ timestamp>http-string ] }
  41         { [ dup array? ] [ [ header-value>string ] map "; " join ] }
  42         [ present ]
  43     } cond ;
  44
  45 : check-header-string ( str -- str )
  46     #! http://en.wikipedia.org/wiki/HTTP_Header_Injection
  47     dup "\r\n\"" intersect empty?
  48     [ "Header injection attack" throw ] unless ;
  49
  50 : write-header ( assoc -- )
  51     >alist sort-keys [
  52         [ check-header-string write ": " write ]
  53         [ header-value>string check-header-string write crlf ] bi*
  54     ] assoc-each crlf ;
  55
  56 TUPLE: cookie name value version comment path domain expires max-age http-only secure ;
  57
  58 : <cookie> ( value name -- cookie )
  59     cookie new
  60         swap >>name
  61         swap >>value ;
  62
  63 : parse-set-cookie ( string -- seq )
  64     [
  65         f swap
  66         (parse-set-cookie)
  67         [
  68             swap {
  69                 { "version" [ >>version ] }
  70                 { "comment" [ >>comment ] }
  71                 { "expires" [ cookie-string>timestamp >>expires ] }
  72                 { "max-age" [ string>number seconds >>max-age ] }
  73                 { "domain" [ >>domain ] }
  74                 { "path" [ >>path ] }
  75                 { "httponly" [ drop t >>http-only ] }
  76                 { "secure" [ drop t >>secure ] }
  77                 [ <cookie> dup , nip ]
  78             } case
  79         ] assoc-each
  80         drop
  81     ] { } make ;
  82
  83 : parse-cookie ( string -- seq )
  84     [
  85         f swap
  86         (parse-cookie)
  87         [
  88             swap {
  89                 { "$version" [ >>version ] }
  90                 { "$domain" [ >>domain ] }
  91                 { "$path" [ >>path ] }
  92                 [ <cookie> dup , nip ]
  93             } case
  94         ] assoc-each
  95         drop
  96     ] { } make ;
  97
  98 : check-cookie-string ( string -- string' )
  99     dup "=;'\"\r\n" intersect empty?
 100     [ "Bad cookie name or value" throw ] unless ;
 101
 102 : unparse-cookie-value ( key value -- )
 103     {
 104         { f [ drop ] }
 105         { t [ check-cookie-string , ] }
 106         [
 107             {
 108                 { [ dup timestamp? ] [ timestamp>cookie-string ] }
 109                 { [ dup duration? ] [ dt>seconds number>string ] }
 110                 { [ dup real? ] [ number>string ] }
 111                 [ ]
 112             } cond
 113             check-cookie-string "=" swap check-cookie-string 3append ,
 114         ]
 115     } case ;
 116
 117 : (unparse-cookie) ( cookie -- strings )
 118     [
 119         dup name>> check-cookie-string >lower
 120         over value>> unparse-cookie-value
 121         "$path" over path>> unparse-cookie-value
 122         "$domain" over domain>> unparse-cookie-value
 123         drop
 124     ] { } make ;
 125
 126 : unparse-cookie ( cookies -- string )
 127     [ (unparse-cookie) ] map concat "; " join ;
 128
 129 : unparse-set-cookie ( cookie -- string )
 130     [
 131         dup name>> check-cookie-string >lower
 132         over value>> unparse-cookie-value
 133         "path" over path>> unparse-cookie-value
 134         "domain" over domain>> unparse-cookie-value
 135         "expires" over expires>> unparse-cookie-value
 136         "max-age" over max-age>> unparse-cookie-value
 137         "httponly" over http-only>> unparse-cookie-value
 138         "secure" over secure>> unparse-cookie-value
 139         drop
 140     ] { } make "; " join ;
 141
 142 TUPLE: request
 143 method
 144 url
 145 version
 146 header
 147 post-data
 148 cookies ;
 149
 150 : set-header ( request/response value key -- request/response )
 151     pick header>> set-at ;
 152
 153 : <request> ( -- request )
 154     request new
 155         "1.1" >>version
 156         <url>
 157             H{ } clone >>query
 158         >>url
 159         H{ } clone >>header
 160         V{ } clone >>cookies
 161         "close" "connection" set-header
 162         "Factor http.client" "user-agent" set-header ;
 163
 164 : header ( request/response key -- value )
 165     swap header>> at ;
 166
 167 TUPLE: response
 168 version
 169 code
 170 message
 171 header
 172 cookies
 173 content-type
 174 content-charset
 175 body ;
 176
 177 : <response> ( -- response )
 178     response new
 179         "1.1" >>version
 180         H{ } clone >>header
 181         "close" "connection" set-header
 182         now timestamp>http-string "date" set-header
 183         "Factor http.server" "server" set-header
 184         latin1 >>content-charset
 185         V{ } clone >>cookies ;
 186
 187 M: response clone
 188     call-next-method
 189         [ clone ] change-header
 190         [ clone ] change-cookies ;
 191
 192 : get-cookie ( request/response name -- cookie/f )
 193     [ cookies>> ] dip '[ , _ name>> = ] find nip ;
 194
 195 : delete-cookie ( request/response name -- )
 196     over cookies>> [ get-cookie ] dip delete ;
 197
 198 : put-cookie ( request/response cookie -- request/response )
 199     [ name>> dupd get-cookie [ dupd delete-cookie ] when* ] keep
 200     over cookies>> push ;
 201
 202 TUPLE: raw-response
 203 version
 204 code
 205 message
 206 body ;
 207
 208 : <raw-response> ( -- response )
 209     raw-response new
 210         "1.1" >>version ;
 211
 212 TUPLE: post-data raw content content-type ;
 213
 214 : <post-data> ( raw content-type -- post-data )
 215     post-data new
 216         swap >>content-type
 217         swap >>raw ;
 218
 219 : parse-content-type-attributes ( string -- attributes )
 220     " " split harvest [ "=" split1 [ >lower ] dip ] { } map>assoc ;
 221
 222 : parse-content-type ( content-type -- type encoding )
 223     ";" split1 parse-content-type-attributes "charset" swap at
 224     name>encoding over "text/" head? latin1 binary ? or ;