factor: trim using lists

[factor.git] / basis / http / http.factor

diff --git a/basis/http/http.factor b/basis/http/http.factor
index 46b67b53216e76f313a54745907eb212baa1117b..a9995ef3c2275f4afdf7f2c6ebced740da5d61bd 100644 (file)
--- a/basis/http/http.factor
+++ b/basis/http/http.factor
@@ -1,17 +1,15 @@
 ! Copyright (C) 2003, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel combinators math namespaces make assocs
-sequences splitting sorting sets strings vectors hashtables
-quotations arrays byte-arrays math.parser calendar
-calendar.format present urls fry io io.encodings
-io.encodings.iana io.encodings.binary io.encodings.utf8 io.crlf
-ascii io.encodings.8-bit.latin1 http.parsers base64 mime.types ;
+USING: accessors arrays ascii assocs base64 calendar calendar.format
+calendar.parser combinators hashtables http.parsers io io.crlf
+io.encodings.iana io.encodings.utf8 kernel make math math.parser
+mime.types present sequences sets sorting splitting urls ;
 IN: http
 
 CONSTANT: max-redirects 10
 
 : (read-header) ( -- alist )
-    [ read-crlf dup f like ] [ parse-header-line ] produce nip ;
+    [ read-?crlf dup f like ] [ parse-header-line ] produce nip ;
 
 : collect-headers ( assoc -- assoc' )
     H{ } clone [ '[ _ push-at ] assoc-each ] keep ;
@@ -32,12 +30,12 @@ CONSTANT: max-redirects 10
     } cond ;
 
 : check-header-string ( str -- str )
-    #! http://en.wikipedia.org/wiki/HTTP_Header_Injection
+    ! http://en.wikipedia.org/wiki/HTTP_Header_Injection
     dup "\r\n" intersects?
     [ "Header injection attack" throw ] when ;
 
 : write-header ( assoc -- )
-    >alist sort-keys [
+    sort-keys [
         [ check-header-string write ": " write ]
         [ header-value>string check-header-string write crlf ] bi*
     ] assoc-each crlf ;
@@ -54,17 +52,17 @@ TUPLE: cookie name value version comment path domain expires max-age http-only s
         f swap
         (parse-set-cookie)
         [
-            swap {
+            swapd pick >lower {
                 { "version" [ >>version ] }
                 { "comment" [ >>comment ] }
-                { "expires" [ cookie-string>timestamp >>expires ] }
+                { "expires" [ [ cookie-string>timestamp >>expires ] unless-empty ] }
                 { "max-age" [ string>number seconds >>max-age ] }
                 { "domain" [ >>domain ] }
                 { "path" [ >>path ] }
                 { "httponly" [ drop t >>http-only ] }
                 { "secure" [ drop t >>secure ] }
-                [ <cookie> dup , nip ]
-            } case
+                [ drop rot <cookie> dup , ]
+            } case nip
         ] assoc-each
         drop
     ] { } make ;
@@ -108,7 +106,7 @@ TUPLE: cookie name value version comment path domain expires max-age http-only s
 
 : (unparse-cookie) ( cookie -- strings )
     [
-        dup name>> check-cookie-string >lower
+        dup name>> check-cookie-string
         over value>> check-cookie-value unparse-cookie-value
         "$path" over path>> unparse-cookie-value
         "$domain" over domain>> unparse-cookie-value
@@ -120,7 +118,7 @@ TUPLE: cookie name value version comment path domain expires max-age http-only s
 
 : unparse-set-cookie ( cookie -- string )
     [
-        dup name>> check-cookie-string >lower
+        dup name>> check-cookie-string
         over value>> check-cookie-value unparse-cookie-value
         "path" over path>> unparse-cookie-value
         "domain" over domain>> unparse-cookie-value
@@ -132,54 +130,72 @@ TUPLE: cookie name value version comment path domain expires max-age http-only s
     ] { } make "; " join ;
 
 TUPLE: request
-method
-url
-version
-header
-post-data
-cookies
-redirects ;
+    method
+    url
+    proxy-url
+    version
+    header
+    post-data
+    cookies
+    redirects ;
 
 : set-header ( request/response value key -- request/response )
     pick header>> set-at ;
 
+: basic-auth ( username password -- str )
+    ":" glue >base64 "Basic " "" prepend-as ;
+
 : set-basic-auth ( request username password -- request )
-    ":" glue >base64 "Basic " prepend "Authorization" set-header ;
-    
+    basic-auth "Authorization" set-header ;
+
+: set-proxy-basic-auth ( request username password -- request )
+    basic-auth "Proxy-Authorization" set-header ;
+
 : <request> ( -- request )
     request new
         "1.1" >>version
         <url>
             H{ } clone >>query
         >>url
+        <url> >>proxy-url
         H{ } clone >>header
         V{ } clone >>cookies
-        "close" "connection" set-header
-        "Factor http.client" "user-agent" set-header
+        "close" "Connection" set-header
+        "Factor http.client" "User-Agent" set-header
         max-redirects >>redirects ;
 
 : header ( request/response key -- value )
     swap header>> at ;
 
+! https://github.com/factor/factor/issues/2273
+! https://observatory.mozilla.org/analyze/factorcode.org
+! https://csp-evaluator.withgoogle.com/?csp=https://factorcode.org
+: add-modern-headers ( response -- response )
+    "max-age=63072000; includeSubDomains; preload" "Strict-Transport-Security" set-header
+    "nosniff" "X-Content-Type-Options" set-header
+    "default-src https: 'unsafe-inline'; frame-ancestors 'none'; object-src 'none'" "Content-Security-Policy" set-header
+    "DENY" "X-Frame-Options" set-header
+    "1; mode=block" "X-XSS-Protection" set-header ;
 
 TUPLE: response
-version
-code
-message
-header
-cookies
-content-type
-content-charset
-content-encoding
-body ;
+    version
+    code
+    message
+    header
+    cookies
+    content-type
+    content-charset
+    content-encoding
+    body ;
 
 : <response> ( -- response )
     response new
         "1.1" >>version
         H{ } clone >>header
-        "close" "connection" set-header
-        now timestamp>http-string "date" set-header
-        "Factor http.server" "server" set-header
+        "close" "Connection" set-header
+        now timestamp>http-string "Date" set-header
+        "Factor http.server" "Server" set-header
+        add-modern-headers
         utf8 >>content-encoding
         V{ } clone >>cookies ;
 
@@ -199,10 +215,10 @@ M: response clone
     over cookies>> push ;
 
 TUPLE: raw-response
-version
-code
-message
-body ;
+    version
+    code
+    message
+    body ;
 
 : <raw-response> ( -- response )
     raw-response new
@@ -215,12 +231,12 @@ TUPLE: post-data data params content-type content-encoding ;
         swap >>content-type ;
 
 : parse-content-type-attributes ( string -- attributes )
-    " " split harvest [
+    split-words harvest [
         "=" split1
         "\"" ?head drop "\"" ?tail drop
     ] { } map>assoc ;
 
 : parse-content-type ( content-type -- type encoding )
     ";" split1
-    parse-content-type-attributes "charset" swap at
+    parse-content-type-attributes "charset" of
     [ dup mime-type-encoding encoding>name ] unless* ;