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