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 ascii
   9 http.parsers
  10 base64 ;
  11 IN: http
  12
  13 CONSTANT: max-redirects 10
  14
  15 : (read-header) ( -- alist )
  16     [ read-crlf dup f like ] [ parse-header-line ] produce nip ;
  17
  18 : collect-headers ( assoc -- assoc' )
  19     H{ } clone [ '[ _ push-at ] assoc-each ] keep ;
  20
  21 : process-header ( alist -- assoc )
  22     f swap [ [ swap or dup ] dip swap ] assoc-map nip
  23     collect-headers [ "; " join ] assoc-map
  24     >hashtable ;
  25
  26 : read-header ( -- assoc )
  27     (read-header) process-header ;
  28
  29 : header-value>string ( value -- string )
  30     {
  31         { [ dup timestamp? ] [ timestamp>http-string ] }
  32         { [ dup array? ] [ [ header-value>string ] map "; " join ] }
  33         [ present ]
  34     } cond ;
  35
  36 : check-header-string ( str -- str )
  37     #! http://en.wikipedia.org/wiki/HTTP_Header_Injection
  38     dup "\r\n" intersects?
  39     [ "Header injection attack" throw ] when ;
  40
  41 : write-header ( assoc -- )
  42     >alist sort-keys [
  43         [ check-header-string write ": " write ]
  44         [ header-value>string check-header-string write crlf ] bi*
  45     ] assoc-each crlf ;
  46
  47 TUPLE: cookie name value version comment path domain expires max-age http-only secure ;
  48
  49 : <cookie> ( value name -- cookie )
  50     cookie new
  51         swap >>name
  52         swap >>value ;
  53
  54 : parse-set-cookie ( string -- seq )
  55     [
  56         f swap
  57         (parse-set-cookie)
  58         [
  59             swap {
  60                 { "version" [ >>version ] }
  61                 { "comment" [ >>comment ] }
  62                 { "expires" [ cookie-string>timestamp >>expires ] }
  63                 { "max-age" [ string>number seconds >>max-age ] }
  64                 { "domain" [ >>domain ] }
  65                 { "path" [ >>path ] }
  66                 { "httponly" [ drop t >>http-only ] }
  67                 { "secure" [ drop t >>secure ] }
  68                 [ <cookie> dup , nip ]
  69             } case
  70         ] assoc-each
  71         drop
  72     ] { } make ;
  73
  74 : parse-cookie ( string -- seq )
  75     [
  76         f swap
  77         (parse-cookie)
  78         [
  79             swap {
  80                 { "$version" [ >>version ] }
  81                 { "$domain" [ >>domain ] }
  82                 { "$path" [ >>path ] }
  83                 [ <cookie> dup , nip ]
  84             } case
  85         ] assoc-each
  86         drop
  87     ] { } make ;
  88
  89 : check-cookie-string ( string -- string' )
  90     dup "=;'\"\r\n" intersects?
  91     [ "Bad cookie name or value" throw ] when ;
  92
  93 : unparse-cookie-value ( key value -- )
  94     {
  95         { f [ drop ] }
  96         { t [ check-cookie-string , ] }
  97         [
  98             {
  99                 { [ dup timestamp? ] [ timestamp>cookie-string ] }
 100                 { [ dup duration? ] [ duration>seconds number>string ] }
 101                 { [ dup real? ] [ number>string ] }
 102                 [ ]
 103             } cond
 104             [ check-cookie-string ] bi@ "=" glue ,
 105         ]
 106     } case ;
 107
 108 : check-cookie-value ( string -- string )
 109     [ "Cookie value must not be f" throw ] unless* ;
 110
 111 : (unparse-cookie) ( cookie -- strings )
 112     [
 113         dup name>> check-cookie-string >lower
 114         over value>> check-cookie-value unparse-cookie-value
 115         "$path" over path>> unparse-cookie-value
 116         "$domain" over domain>> unparse-cookie-value
 117         drop
 118     ] { } make ;
 119
 120 : unparse-cookie ( cookies -- string )
 121     [ (unparse-cookie) ] map concat "; " join ;
 122
 123 : unparse-set-cookie ( cookie -- string )
 124     [
 125         dup name>> check-cookie-string >lower
 126         over value>> check-cookie-value unparse-cookie-value
 127         "path" over path>> unparse-cookie-value
 128         "domain" over domain>> unparse-cookie-value
 129         "expires" over expires>> unparse-cookie-value
 130         "max-age" over max-age>> unparse-cookie-value
 131         "httponly" over http-only>> unparse-cookie-value
 132         "secure" over secure>> unparse-cookie-value
 133         drop
 134     ] { } make "; " join ;
 135
 136 TUPLE: request
 137 method
 138 url
 139 version
 140 header
 141 post-data
 142 cookies
 143 redirects ;
 144
 145 : set-header ( request/response value key -- request/response )
 146     pick header>> set-at ;
 147
 148 : set-basic-auth ( request username password -- request )
 149     ":" glue >base64 "Basic " prepend "Authorization" set-header ;
 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         max-redirects >>redirects ;
 162
 163 : header ( request/response key -- value )
 164     swap header>> at ;
 165
 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 '[ [ _ ] 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 data params content-type content-encoding ;
 213
 214 : <post-data> ( content-type -- post-data )
 215     post-data new
 216         swap >>content-type ;
 217
 218 : parse-content-type-attributes ( string -- attributes )
 219     " " split harvest [
 220         "=" split1
 221         "\"" ?head drop "\"" ?tail drop
 222     ] { } map>assoc ;
 223
 224 : parse-content-type ( content-type -- type encoding )
 225     ";" split1
 226     parse-content-type-attributes "charset" swap at name>encoding
 227     [ dup "text/" head? latin1 binary ? ] unless* ;