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