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