basis/http/http.factor

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