2008-02-25 15:53:18 -05:00
|
|
|
! Copyright (C) 2003, 2008 Slava Pestov.
|
2007-09-20 18:09:08 -04:00
|
|
|
! See http://factorcode.org/license.txt for BSD license.
|
2008-12-08 21:04:13 -05:00
|
|
|
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
|
2008-04-22 21:23:49 -04:00
|
|
|
|
2008-06-16 02:35:06 -04:00
|
|
|
io io.encodings io.encodings.iana io.encodings.binary
|
|
|
|
io.encodings.8-bit
|
2008-04-22 21:23:49 -04:00
|
|
|
|
2008-05-26 01:47:27 -04:00
|
|
|
unicode.case unicode.categories qualified
|
|
|
|
|
2008-06-18 01:36:20 -04:00
|
|
|
http.parsers ;
|
2008-04-22 21:23:49 -04:00
|
|
|
|
|
|
|
EXCLUDE: fry => , ;
|
|
|
|
|
2007-09-20 18:09:08 -04:00
|
|
|
IN: http
|
|
|
|
|
2008-06-09 03:14:14 -04:00
|
|
|
: crlf ( -- ) "\r\n" write ;
|
2008-02-29 01:57:38 -05:00
|
|
|
|
2008-06-12 04:50:20 -04:00
|
|
|
: read-crlf ( -- bytes )
|
2008-04-22 21:23:49 -04:00
|
|
|
"\r" read-until
|
2008-04-23 01:53:42 -04:00
|
|
|
[ CHAR: \r assert= read1 CHAR: \n assert= ] when* ;
|
2008-04-22 21:23:49 -04:00
|
|
|
|
2008-06-18 01:36:20 -04:00
|
|
|
: (read-header) ( -- alist )
|
2008-07-10 02:00:27 -04:00
|
|
|
[ read-crlf dup f like ] [ parse-header-line ] [ drop ] produce ;
|
2008-06-18 01:36:20 -04:00
|
|
|
|
2008-09-05 20:29:14 -04:00
|
|
|
: collect-headers ( assoc -- assoc' )
|
2008-09-10 23:11:40 -04:00
|
|
|
H{ } clone [ '[ _ push-at ] assoc-each ] keep ;
|
2008-09-05 20:29:14 -04:00
|
|
|
|
2008-06-18 01:36:20 -04:00
|
|
|
: process-header ( alist -- assoc )
|
|
|
|
f swap [ [ swap or dup ] dip swap ] assoc-map nip
|
2008-09-05 20:29:14 -04:00
|
|
|
collect-headers [ "; " join ] assoc-map
|
2008-06-18 01:36:20 -04:00
|
|
|
>hashtable ;
|
2008-02-29 01:57:38 -05:00
|
|
|
|
|
|
|
: read-header ( -- assoc )
|
2008-06-18 01:36:20 -04:00
|
|
|
(read-header) process-header ;
|
2008-02-29 01:57:38 -05:00
|
|
|
|
|
|
|
: header-value>string ( value -- string )
|
|
|
|
{
|
|
|
|
{ [ dup timestamp? ] [ timestamp>http-string ] }
|
2008-06-05 01:18:36 -04:00
|
|
|
{ [ dup array? ] [ [ header-value>string ] map "; " join ] }
|
|
|
|
[ present ]
|
2008-02-29 01:57:38 -05:00
|
|
|
} cond ;
|
|
|
|
|
|
|
|
: check-header-string ( str -- str )
|
|
|
|
#! http://en.wikipedia.org/wiki/HTTP_Header_Injection
|
2008-06-18 01:36:20 -04:00
|
|
|
dup "\r\n\"" intersect empty?
|
2008-03-11 04:39:09 -04:00
|
|
|
[ "Header injection attack" throw ] unless ;
|
2008-02-29 01:57:38 -05:00
|
|
|
|
|
|
|
: write-header ( assoc -- )
|
|
|
|
>alist sort-keys [
|
2008-06-18 01:36:20 -04:00
|
|
|
[ check-header-string write ": " write ]
|
|
|
|
[ header-value>string check-header-string write crlf ] bi*
|
2008-02-29 01:57:38 -05:00
|
|
|
] assoc-each crlf ;
|
|
|
|
|
2008-06-18 01:36:20 -04:00
|
|
|
TUPLE: cookie name value version comment path domain expires max-age http-only secure ;
|
2008-02-29 01:57:38 -05:00
|
|
|
|
|
|
|
: <cookie> ( value name -- cookie )
|
2008-04-13 16:06:27 -04:00
|
|
|
cookie new
|
2008-04-27 04:09:00 -04:00
|
|
|
swap >>name
|
|
|
|
swap >>value ;
|
2008-02-29 01:57:38 -05:00
|
|
|
|
2008-06-18 01:36:20 -04:00
|
|
|
: parse-set-cookie ( string -- seq )
|
2008-02-29 01:57:38 -05:00
|
|
|
[
|
|
|
|
f swap
|
2008-06-18 01:36:20 -04:00
|
|
|
(parse-set-cookie)
|
|
|
|
[
|
|
|
|
swap {
|
|
|
|
{ "version" [ >>version ] }
|
|
|
|
{ "comment" [ >>comment ] }
|
2008-04-27 04:09:00 -04:00
|
|
|
{ "expires" [ cookie-string>timestamp >>expires ] }
|
2008-04-27 05:27:04 -04:00
|
|
|
{ "max-age" [ string>number seconds >>max-age ] }
|
2008-02-29 01:57:38 -05:00
|
|
|
{ "domain" [ >>domain ] }
|
|
|
|
{ "path" [ >>path ] }
|
|
|
|
{ "httponly" [ drop t >>http-only ] }
|
2008-06-18 01:36:20 -04:00
|
|
|
{ "secure" [ drop t >>secure ] }
|
2008-02-29 01:57:38 -05:00
|
|
|
[ <cookie> dup , nip ]
|
|
|
|
} case
|
2008-06-18 01:36:20 -04:00
|
|
|
] assoc-each
|
|
|
|
drop
|
|
|
|
] { } make ;
|
2008-02-29 01:57:38 -05:00
|
|
|
|
2008-06-18 01:36:20 -04:00
|
|
|
: parse-cookie ( string -- seq )
|
|
|
|
[
|
|
|
|
f swap
|
|
|
|
(parse-cookie)
|
|
|
|
[
|
|
|
|
swap {
|
|
|
|
{ "$version" [ >>version ] }
|
|
|
|
{ "$domain" [ >>domain ] }
|
|
|
|
{ "$path" [ >>path ] }
|
|
|
|
[ <cookie> dup , nip ]
|
|
|
|
} case
|
|
|
|
] assoc-each
|
2008-02-29 01:57:38 -05:00
|
|
|
drop
|
|
|
|
] { } make ;
|
|
|
|
|
2008-06-16 06:16:51 -04:00
|
|
|
: check-cookie-string ( string -- string' )
|
2008-06-18 01:36:20 -04:00
|
|
|
dup "=;'\"\r\n" intersect empty?
|
2008-06-16 06:16:51 -04:00
|
|
|
[ "Bad cookie name or value" throw ] unless ;
|
|
|
|
|
2008-06-18 01:36:20 -04:00
|
|
|
: unparse-cookie-value ( key value -- )
|
2008-02-29 01:57:38 -05:00
|
|
|
{
|
2008-04-11 13:55:57 -04:00
|
|
|
{ f [ drop ] }
|
2008-06-16 06:16:51 -04:00
|
|
|
{ t [ check-cookie-string , ] }
|
2008-04-27 04:09:00 -04:00
|
|
|
[
|
|
|
|
{
|
|
|
|
{ [ dup timestamp? ] [ timestamp>cookie-string ] }
|
2008-09-01 21:09:51 -04:00
|
|
|
{ [ dup duration? ] [ duration>seconds number>string ] }
|
2008-06-16 06:16:51 -04:00
|
|
|
{ [ dup real? ] [ number>string ] }
|
2008-04-27 04:09:00 -04:00
|
|
|
[ ]
|
|
|
|
} cond
|
2008-12-03 20:13:18 -05:00
|
|
|
[ check-cookie-string ] bi@ "=" glue ,
|
2008-04-27 04:09:00 -04:00
|
|
|
]
|
2008-04-11 13:55:57 -04:00
|
|
|
} case ;
|
2008-02-29 01:57:38 -05:00
|
|
|
|
2008-07-09 18:04:20 -04:00
|
|
|
: check-cookie-value ( string -- string )
|
|
|
|
[ "Cookie value must not be f" throw ] unless* ;
|
|
|
|
|
2008-06-18 01:36:20 -04:00
|
|
|
: (unparse-cookie) ( cookie -- strings )
|
2008-02-29 01:57:38 -05:00
|
|
|
[
|
2008-06-16 06:16:51 -04:00
|
|
|
dup name>> check-cookie-string >lower
|
2008-07-09 18:04:20 -04:00
|
|
|
over value>> check-cookie-value unparse-cookie-value
|
2008-06-18 01:36:20 -04:00
|
|
|
"$path" over path>> unparse-cookie-value
|
|
|
|
"$domain" over domain>> unparse-cookie-value
|
2008-02-29 01:57:38 -05:00
|
|
|
drop
|
|
|
|
] { } make ;
|
|
|
|
|
2008-06-18 01:36:20 -04:00
|
|
|
: unparse-cookie ( cookies -- string )
|
|
|
|
[ (unparse-cookie) ] map concat "; " join ;
|
|
|
|
|
|
|
|
: unparse-set-cookie ( cookie -- string )
|
|
|
|
[
|
|
|
|
dup name>> check-cookie-string >lower
|
2008-07-09 18:04:20 -04:00
|
|
|
over value>> check-cookie-value unparse-cookie-value
|
2008-06-18 01:36:20 -04:00
|
|
|
"path" over path>> unparse-cookie-value
|
|
|
|
"domain" over domain>> unparse-cookie-value
|
|
|
|
"expires" over expires>> unparse-cookie-value
|
|
|
|
"max-age" over max-age>> unparse-cookie-value
|
|
|
|
"httponly" over http-only>> unparse-cookie-value
|
|
|
|
"secure" over secure>> unparse-cookie-value
|
|
|
|
drop
|
|
|
|
] { } make "; " join ;
|
2008-02-29 01:57:38 -05:00
|
|
|
|
2008-02-25 15:53:18 -05:00
|
|
|
TUPLE: request
|
|
|
|
method
|
2008-06-01 18:22:39 -04:00
|
|
|
url
|
2008-02-25 15:53:18 -05:00
|
|
|
version
|
|
|
|
header
|
|
|
|
post-data
|
2008-02-29 01:57:38 -05:00
|
|
|
cookies ;
|
2008-02-25 15:53:18 -05:00
|
|
|
|
2008-04-22 15:37:26 -04:00
|
|
|
: set-header ( request/response value key -- request/response )
|
|
|
|
pick header>> set-at ;
|
|
|
|
|
2008-06-09 03:14:14 -04:00
|
|
|
: <request> ( -- request )
|
2008-04-13 16:06:27 -04:00
|
|
|
request new
|
2008-03-13 23:14:32 -04:00
|
|
|
"1.1" >>version
|
2008-06-01 18:22:39 -04:00
|
|
|
<url>
|
|
|
|
H{ } clone >>query
|
|
|
|
>>url
|
2008-03-15 07:22:47 -04:00
|
|
|
H{ } clone >>header
|
2008-04-22 15:37:26 -04:00
|
|
|
V{ } clone >>cookies
|
2008-05-20 19:24:32 -04:00
|
|
|
"close" "connection" set-header
|
2008-06-16 04:34:17 -04:00
|
|
|
"Factor http.client" "user-agent" set-header ;
|
2008-02-29 01:57:38 -05:00
|
|
|
|
|
|
|
: header ( request/response key -- value )
|
|
|
|
swap header>> at ;
|
|
|
|
|
2008-02-25 15:53:18 -05:00
|
|
|
TUPLE: response
|
|
|
|
version
|
|
|
|
code
|
|
|
|
message
|
2008-02-29 01:57:38 -05:00
|
|
|
header
|
|
|
|
cookies
|
2008-05-01 17:24:50 -04:00
|
|
|
content-type
|
|
|
|
content-charset
|
2008-02-29 01:57:38 -05:00
|
|
|
body ;
|
2008-02-25 15:53:18 -05:00
|
|
|
|
2008-06-09 03:14:14 -04:00
|
|
|
: <response> ( -- response )
|
2008-04-13 16:06:27 -04:00
|
|
|
response new
|
2008-04-22 15:37:26 -04:00
|
|
|
"1.1" >>version
|
|
|
|
H{ } clone >>header
|
|
|
|
"close" "connection" set-header
|
|
|
|
now timestamp>http-string "date" set-header
|
2008-06-16 04:34:17 -04:00
|
|
|
"Factor http.server" "server" set-header
|
2008-06-12 04:50:20 -04:00
|
|
|
latin1 >>content-charset
|
2008-04-22 15:37:26 -04:00
|
|
|
V{ } clone >>cookies ;
|
2008-02-25 15:53:18 -05:00
|
|
|
|
2008-06-16 02:35:06 -04:00
|
|
|
M: response clone
|
|
|
|
call-next-method
|
|
|
|
[ clone ] change-header
|
|
|
|
[ clone ] change-cookies ;
|
|
|
|
|
2008-02-29 01:57:38 -05:00
|
|
|
: get-cookie ( request/response name -- cookie/f )
|
2008-09-10 23:11:40 -04:00
|
|
|
[ cookies>> ] dip '[ [ _ ] dip name>> = ] find nip ;
|
2008-02-29 01:57:38 -05:00
|
|
|
|
|
|
|
: delete-cookie ( request/response name -- )
|
2008-05-26 01:47:27 -04:00
|
|
|
over cookies>> [ get-cookie ] dip delete ;
|
2008-02-29 01:57:38 -05:00
|
|
|
|
|
|
|
: put-cookie ( request/response cookie -- request/response )
|
2008-03-11 04:39:09 -04:00
|
|
|
[ name>> dupd get-cookie [ dupd delete-cookie ] when* ] keep
|
2008-02-29 01:57:38 -05:00
|
|
|
over cookies>> push ;
|
|
|
|
|
2008-05-01 17:24:50 -04:00
|
|
|
TUPLE: raw-response
|
2008-02-29 01:57:38 -05:00
|
|
|
version
|
|
|
|
code
|
|
|
|
message
|
|
|
|
body ;
|
|
|
|
|
|
|
|
: <raw-response> ( -- response )
|
2008-04-13 16:06:27 -04:00
|
|
|
raw-response new
|
2008-06-02 16:00:03 -04:00
|
|
|
"1.1" >>version ;
|
2008-02-29 01:57:38 -05:00
|
|
|
|
2008-07-02 22:52:28 -04:00
|
|
|
TUPLE: post-data raw content content-type ;
|
|
|
|
|
|
|
|
: <post-data> ( raw content-type -- post-data )
|
|
|
|
post-data new
|
|
|
|
swap >>content-type
|
|
|
|
swap >>raw ;
|
2008-02-25 15:53:18 -05:00
|
|
|
|
2008-07-02 22:52:28 -04:00
|
|
|
: parse-content-type-attributes ( string -- attributes )
|
|
|
|
" " split harvest [ "=" split1 [ >lower ] dip ] { } map>assoc ;
|
|
|
|
|
|
|
|
: parse-content-type ( content-type -- type encoding )
|
|
|
|
";" split1 parse-content-type-attributes "charset" swap at
|
|
|
|
name>encoding over "text/" head? latin1 binary ? or ;
|