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 assocs
4 sequences splitting sorting sets strings vectors hashtables
5 quotations arrays byte-arrays math.parser calendar
6 calendar.format present urls fry
7 io io.encodings io.encodings.iana io.encodings.binary
8 io.encodings.8-bit io.crlf
9 unicode.case unicode.categories
14 : (read-header) ( -- alist )
15 [ read-crlf dup f like ] [ parse-header-line ] produce nip ;
17 : collect-headers ( assoc -- assoc' )
18 H{ } clone [ '[ _ push-at ] assoc-each ] keep ;
20 : process-header ( alist -- assoc )
21 f swap [ [ swap or dup ] dip swap ] assoc-map nip
22 collect-headers [ "; " join ] assoc-map
25 : read-header ( -- assoc )
26 (read-header) process-header ;
28 : header-value>string ( value -- string )
30 { [ dup timestamp? ] [ timestamp>http-string ] }
31 { [ dup array? ] [ [ header-value>string ] map "; " join ] }
35 : check-header-string ( str -- str )
36 #! http://en.wikipedia.org/wiki/HTTP_Header_Injection
37 dup "\r\n" intersects?
38 [ "Header injection attack" throw ] when ;
40 : write-header ( assoc -- )
42 [ check-header-string write ": " write ]
43 [ header-value>string check-header-string write crlf ] bi*
46 TUPLE: cookie name value version comment path domain expires max-age http-only secure ;
48 : <cookie> ( value name -- cookie )
53 : parse-set-cookie ( string -- seq )
59 { "version" [ >>version ] }
60 { "comment" [ >>comment ] }
61 { "expires" [ cookie-string>timestamp >>expires ] }
62 { "max-age" [ string>number seconds >>max-age ] }
63 { "domain" [ >>domain ] }
65 { "httponly" [ drop t >>http-only ] }
66 { "secure" [ drop t >>secure ] }
67 [ <cookie> dup , nip ]
73 : parse-cookie ( string -- seq )
79 { "$version" [ >>version ] }
80 { "$domain" [ >>domain ] }
81 { "$path" [ >>path ] }
82 [ <cookie> dup , nip ]
88 : check-cookie-string ( string -- string' )
89 dup "=;'\"\r\n" intersects?
90 [ "Bad cookie name or value" throw ] when ;
92 : unparse-cookie-value ( key value -- )
95 { t [ check-cookie-string , ] }
98 { [ dup timestamp? ] [ timestamp>cookie-string ] }
99 { [ dup duration? ] [ duration>seconds number>string ] }
100 { [ dup real? ] [ number>string ] }
103 [ check-cookie-string ] bi@ "=" glue ,
107 : check-cookie-value ( string -- string )
108 [ "Cookie value must not be f" throw ] unless* ;
110 : (unparse-cookie) ( cookie -- strings )
112 dup name>> check-cookie-string >lower
113 over value>> check-cookie-value unparse-cookie-value
114 "$path" over path>> unparse-cookie-value
115 "$domain" over domain>> unparse-cookie-value
119 : unparse-cookie ( cookies -- string )
120 [ (unparse-cookie) ] map concat "; " join ;
122 : unparse-set-cookie ( cookie -- string )
124 dup name>> check-cookie-string >lower
125 over value>> check-cookie-value unparse-cookie-value
126 "path" over path>> unparse-cookie-value
127 "domain" over domain>> unparse-cookie-value
128 "expires" over expires>> unparse-cookie-value
129 "max-age" over max-age>> unparse-cookie-value
130 "httponly" over http-only>> unparse-cookie-value
131 "secure" over secure>> unparse-cookie-value
133 ] { } make "; " join ;
143 : set-header ( request/response value key -- request/response )
144 pick header>> set-at ;
146 : set-basic-auth ( request username password -- request )
147 ":" glue >base64 "Basic " prepend "Authorization" set-header ;
149 : <request> ( -- request )
157 "close" "connection" set-header
158 "Factor http.client" "user-agent" set-header ;
160 : header ( request/response key -- value )
174 : <response> ( -- response )
178 "close" "connection" set-header
179 now timestamp>http-string "date" set-header
180 "Factor http.server" "server" set-header
181 latin1 >>content-charset
182 V{ } clone >>cookies ;
186 [ clone ] change-header
187 [ clone ] change-cookies ;
189 : get-cookie ( request/response name -- cookie/f )
190 [ cookies>> ] dip '[ [ _ ] dip name>> = ] find nip ;
192 : delete-cookie ( request/response name -- )
193 over cookies>> [ get-cookie ] dip delete ;
195 : put-cookie ( request/response cookie -- request/response )
196 [ name>> dupd get-cookie [ dupd delete-cookie ] when* ] keep
197 over cookies>> push ;
205 : <raw-response> ( -- response )
209 TUPLE: post-data data params content-type content-encoding ;
211 : <post-data> ( content-type -- post-data )
213 swap >>content-type ;
215 : parse-content-type-attributes ( string -- attributes )
218 [ >lower ] [ "\"" ?head drop "\"" ?tail drop ] bi*
221 : parse-content-type ( content-type -- type encoding )
223 parse-content-type-attributes "charset" swap at
225 [ dup "text/" head? latin1 binary ? ] if* ;