basis/http/http.factor

   1 ! Copyright (C) 2003, 2010 Slava Pestov.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays ascii assocs base64 calendar calendar.format
   4 calendar.parser combinators hashtables http.parsers io io.crlf
   5 io.encodings.iana io.encodings.utf8 kernel make math math.parser
   6 mime.types present sequences sets sorting splitting urls ;
   7 IN: http
   8
   9 CONSTANT: max-redirects 10
  10
  11 : (read-header) ( -- alist )
  12     [ read-?crlf dup f like ] [ parse-header-line ] produce nip ;
  13
  14 : collect-headers ( assoc -- assoc' )
  15     H{ } clone [ '[ _ push-at ] assoc-each ] keep ;
  16
  17 : process-header ( alist -- assoc )
  18     f swap [ [ swap or dup ] dip swap ] assoc-map nip
  19     collect-headers [ "; " join ] assoc-map
  20     >hashtable ;
  21
  22 : read-header ( -- assoc )
  23     (read-header) process-header ;
  24
  25 : header-value>string ( value -- string )
  26     {
  27         { [ dup timestamp? ] [ timestamp>http-string ] }
  28         { [ dup array? ] [ [ header-value>string ] map "; " join ] }
  29         [ present ]
  30     } cond ;
  31
  32 : check-header-string ( str -- str )
  33     ! https://en.wikipedia.org/wiki/HTTP_Header_Injection
  34     dup "\r\n" intersects?
  35     [ "Header injection attack" throw ] when ;
  36
  37 : write-header ( assoc -- )
  38     sort-keys [
  39         [ check-header-string write ": " write ]
  40         [ header-value>string check-header-string write crlf ] bi*
  41     ] assoc-each crlf ;
  42
  43 TUPLE: cookie name value version comment path domain expires max-age http-only secure ;
  44
  45 : <cookie> ( value name -- cookie )
  46     cookie new
  47         swap >>name
  48         swap >>value ;
  49
  50 : parse-set-cookie ( string -- seq )
  51     [
  52         f swap
  53         (parse-set-cookie)
  54         [
  55             swapd pick >lower {
  56                 { "version" [ >>version ] }
  57                 { "comment" [ >>comment ] }
  58                 { "expires" [ [ cookie-string>timestamp >>expires ] unless-empty ] }
  59                 { "max-age" [ string>number seconds >>max-age ] }
  60                 { "domain" [ >>domain ] }
  61                 { "path" [ >>path ] }
  62                 { "httponly" [ drop t >>http-only ] }
  63                 { "secure" [ drop t >>secure ] }
  64                 [ drop rot <cookie> dup , ]
  65             } case nip
  66         ] assoc-each
  67         drop
  68     ] { } make ;
  69
  70 : parse-cookie ( string -- seq )
  71     [
  72         f swap
  73         (parse-cookie)
  74         [
  75             swap {
  76                 { "$version" [ >>version ] }
  77                 { "$domain" [ >>domain ] }
  78                 { "$path" [ >>path ] }
  79                 [ <cookie> dup , nip ]
  80             } case
  81         ] assoc-each
  82         drop
  83     ] { } make ;
  84
  85 : check-cookie-string ( string -- string' )
  86     dup "=;'\"\r\n" intersects?
  87     [ "Bad cookie name or value" throw ] when ;
  88
  89 : unparse-cookie-value ( key value -- )
  90     {
  91         { f [ drop ] }
  92         { t [ check-cookie-string , ] }
  93         [
  94             {
  95                 { [ dup timestamp? ] [ timestamp>cookie-string ] }
  96                 { [ dup duration? ] [ duration>seconds number>string ] }
  97                 { [ dup real? ] [ number>string ] }
  98                 [ ]
  99             } cond
 100             [ check-cookie-string ] bi@ "=" glue ,
 101         ]
 102     } case ;
 103
 104 : check-cookie-value ( string -- string )
 105     [ "Cookie value must not be f" throw ] unless* ;
 106
 107 : (unparse-cookie) ( cookie -- strings )
 108     [
 109         dup name>> check-cookie-string
 110         over value>> check-cookie-value unparse-cookie-value
 111         "$path" over path>> unparse-cookie-value
 112         "$domain" over domain>> unparse-cookie-value
 113         drop
 114     ] { } make ;
 115
 116 : unparse-cookie ( cookies -- string )
 117     [ (unparse-cookie) ] map concat "; " join ;
 118
 119 : unparse-set-cookie ( cookie -- string )
 120     [
 121         dup name>> check-cookie-string
 122         over value>> check-cookie-value unparse-cookie-value
 123         "path" over path>> unparse-cookie-value
 124         "domain" over domain>> unparse-cookie-value
 125         "expires" over expires>> unparse-cookie-value
 126         "max-age" over max-age>> unparse-cookie-value
 127         "httponly" over http-only>> unparse-cookie-value
 128         "secure" over secure>> unparse-cookie-value
 129         drop
 130     ] { } make "; " join ;
 131
 132 TUPLE: request
 133     method
 134     url
 135     proxy-url
 136     version
 137     header
 138     post-data
 139     cookies
 140     redirects ;
 141
 142 : set-header ( request/response value key -- request/response )
 143     pick header>> set-at ;
 144
 145 : set-headers ( request/response assoc -- request/response )
 146     [ swap set-header ] assoc-each ; inline
 147
 148 : delete-header ( request/response key -- request/response )
 149     over header>> delete-at ;
 150
 151 : basic-auth ( username password -- str )
 152     ":" glue >base64 "Basic " "" prepend-as ;
 153
 154 : set-basic-auth ( request username password -- request )
 155     basic-auth "Authorization" set-header ;
 156
 157 : set-proxy-basic-auth ( request username password -- request )
 158     basic-auth "Proxy-Authorization" set-header ;
 159
 160 : <request> ( -- request )
 161     request new
 162         "1.1" >>version
 163         <url>
 164             H{ } clone >>query
 165         >>url
 166         <url> >>proxy-url
 167         H{ } clone >>header
 168         V{ } clone >>cookies
 169         "close" "Connection" set-header
 170         "Factor http.client" "User-Agent" set-header
 171         max-redirects >>redirects ;
 172
 173 : header ( request/response key -- value )
 174     swap header>> at ;
 175
 176 ! https://github.com/factor/factor/issues/2273
 177 ! https://observatory.mozilla.org/analyze/factorcode.org
 178 ! https://csp-evaluator.withgoogle.com/?csp=https://factorcode.org
 179 : add-modern-headers ( response -- response )
 180     "max-age=63072000; includeSubDomains; preload" "Strict-Transport-Security" set-header
 181     "nosniff" "X-Content-Type-Options" set-header
 182     "default-src https: 'unsafe-inline'; frame-ancestors 'none'; object-src 'none'; img-src 'self' data:;" "Content-Security-Policy" set-header
 183     "DENY" "X-Frame-Options" set-header
 184     "1; mode=block" "X-XSS-Protection" set-header ;
 185
 186 TUPLE: response
 187     version
 188     code
 189     message
 190     header
 191     cookies
 192     content-type
 193     content-charset
 194     content-encoding
 195     body ;
 196
 197 : <response> ( -- response )
 198     response new
 199         "1.1" >>version
 200         H{ } clone >>header
 201         "close" "Connection" set-header
 202         now timestamp>http-string "Date" set-header
 203         "Factor http.server" "Server" set-header
 204         ! XXX: add-modern-headers
 205         utf8 >>content-encoding
 206         V{ } clone >>cookies ;
 207
 208 M: response clone
 209     call-next-method
 210         [ clone ] change-header
 211         [ clone ] change-cookies ;
 212
 213 : get-cookie ( request/response name -- cookie/f )
 214     [ cookies>> ] dip '[ [ _ ] dip name>> = ] find nip ;
 215
 216 : delete-cookie ( request/response name -- )
 217     over cookies>> [ get-cookie ] dip remove! drop ;
 218
 219 : put-cookie ( request/response cookie -- request/response )
 220     [ name>> dupd get-cookie [ dupd delete-cookie ] when* ] keep
 221     over cookies>> push ;
 222
 223 TUPLE: raw-response
 224     version
 225     code
 226     message
 227     body ;
 228
 229 : <raw-response> ( -- response )
 230     raw-response new
 231         "1.1" >>version ;
 232
 233 TUPLE: post-data data params content-type content-encoding ;
 234
 235 : <post-data> ( content-type -- post-data )
 236     post-data new
 237         swap >>content-type ;
 238
 239 : parse-content-type-attributes ( string -- attributes )
 240     split-words harvest [
 241         "=" split1
 242         "\"" ?head drop "\"" ?tail drop
 243     ] { } map>assoc ;
 244
 245 : parse-content-type ( content-type -- type encoding )
 246     ";" split1
 247     parse-content-type-attributes "charset" of
 248     [ dup mime-type-encoding encoding>name ] unless* ;