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