-! Copyright (C) 2003, 2008 Slava Pestov.
+! 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.8-bit io.crlf
-unicode.case unicode.categories
-http.parsers
-base64 ;
+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 ;
} 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 ;
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 ;
: (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
: 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
] { } make "; " join ;
TUPLE: request
-method
-url
-version
-header
-post-data
-cookies ;
+ 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
-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
- latin1 >>content-charset
+ "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 ;
M: response clone
[ cookies>> ] dip '[ [ _ ] dip name>> = ] find nip ;
: delete-cookie ( request/response name -- )
- over cookies>> [ get-cookie ] dip delete ;
+ over cookies>> [ get-cookie ] dip remove! drop ;
: put-cookie ( request/response cookie -- request/response )
[ name>> dupd get-cookie [ dupd delete-cookie ] when* ] keep
over cookies>> push ;
TUPLE: raw-response
-version
-code
-message
-body ;
+ version
+ code
+ message
+ body ;
: <raw-response> ( -- response )
raw-response new
swap >>content-type ;
: parse-content-type-attributes ( string -- attributes )
- " " split harvest [
+ split-words harvest [
"=" split1
- [ >lower ] [ "\"" ?head drop "\"" ?tail drop ] bi*
+ "\"" ?head drop "\"" ?tail drop
] { } map>assoc ;
: parse-content-type ( content-type -- type encoding )
";" split1
- parse-content-type-attributes "charset" swap at
- [ name>encoding ]
- [ dup "text/" head? latin1 binary ? ] if* ;
+ parse-content-type-attributes "charset" of
+ [ dup mime-type-encoding encoding>name ] unless* ;
projects / factor.git / blobdiff