1 ! Copyright (C) 2003, 2010 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays ascii assocs base64 calendar calendar.format
4 calendar.parser combinators fry 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 ;
9 CONSTANT: max-redirects 10
11 : (read-header) ( -- alist )
12 [ read-?crlf dup f like ] [ parse-header-line ] produce nip ;
14 : collect-headers ( assoc -- assoc' )
15 H{ } clone [ '[ _ push-at ] assoc-each ] keep ;
17 : process-header ( alist -- assoc )
18 f swap [ [ swap or dup ] dip swap ] assoc-map nip
19 collect-headers [ "; " join ] assoc-map
22 : read-header ( -- assoc )
23 (read-header) process-header ;
25 : header-value>string ( value -- string )
27 { [ dup timestamp? ] [ timestamp>http-string ] }
28 { [ dup array? ] [ [ header-value>string ] map "; " join ] }
32 : check-header-string ( str -- str )
33 ! http://en.wikipedia.org/wiki/HTTP_Header_Injection
34 dup "\r\n" intersects?
35 [ "Header injection attack" throw ] when ;
37 : write-header ( assoc -- )
39 [ check-header-string write ": " write ]
40 [ header-value>string check-header-string write crlf ] bi*
43 TUPLE: cookie name value version comment path domain expires max-age http-only secure ;
45 : <cookie> ( value name -- cookie )
50 : parse-set-cookie ( string -- seq )
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 ] }
62 { "httponly" [ drop t >>http-only ] }
63 { "secure" [ drop t >>secure ] }
64 [ drop rot <cookie> dup , ]
70 : parse-cookie ( string -- seq )
76 { "$version" [ >>version ] }
77 { "$domain" [ >>domain ] }
78 { "$path" [ >>path ] }
79 [ <cookie> dup , nip ]
85 : check-cookie-string ( string -- string' )
86 dup "=;'\"\r\n" intersects?
87 [ "Bad cookie name or value" throw ] when ;
89 : unparse-cookie-value ( key value -- )
92 { t [ check-cookie-string , ] }
95 { [ dup timestamp? ] [ timestamp>cookie-string ] }
96 { [ dup duration? ] [ duration>seconds number>string ] }
97 { [ dup real? ] [ number>string ] }
100 [ check-cookie-string ] bi@ "=" glue ,
104 : check-cookie-value ( string -- string )
105 [ "Cookie value must not be f" throw ] unless* ;
107 : (unparse-cookie) ( cookie -- strings )
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
116 : unparse-cookie ( cookies -- string )
117 [ (unparse-cookie) ] map concat "; " join ;
119 : unparse-set-cookie ( cookie -- string )
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
130 ] { } make "; " join ;
142 : set-header ( request/response value key -- request/response )
143 pick header>> set-at ;
145 : basic-auth ( username password -- str )
146 ":" glue >base64 "Basic " "" prepend-as ;
148 : set-basic-auth ( request username password -- request )
149 basic-auth "Authorization" set-header ;
151 : set-proxy-basic-auth ( request username password -- request )
152 basic-auth "Proxy-Authorization" set-header ;
154 : <request> ( -- request )
163 "close" "Connection" set-header
164 "Factor http.client" "User-Agent" set-header
165 max-redirects >>redirects ;
167 : header ( request/response key -- value )
182 : <response> ( -- response )
186 "close" "Connection" set-header
187 now timestamp>http-string "Date" set-header
188 "Factor http.server" "Server" set-header
189 utf8 >>content-encoding
190 V{ } clone >>cookies ;
194 [ clone ] change-header
195 [ clone ] change-cookies ;
197 : get-cookie ( request/response name -- cookie/f )
198 [ cookies>> ] dip '[ [ _ ] dip name>> = ] find nip ;
200 : delete-cookie ( request/response name -- )
201 over cookies>> [ get-cookie ] dip remove! drop ;
203 : put-cookie ( request/response cookie -- request/response )
204 [ name>> dupd get-cookie [ dupd delete-cookie ] when* ] keep
205 over cookies>> push ;
213 : <raw-response> ( -- response )
217 TUPLE: post-data data params content-type content-encoding ;
219 : <post-data> ( content-type -- post-data )
221 swap >>content-type ;
223 : parse-content-type-attributes ( string -- attributes )
226 "\"" ?head drop "\"" ?tail drop
229 : parse-content-type ( content-type -- type encoding )
231 parse-content-type-attributes "charset" of
232 [ dup mime-type-encoding encoding>name ] unless* ;