Merge branch 'master' of git://factorcode.org/git/factor into unicode
Conflicts: extra/http/client/client.factor extra/http/server/server.factor extra/http/server/templating/templating.factor extra/webapps/cgi/cgi.factor extra/webapps/file/file.factor extra/webapps/source/source.factordb4
Daniel Ehrenberg
commit
5805db7ac4
|
|
@ -56,8 +56,8 @@ UNION: c a b ;
|
||||||
[ t ] [ \ c \ tuple class< ] unit-test
|
[ t ] [ \ c \ tuple class< ] unit-test
|
||||||
[ f ] [ \ tuple \ c class< ] unit-test
|
[ f ] [ \ tuple \ c class< ] unit-test
|
||||||
|
|
||||||
DEFER: bah
|
! DEFER: bah
|
||||||
FORGET: bah
|
! FORGET: bah
|
||||||
UNION: bah fixnum alien ;
|
UNION: bah fixnum alien ;
|
||||||
[ bah ] [ \ bah? "predicating" word-prop ] unit-test
|
[ bah ] [ \ bah? "predicating" word-prop ] unit-test
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -25,8 +25,6 @@ GENERIC: make-default-method ( generic combination -- method )
|
||||||
|
|
||||||
PREDICATE: word generic "combination" word-prop >boolean ;
|
PREDICATE: word generic "combination" word-prop >boolean ;
|
||||||
|
|
||||||
M: generic definer drop f f ;
|
|
||||||
|
|
||||||
M: generic definition drop f ;
|
M: generic definition drop f ;
|
||||||
|
|
||||||
: make-generic ( word -- )
|
: make-generic ( word -- )
|
||||||
|
|
|
||||||
|
|
@ -141,7 +141,7 @@ SYMBOL: quot-uses-b
|
||||||
|
|
||||||
[ { + } ] [ \ quot-uses-b uses ] unit-test
|
[ { + } ] [ \ quot-uses-b uses ] unit-test
|
||||||
|
|
||||||
[ "IN: words.tests : undef-test ; << undef-test >>" eval ]
|
[ "IN: words.tests FORGET: undef-test : undef-test ; << undef-test >>" eval ]
|
||||||
[ [ undefined? ] is? ] must-fail-with
|
[ [ undefined? ] is? ] must-fail-with
|
||||||
|
|
||||||
[ ] [
|
[ ] [
|
||||||
|
|
|
||||||
|
|
@ -68,7 +68,7 @@ SYMBOL: bootstrapping?
|
||||||
: crossref? ( word -- ? )
|
: crossref? ( word -- ? )
|
||||||
{
|
{
|
||||||
{ [ dup "forgotten" word-prop ] [ f ] }
|
{ [ dup "forgotten" word-prop ] [ f ] }
|
||||||
{ [ dup "method-definition" word-prop ] [ t ] }
|
{ [ dup "method-def" word-prop ] [ t ] }
|
||||||
{ [ dup word-vocabulary ] [ t ] }
|
{ [ dup word-vocabulary ] [ t ] }
|
||||||
{ [ t ] [ f ] }
|
{ [ t ] [ f ] }
|
||||||
} cond nip ;
|
} cond nip ;
|
||||||
|
|
|
||||||
|
|
@ -16,13 +16,16 @@ IN: assocs.lib
|
||||||
: at-default ( key assoc -- value/key )
|
: at-default ( key assoc -- value/key )
|
||||||
dupd at [ nip ] when* ;
|
dupd at [ nip ] when* ;
|
||||||
|
|
||||||
|
: replace-at ( assoc value key -- assoc )
|
||||||
|
>r >r dup r> 1vector r> rot set-at ;
|
||||||
|
|
||||||
: insert-at ( value key assoc -- )
|
: insert-at ( value key assoc -- )
|
||||||
[ ?push ] change-at ;
|
[ ?push ] change-at ;
|
||||||
|
|
||||||
: peek-at* ( key assoc -- obj ? )
|
: peek-at* ( assoc key -- obj ? )
|
||||||
at* dup [ >r peek r> ] when ;
|
swap at* dup [ >r peek r> ] when ;
|
||||||
|
|
||||||
: peek-at ( key assoc -- obj )
|
: peek-at ( assoc key -- obj )
|
||||||
peek-at* drop ;
|
peek-at* drop ;
|
||||||
|
|
||||||
: >multi-assoc ( assoc -- new-assoc )
|
: >multi-assoc ( assoc -- new-assoc )
|
||||||
|
|
|
||||||
|
|
@ -21,7 +21,7 @@ IN: benchmark
|
||||||
] with-row
|
] with-row
|
||||||
[
|
[
|
||||||
[
|
[
|
||||||
swap [ ($vocab-link) ] with-cell
|
swap [ dup ($vocab-link) ] with-cell
|
||||||
first2 pprint-cell pprint-cell
|
first2 pprint-cell pprint-cell
|
||||||
] with-row
|
] with-row
|
||||||
] assoc-each
|
] assoc-each
|
||||||
|
|
|
||||||
|
|
@ -112,7 +112,7 @@ FUNCTION: int sqlite3_prepare ( sqlite3* pDb, char* zSql, int nBytes, void* ppSt
|
||||||
FUNCTION: int sqlite3_finalize ( sqlite3_stmt* pStmt ) ;
|
FUNCTION: int sqlite3_finalize ( sqlite3_stmt* pStmt ) ;
|
||||||
FUNCTION: int sqlite3_reset ( sqlite3_stmt* pStmt ) ;
|
FUNCTION: int sqlite3_reset ( sqlite3_stmt* pStmt ) ;
|
||||||
FUNCTION: int sqlite3_step ( sqlite3_stmt* pStmt ) ;
|
FUNCTION: int sqlite3_step ( sqlite3_stmt* pStmt ) ;
|
||||||
FUNCTION: int sqlite3_last_insert_rowid ( sqlite3* pStmt ) ;
|
FUNCTION: sqlite3_int64 sqlite3_last_insert_rowid ( sqlite3* pStmt ) ;
|
||||||
FUNCTION: int sqlite3_bind_blob ( sqlite3_stmt* pStmt, int index, void* ptr, int len, int destructor ) ;
|
FUNCTION: int sqlite3_bind_blob ( sqlite3_stmt* pStmt, int index, void* ptr, int len, int destructor ) ;
|
||||||
FUNCTION: int sqlite3_bind_double ( sqlite3_stmt* pStmt, int index, double x ) ;
|
FUNCTION: int sqlite3_bind_double ( sqlite3_stmt* pStmt, int index, double x ) ;
|
||||||
FUNCTION: int sqlite3_bind_int ( sqlite3_stmt* pStmt, int index, int n ) ;
|
FUNCTION: int sqlite3_bind_int ( sqlite3_stmt* pStmt, int index, int n ) ;
|
||||||
|
|
|
||||||
|
|
@ -179,8 +179,8 @@ M: sqlite-db <select-by-slots-statement> ( tuple class -- statement )
|
||||||
" where " 0%
|
" where " 0%
|
||||||
[ ", " 0% ]
|
[ ", " 0% ]
|
||||||
[ dup sql-spec-column-name 0% " = " 0% bind% ] interleave
|
[ dup sql-spec-column-name 0% " = " 0% bind% ] interleave
|
||||||
";" 0%
|
|
||||||
] if
|
] if
|
||||||
|
";" 0%
|
||||||
] sqlite-make ;
|
] sqlite-make ;
|
||||||
|
|
||||||
M: sqlite-db modifier-table ( -- hashtable )
|
M: sqlite-db modifier-table ( -- hashtable )
|
||||||
|
|
|
||||||
|
|
@ -103,7 +103,7 @@ HOOK: insert-tuple* db ( tuple statement -- )
|
||||||
db get db-delete-statements [ <delete-tuple-statement> ] cache
|
db get db-delete-statements [ <delete-tuple-statement> ] cache
|
||||||
[ bind-tuple ] keep execute-statement ;
|
[ bind-tuple ] keep execute-statement ;
|
||||||
|
|
||||||
: select-tuples ( tuple -- tuple )
|
: select-tuples ( tuple -- tuples )
|
||||||
dup dup class <select-by-slots-statement> [
|
dup dup class <select-by-slots-statement> [
|
||||||
[ bind-tuple ] keep query-tuples
|
[ bind-tuple ] keep query-tuples
|
||||||
] with-disposal ;
|
] with-disposal ;
|
||||||
|
|
|
||||||
|
|
@ -39,7 +39,8 @@ M: tuple-class group-words
|
||||||
: define-mimic ( group mimicker mimicked -- )
|
: define-mimic ( group mimicker mimicked -- )
|
||||||
>r >r group-words r> r> [
|
>r >r group-words r> r> [
|
||||||
pick "methods" word-prop at dup
|
pick "methods" word-prop at dup
|
||||||
[ method-def spin define-method ] [ 3drop ] if
|
[ "method-def" word-prop spin define-method ]
|
||||||
|
[ 3drop ] if
|
||||||
] 2curry each ;
|
] 2curry each ;
|
||||||
|
|
||||||
: MIMIC:
|
: MIMIC:
|
||||||
|
|
|
||||||
|
|
@ -35,6 +35,17 @@ SYMBOL: current-action
|
||||||
SYMBOL: validators-errored
|
SYMBOL: validators-errored
|
||||||
SYMBOL: validation-errors
|
SYMBOL: validation-errors
|
||||||
|
|
||||||
|
: build-url ( str query-params -- newstr )
|
||||||
|
[
|
||||||
|
over %
|
||||||
|
dup assoc-empty? [
|
||||||
|
2drop
|
||||||
|
] [
|
||||||
|
CHAR: ? rot member? "&" "?" ? %
|
||||||
|
assoc>query %
|
||||||
|
] if
|
||||||
|
] "" make ;
|
||||||
|
|
||||||
: action-link ( query action -- url )
|
: action-link ( query action -- url )
|
||||||
[
|
[
|
||||||
"/responder/" %
|
"/responder/" %
|
||||||
|
|
|
||||||
|
|
@ -173,7 +173,7 @@ M: f print-element drop ;
|
||||||
|
|
||||||
: $vocabulary ( element -- )
|
: $vocabulary ( element -- )
|
||||||
first word-vocabulary [
|
first word-vocabulary [
|
||||||
"Vocabulary" $heading nl ($vocab-link)
|
"Vocabulary" $heading nl dup ($vocab-link)
|
||||||
] when* ;
|
] when* ;
|
||||||
|
|
||||||
: textual-list ( seq quot -- )
|
: textual-list ( seq quot -- )
|
||||||
|
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
Chris Double
|
|
||||||
|
|
@ -1,69 +0,0 @@
|
||||||
! Copyright (C) 2007 Chris Double.
|
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
|
||||||
USING: help.markup help.syntax crypto.sha2 ;
|
|
||||||
IN: http.basic-authentication
|
|
||||||
|
|
||||||
HELP: realms
|
|
||||||
{ $description
|
|
||||||
"A hashtable mapping a basic authentication realm (a string) "
|
|
||||||
"to either a quotation or a hashtable. The quotation has "
|
|
||||||
"stack effect ( username sha-256-string -- bool ). It "
|
|
||||||
"is expected to perform the user authentication when called." $nl
|
|
||||||
"If the realm maps to a hashtable then the hashtable should be a "
|
|
||||||
"mapping of usernames to sha-256 hashed passwords." $nl
|
|
||||||
"If the 'realms' variable does not exist in the current scope then "
|
|
||||||
"authentication will always fail." }
|
|
||||||
{ $see-also add-realm with-basic-authentication } ;
|
|
||||||
|
|
||||||
HELP: add-realm
|
|
||||||
{ $values
|
|
||||||
{ "data" "a quotation or a hashtable" } { "name" "a string" } }
|
|
||||||
{ $description
|
|
||||||
"Adds the authentication data to the " { $link realms } ". 'data' can be "
|
|
||||||
"a quotation with stack effect ( username sha-256-string -- bool ) or "
|
|
||||||
"a hashtable mapping username strings to sha-256-string passwords." }
|
|
||||||
{ $examples
|
|
||||||
{ $code "H{ { \"admin\" \"...\" } { \"user\" \"...\" } } \"my-realm\" add-realm" }
|
|
||||||
{ $code "[ \"...\" = swap \"admin\" = and ] \"my-realm\" add-realm" }
|
|
||||||
}
|
|
||||||
{ $see-also with-basic-authentication realms } ;
|
|
||||||
|
|
||||||
HELP: with-basic-authentication
|
|
||||||
{ $values
|
|
||||||
{ "realm" "a string" } { "quot" "a quotation with stack effect ( -- )" } }
|
|
||||||
{ $description
|
|
||||||
"Checks if the HTTP request has the correct authorisation headers "
|
|
||||||
"for basic authentication within the named realm. If the headers "
|
|
||||||
"are not present then a '401' HTTP response results from the "
|
|
||||||
"request, otherwise the quotation is called." }
|
|
||||||
{ $examples
|
|
||||||
{ $code "\"my-realm\" [\n serving-html \"<html><body>Success!</body></html>\" write\n] with-basic-authentication" } }
|
|
||||||
{ $see-also add-realm realms }
|
|
||||||
;
|
|
||||||
|
|
||||||
ARTICLE: { "http-authentication" "basic-authentication" } "Basic Authentication"
|
|
||||||
"The Basic Authentication system provides a simple browser based "
|
|
||||||
"authentication method to web applications. When the browser requests "
|
|
||||||
"a resource protected with basic authentication the server responds with "
|
|
||||||
"a '401' response code which means the user is unauthorized."
|
|
||||||
$nl
|
|
||||||
"When the browser receives this it prompts the user for a username and "
|
|
||||||
"password. This is sent back to the server in a special HTTP header. The "
|
|
||||||
"server then checks this against its authentication information and either "
|
|
||||||
"accepts or rejects the users request."
|
|
||||||
$nl
|
|
||||||
"Authentication is split up into " { $link realms } ". Each realm can have "
|
|
||||||
"a different database of username and password information. A responder can "
|
|
||||||
"require basic authentication by using the " { $link with-basic-authentication } " word."
|
|
||||||
$nl
|
|
||||||
"Username and password information can be maintained using " { $link realms } " and " { $link add-realm } "."
|
|
||||||
$nl
|
|
||||||
"All passwords on the server should be stored as sha-256 strings generated with the " { $link string>sha-256-string } " word."
|
|
||||||
$nl
|
|
||||||
"Note that Basic Authentication itself is insecure in that it "
|
|
||||||
"sends the username and password as clear text (although it is "
|
|
||||||
"base64 encoded this is not much help). To prevent eavesdropping "
|
|
||||||
"it is best to use Basic Authentication with SSL." ;
|
|
||||||
|
|
||||||
IN: http.basic-authentication
|
|
||||||
ABOUT: { "http-authentication" "basic-authentication" }
|
|
||||||
|
|
@ -1,66 +0,0 @@
|
||||||
! Copyright (c) 2007 Chris Double.
|
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
|
||||||
USING: kernel crypto.sha2 http.basic-authentication tools.test
|
|
||||||
namespaces base64 sequences ;
|
|
||||||
|
|
||||||
{ t } [
|
|
||||||
[
|
|
||||||
H{ } clone realms set
|
|
||||||
H{ { "admin" "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" } } "test-realm" add-realm
|
|
||||||
"test-realm" "Basic " "admin:password" >base64 append authorization-ok?
|
|
||||||
] with-scope
|
|
||||||
] unit-test
|
|
||||||
|
|
||||||
{ f } [
|
|
||||||
[
|
|
||||||
H{ } clone realms set
|
|
||||||
H{ { "admin" "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" } } "test-realm" add-realm
|
|
||||||
"test-realm" "Basic " "admin:passwordx" >base64 append authorization-ok?
|
|
||||||
] with-scope
|
|
||||||
] unit-test
|
|
||||||
|
|
||||||
{ f } [
|
|
||||||
[
|
|
||||||
H{ } clone realms set
|
|
||||||
H{ { "admin" "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" } } "test-realm" add-realm
|
|
||||||
"test-realm" "Basic " "xadmin:password" >base64 append authorization-ok?
|
|
||||||
] with-scope
|
|
||||||
] unit-test
|
|
||||||
|
|
||||||
{ t } [
|
|
||||||
[
|
|
||||||
H{ } clone realms set
|
|
||||||
[ "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" = swap "admin" = and ] "test-realm" add-realm
|
|
||||||
"test-realm" "Basic " "admin:password" >base64 append authorization-ok?
|
|
||||||
] with-scope
|
|
||||||
] unit-test
|
|
||||||
|
|
||||||
{ f } [
|
|
||||||
[
|
|
||||||
H{ } clone realms set
|
|
||||||
[ "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" = swap "admin" = and ] "test-realm" add-realm
|
|
||||||
"test-realm" "Basic " "xadmin:password" >base64 append authorization-ok?
|
|
||||||
] with-scope
|
|
||||||
] unit-test
|
|
||||||
|
|
||||||
{ f } [
|
|
||||||
[
|
|
||||||
H{ } clone realms set
|
|
||||||
[ "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" = swap "admin" = and ] "test-realm" add-realm
|
|
||||||
"test-realm" "Basic " "admin:xpassword" >base64 append authorization-ok?
|
|
||||||
] with-scope
|
|
||||||
] unit-test
|
|
||||||
|
|
||||||
{ f } [
|
|
||||||
[
|
|
||||||
f realms set
|
|
||||||
"test-realm" "Basic " "admin:password" >base64 append authorization-ok?
|
|
||||||
] with-scope
|
|
||||||
] unit-test
|
|
||||||
|
|
||||||
{ f } [
|
|
||||||
[
|
|
||||||
H{ } clone realms set
|
|
||||||
"test-realm" "Basic " "admin:password" >base64 append authorization-ok?
|
|
||||||
] with-scope
|
|
||||||
] unit-test
|
|
||||||
|
|
@ -1,65 +0,0 @@
|
||||||
! Copyright (c) 2007 Chris Double.
|
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
|
||||||
USING: kernel base64 http.server crypto.sha2 namespaces assocs
|
|
||||||
quotations hashtables combinators splitting sequences
|
|
||||||
http.server.responders io html.elements ;
|
|
||||||
IN: http.basic-authentication
|
|
||||||
|
|
||||||
! 'realms' is a hashtable mapping a realm (a string) to
|
|
||||||
! either a quotation or a hashtable. The quotation
|
|
||||||
! has stack effect ( username sha-256-string -- bool ).
|
|
||||||
! It should perform the user authentication. 'sha-256-string'
|
|
||||||
! is the plain text password provided by the user passed through
|
|
||||||
! 'string>sha-256-string'. If 'realms' maps to a hashtable then
|
|
||||||
! it is a mapping of usernames to sha-256 hashed passwords.
|
|
||||||
!
|
|
||||||
! 'realms' can be set on a per vhost basis in the vhosts
|
|
||||||
! table.
|
|
||||||
!
|
|
||||||
! If there are no realms then authentication fails.
|
|
||||||
SYMBOL: realms
|
|
||||||
|
|
||||||
: add-realm ( data name -- )
|
|
||||||
#! Add the named realm to the realms table.
|
|
||||||
#! 'data' should be a hashtable or a quotation.
|
|
||||||
realms get [ H{ } clone dup realms set ] unless*
|
|
||||||
set-at ;
|
|
||||||
|
|
||||||
: user-authorized? ( username password realm -- bool )
|
|
||||||
realms get dup [
|
|
||||||
at {
|
|
||||||
{ [ dup quotation? ] [ call ] }
|
|
||||||
{ [ dup hashtable? ] [ swapd at = ] }
|
|
||||||
{ [ t ] [ 3drop f ] }
|
|
||||||
} cond
|
|
||||||
] [
|
|
||||||
3drop drop f
|
|
||||||
] if ;
|
|
||||||
|
|
||||||
: authorization-ok? ( realm header -- bool )
|
|
||||||
#! Given the realm and the 'Authorization' header,
|
|
||||||
#! authenticate the user.
|
|
||||||
dup [
|
|
||||||
" " split dup first "Basic" = [
|
|
||||||
second base64> ":" split first2 string>sha-256-string rot
|
|
||||||
user-authorized?
|
|
||||||
] [
|
|
||||||
2drop f
|
|
||||||
] if
|
|
||||||
] [
|
|
||||||
2drop f
|
|
||||||
] if ;
|
|
||||||
|
|
||||||
: authentication-error ( realm -- )
|
|
||||||
"401 Unauthorized" response
|
|
||||||
"Basic realm=\"" swap "\"" 3append "WWW-Authenticate" associate print-header
|
|
||||||
<html> <body>
|
|
||||||
"Username or Password is invalid" write
|
|
||||||
</body> </html> ;
|
|
||||||
|
|
||||||
: with-basic-authentication ( realm quot -- )
|
|
||||||
#! Check if the user is authenticated in the given realm
|
|
||||||
#! to run the specified quotation. If not, use Basic
|
|
||||||
#! Authentication to ask for authorization details.
|
|
||||||
over "authorization" header-param authorization-ok?
|
|
||||||
[ nip call ] [ drop authentication-error ] if ;
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
HTTP Basic Authentication implementation
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
web
|
|
||||||
|
|
@ -1,14 +1,28 @@
|
||||||
USING: http.client tools.test ;
|
USING: http.client http.client.private http tools.test
|
||||||
|
tuple-syntax namespaces ;
|
||||||
[ "localhost" 80 ] [ "localhost" parse-host ] unit-test
|
[ "localhost" 80 ] [ "localhost" parse-host ] unit-test
|
||||||
[ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test
|
[ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test
|
||||||
[ "localhost:8888" "/foo" ] [ "http://localhost:8888/foo" parse-url ] unit-test
|
[ "/foo" "localhost" 8888 ] [ "http://localhost:8888/foo" parse-url ] unit-test
|
||||||
[ "localhost:8888" "/" ] [ "http://localhost:8888" parse-url ] unit-test
|
[ "/" "localhost" 8888 ] [ "http://localhost:8888" parse-url ] unit-test
|
||||||
[ 404 ] [ "HTTP/1.1 404 File not found" parse-response ] unit-test
|
|
||||||
[ 404 ] [ "404 File not found" parse-response ] unit-test
|
|
||||||
[ 200 ] [ "HTTP/1.0 200" parse-response ] unit-test
|
|
||||||
[ 200 ] [ "HTTP/1.0 200 Success" parse-response ] unit-test
|
|
||||||
|
|
||||||
[ "foo.txt" ] [ "http://www.paulgraham.com/foo.txt" download-name ] unit-test
|
[ "foo.txt" ] [ "http://www.paulgraham.com/foo.txt" download-name ] unit-test
|
||||||
[ "foo.txt" ] [ "http://www.arcsucks.com/foo.txt?xxx" download-name ] unit-test
|
[ "foo.txt" ] [ "http://www.arcsucks.com/foo.txt?xxx" download-name ] unit-test
|
||||||
[ "foo.txt" ] [ "http://www.arcsucks.com/foo.txt/" download-name ] unit-test
|
[ "foo.txt" ] [ "http://www.arcsucks.com/foo.txt/" download-name ] unit-test
|
||||||
[ "www.arcsucks.com" ] [ "http://www.arcsucks.com////" download-name ] unit-test
|
[ "www.arcsucks.com" ] [ "http://www.arcsucks.com////" download-name ] unit-test
|
||||||
|
|
||||||
|
[
|
||||||
|
TUPLE{ request
|
||||||
|
method: "GET"
|
||||||
|
host: "www.apple.com"
|
||||||
|
path: "/index.html"
|
||||||
|
port: 80
|
||||||
|
version: "1.1"
|
||||||
|
cookies: V{ }
|
||||||
|
}
|
||||||
|
] [
|
||||||
|
[
|
||||||
|
"http://www.apple.com/index.html"
|
||||||
|
<get-request>
|
||||||
|
request-with-url
|
||||||
|
] with-scope
|
||||||
|
] unit-test
|
||||||
|
|
|
||||||
|
|
@ -2,64 +2,71 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: assocs http kernel math math.parser namespaces sequences
|
USING: assocs http kernel math math.parser namespaces sequences
|
||||||
io io.sockets io.streams.string io.files io.timeouts strings
|
io io.sockets io.streams.string io.files io.timeouts strings
|
||||||
splitting calendar continuations assocs.lib io.encodings.binary ;
|
splitting calendar continuations accessors vectors io.encodings.binary ;
|
||||||
IN: http.client
|
IN: http.client
|
||||||
|
|
||||||
: parse-host ( url -- host port )
|
: parse-url ( url -- resource host port )
|
||||||
#! Extract the host name and port number from an HTTP URL.
|
"http://" ?head [ "Only http:// supported" throw ] unless
|
||||||
":" split1 [ string>number ] [ 80 ] if* ;
|
|
||||||
|
|
||||||
SYMBOL: domain
|
|
||||||
|
|
||||||
: parse-url ( url -- host resource )
|
|
||||||
dup "https://" head? [
|
|
||||||
"ssl not yet supported: " swap append throw
|
|
||||||
] when "http://" ?head drop
|
|
||||||
"/" split1 [ "/" swap append ] [ "/" ] if*
|
"/" split1 [ "/" swap append ] [ "/" ] if*
|
||||||
>r dup empty? [ drop domain get ] [ dup domain set ] if r> ;
|
swap parse-host ;
|
||||||
|
|
||||||
: parse-response ( line -- code )
|
<PRIVATE
|
||||||
"HTTP/" ?head [ " " split1 nip ] when
|
|
||||||
" " split1 drop string>number [
|
|
||||||
"Premature end of stream" throw
|
|
||||||
] unless* ;
|
|
||||||
|
|
||||||
: read-response ( -- code header )
|
: store-path ( request path -- request )
|
||||||
#! After sending a GET or POST we read a response line and
|
"?" split1 >r >>path r> dup [ query>assoc ] when >>query ;
|
||||||
#! header.
|
|
||||||
flush readln parse-response read-header ;
|
|
||||||
|
|
||||||
: crlf "\r\n" write ;
|
! This is all pretty complex because it needs to handle
|
||||||
|
! HTTP redirects, which might be absolute or relative
|
||||||
|
: request-with-url ( url request -- request )
|
||||||
|
clone dup "request" set
|
||||||
|
swap parse-url >r >r store-path r> >>host r> >>port ;
|
||||||
|
|
||||||
: http-request ( host resource method -- )
|
DEFER: (http-request)
|
||||||
write bl write " HTTP/1.0" write crlf
|
|
||||||
"Host: " write write crlf ;
|
|
||||||
|
|
||||||
: get-request ( host resource -- )
|
: absolute-redirect ( url -- request )
|
||||||
"GET" http-request crlf ;
|
"request" get request-with-url ;
|
||||||
|
|
||||||
DEFER: http-get-stream
|
: relative-redirect ( path -- request )
|
||||||
|
"request" get swap store-path ;
|
||||||
|
|
||||||
: do-redirect ( code headers stream -- code headers stream )
|
: do-redirect ( response -- response stream )
|
||||||
#! Should this support Location: headers that are
|
dup response-code 300 399 between? [
|
||||||
#! relative URLs?
|
header>> "location" swap at
|
||||||
pick 100 /i 3 = [
|
dup "http://" head? [
|
||||||
dispose "location" swap peek-at nip http-get-stream
|
absolute-redirect
|
||||||
] when ;
|
] [
|
||||||
|
relative-redirect
|
||||||
|
] if "GET" >>method (http-request)
|
||||||
|
] [
|
||||||
|
stdio get
|
||||||
|
] if ;
|
||||||
|
|
||||||
: default-timeout 1 minutes over set-timeout ;
|
: (http-request) ( request -- response stream )
|
||||||
|
dup host>> over port>> <inet> <client> stdio set
|
||||||
|
dup "r" set-global write-request flush read-response
|
||||||
|
do-redirect ;
|
||||||
|
|
||||||
: http-get-stream ( url -- code headers stream )
|
PRIVATE>
|
||||||
#! Opens a stream for reading from an HTTP URL.
|
|
||||||
parse-url over parse-host <inet> <client> [
|
: http-request ( url request -- response stream )
|
||||||
[ [ get-request read-response ] with-stream* ] keep
|
[
|
||||||
default-timeout
|
request-with-url
|
||||||
] [ ] [ dispose ] cleanup do-redirect ;
|
[
|
||||||
|
(http-request)
|
||||||
|
1 minutes over set-timeout
|
||||||
|
] [ ] [ stdio get dispose ] cleanup
|
||||||
|
] with-scope ;
|
||||||
|
|
||||||
|
: <get-request> ( -- request )
|
||||||
|
<request> "GET" >>method ;
|
||||||
|
|
||||||
|
: http-get-stream ( url -- response stream )
|
||||||
|
<get-request> http-request ;
|
||||||
|
|
||||||
: success? ( code -- ? ) 200 = ;
|
: success? ( code -- ? ) 200 = ;
|
||||||
|
|
||||||
: check-response ( code headers stream -- stream )
|
: check-response ( response stream -- stream )
|
||||||
nip swap success?
|
swap code>> success?
|
||||||
[ dispose "HTTP download failed" throw ] unless ;
|
[ dispose "HTTP download failed" throw ] unless ;
|
||||||
|
|
||||||
: http-get ( url -- string )
|
: http-get ( url -- string )
|
||||||
|
|
@ -70,23 +77,18 @@ DEFER: http-get-stream
|
||||||
|
|
||||||
: download-to ( url file -- )
|
: download-to ( url file -- )
|
||||||
#! Downloads the contents of a URL to a file.
|
#! Downloads the contents of a URL to a file.
|
||||||
>r http-get-stream check-response
|
swap http-get-stream check-response
|
||||||
r> binary <file-writer> stream-copy ;
|
[ swap binary <file-writer> stream-copy ] with-disposal ;
|
||||||
|
|
||||||
: download ( url -- )
|
: download ( url -- )
|
||||||
dup download-name download-to ;
|
dup download-name download-to ;
|
||||||
|
|
||||||
: post-request ( content-type content host resource -- )
|
: <post-request> ( content-type content -- request )
|
||||||
#! Note: It is up to the caller to url encode the content if
|
<request>
|
||||||
#! it is required according to the content-type.
|
"POST" >>method
|
||||||
"POST" http-request [
|
swap >>post-data
|
||||||
"Content-Length: " write length number>string write crlf
|
swap >>post-data-type ;
|
||||||
"Content-Type: " write url-encode write crlf
|
|
||||||
crlf
|
|
||||||
] keep write ;
|
|
||||||
|
|
||||||
: http-post ( content-type content url -- code headers string )
|
: http-post ( content-type content url -- response string )
|
||||||
#! Make a POST request. The content is URL encoded for you.
|
#! The content is URL encoded for you.
|
||||||
parse-url over parse-host <inet> <client> [
|
-rot url-encode <post-request> http-request contents ;
|
||||||
post-request flush read-response stdio get contents
|
|
||||||
] with-stream ;
|
|
||||||
|
|
|
||||||
|
|
@ -1,4 +1,5 @@
|
||||||
USING: http tools.test ;
|
USING: http tools.test multiline tuple-syntax
|
||||||
|
io.streams.string kernel arrays splitting sequences ;
|
||||||
IN: http.tests
|
IN: http.tests
|
||||||
|
|
||||||
[ "hello%20world" ] [ "hello world" url-encode ] unit-test
|
[ "hello%20world" ] [ "hello world" url-encode ] unit-test
|
||||||
|
|
@ -16,3 +17,113 @@ IN: http.tests
|
||||||
[ "%20%21%20" ] [ " ! " url-encode ] unit-test
|
[ "%20%21%20" ] [ " ! " url-encode ] unit-test
|
||||||
|
|
||||||
[ "\u001234hi\u002045" ] [ "\u001234hi\u002045" url-encode url-decode ] unit-test
|
[ "\u001234hi\u002045" ] [ "\u001234hi\u002045" url-encode url-decode ] unit-test
|
||||||
|
|
||||||
|
[ "/" ] [ "http://foo.com" url>path ] unit-test
|
||||||
|
[ "/" ] [ "http://foo.com/" url>path ] unit-test
|
||||||
|
[ "/bar" ] [ "http://foo.com/bar" url>path ] unit-test
|
||||||
|
[ "/bar" ] [ "/bar" url>path ] unit-test
|
||||||
|
|
||||||
|
STRING: read-request-test-1
|
||||||
|
GET http://foo/bar HTTP/1.1
|
||||||
|
Some-Header: 1
|
||||||
|
Some-Header: 2
|
||||||
|
Content-Length: 4
|
||||||
|
|
||||||
|
blah
|
||||||
|
;
|
||||||
|
|
||||||
|
[
|
||||||
|
TUPLE{ request
|
||||||
|
port: 80
|
||||||
|
method: "GET"
|
||||||
|
path: "/bar"
|
||||||
|
query: H{ }
|
||||||
|
version: "1.1"
|
||||||
|
header: H{ { "some-header" "1; 2" } { "content-length" "4" } }
|
||||||
|
post-data: "blah"
|
||||||
|
cookies: V{ }
|
||||||
|
}
|
||||||
|
] [
|
||||||
|
read-request-test-1 [
|
||||||
|
read-request
|
||||||
|
] with-string-reader
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
STRING: read-request-test-1'
|
||||||
|
GET /bar HTTP/1.1
|
||||||
|
content-length: 4
|
||||||
|
some-header: 1; 2
|
||||||
|
|
||||||
|
blah
|
||||||
|
;
|
||||||
|
|
||||||
|
read-request-test-1' 1array [
|
||||||
|
read-request-test-1
|
||||||
|
[ read-request ] with-string-reader
|
||||||
|
[ write-request ] with-string-writer
|
||||||
|
! normalize crlf
|
||||||
|
string-lines "\n" join
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
STRING: read-request-test-2
|
||||||
|
HEAD http://foo/bar HTTP/1.1
|
||||||
|
Host: www.sex.com
|
||||||
|
;
|
||||||
|
|
||||||
|
[
|
||||||
|
TUPLE{ request
|
||||||
|
port: 80
|
||||||
|
method: "HEAD"
|
||||||
|
path: "/bar"
|
||||||
|
query: H{ }
|
||||||
|
version: "1.1"
|
||||||
|
header: H{ { "host" "www.sex.com" } }
|
||||||
|
host: "www.sex.com"
|
||||||
|
cookies: V{ }
|
||||||
|
}
|
||||||
|
] [
|
||||||
|
read-request-test-2 [
|
||||||
|
read-request
|
||||||
|
] with-string-reader
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
STRING: read-response-test-1
|
||||||
|
HTTP/1.1 404 not found
|
||||||
|
Content-Type: text/html
|
||||||
|
|
||||||
|
blah
|
||||||
|
;
|
||||||
|
|
||||||
|
[
|
||||||
|
TUPLE{ response
|
||||||
|
version: "1.1"
|
||||||
|
code: 404
|
||||||
|
message: "not found"
|
||||||
|
header: H{ { "content-type" "text/html" } }
|
||||||
|
cookies: V{ }
|
||||||
|
}
|
||||||
|
] [
|
||||||
|
read-response-test-1
|
||||||
|
[ read-response ] with-string-reader
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
|
||||||
|
STRING: read-response-test-1'
|
||||||
|
HTTP/1.1 404 not found
|
||||||
|
content-type: text/html
|
||||||
|
|
||||||
|
|
||||||
|
;
|
||||||
|
|
||||||
|
read-response-test-1' 1array [
|
||||||
|
read-response-test-1
|
||||||
|
[ read-response ] with-string-reader
|
||||||
|
[ write-response ] with-string-writer
|
||||||
|
! normalize crlf
|
||||||
|
string-lines "\n" join
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ t ] [
|
||||||
|
"rmid=732423sdfs73242; path=/; domain=.example.net; expires=Fri, 31-Dec-2010 23:59:59 GMT"
|
||||||
|
dup parse-cookies unparse-cookies =
|
||||||
|
] unit-test
|
||||||
|
|
|
||||||
|
|
@ -1,19 +1,13 @@
|
||||||
! Copyright (C) 2003, 2007 Slava Pestov.
|
! Copyright (C) 2003, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: hashtables io kernel math namespaces math.parser assocs
|
USING: hashtables io io.streams.string kernel math namespaces
|
||||||
sequences strings splitting ascii io.encodings.utf8 assocs.lib
|
math.parser assocs sequences strings splitting ascii
|
||||||
namespaces unicode.case ;
|
io.encodings.utf8 namespaces unicode.case combinators
|
||||||
|
vectors sorting new-slots accessors calendar calendar.format
|
||||||
|
quotations arrays ;
|
||||||
IN: http
|
IN: http
|
||||||
|
|
||||||
: header-line ( line -- )
|
: http-port 80 ; inline
|
||||||
": " split1 dup [ swap >lower insert ] [ 2drop ] if ;
|
|
||||||
|
|
||||||
: (read-header) ( -- )
|
|
||||||
readln dup
|
|
||||||
empty? [ drop ] [ header-line (read-header) ] if ;
|
|
||||||
|
|
||||||
: read-header ( -- hash )
|
|
||||||
[ (read-header) ] H{ } make-assoc ;
|
|
||||||
|
|
||||||
: url-quotable? ( ch -- ? )
|
: url-quotable? ( ch -- ? )
|
||||||
#! In a URL, can this character be used without
|
#! In a URL, can this character be used without
|
||||||
|
|
@ -23,7 +17,7 @@ IN: http
|
||||||
over digit? or
|
over digit? or
|
||||||
swap "/_-." member? or ; foldable
|
swap "/_-." member? or ; foldable
|
||||||
|
|
||||||
: push-utf8 ( string -- )
|
: push-utf8 ( ch -- )
|
||||||
1string encode-utf8 [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ;
|
1string encode-utf8 [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ;
|
||||||
|
|
||||||
: url-encode ( str -- str )
|
: url-encode ( str -- str )
|
||||||
|
|
@ -58,17 +52,375 @@ IN: http
|
||||||
: url-decode ( str -- str )
|
: url-decode ( str -- str )
|
||||||
[ 0 swap url-decode-iter ] "" make decode-utf8 ;
|
[ 0 swap url-decode-iter ] "" make decode-utf8 ;
|
||||||
|
|
||||||
: hash>query ( hash -- str )
|
: crlf "\r\n" write ;
|
||||||
|
|
||||||
|
: add-header ( value key assoc -- )
|
||||||
|
[ at dup [ "; " rot 3append ] [ drop ] if ] 2keep set-at ;
|
||||||
|
|
||||||
|
: header-line ( line -- )
|
||||||
|
dup first blank? [
|
||||||
|
[ blank? ] left-trim
|
||||||
|
"last-header" get
|
||||||
|
"header" get
|
||||||
|
add-header
|
||||||
|
] [
|
||||||
|
": " split1 dup [
|
||||||
|
swap >lower dup "last-header" set
|
||||||
|
"header" get add-header
|
||||||
|
] [
|
||||||
|
2drop
|
||||||
|
] if
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
: read-header-line ( -- )
|
||||||
|
readln dup
|
||||||
|
empty? [ drop ] [ header-line read-header-line ] if ;
|
||||||
|
|
||||||
|
: read-header ( -- assoc )
|
||||||
|
H{ } clone [
|
||||||
|
"header" [ read-header-line ] with-variable
|
||||||
|
] keep ;
|
||||||
|
|
||||||
|
: header-value>string ( value -- string )
|
||||||
|
{
|
||||||
|
{ [ dup number? ] [ number>string ] }
|
||||||
|
{ [ dup timestamp? ] [ timestamp>http-string ] }
|
||||||
|
{ [ dup string? ] [ ] }
|
||||||
|
{ [ dup sequence? ] [ [ header-value>string ] map "; " join ] }
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
: check-header-string ( str -- str )
|
||||||
|
#! http://en.wikipedia.org/wiki/HTTP_Header_Injection
|
||||||
|
dup [ "\r\n" member? ] contains?
|
||||||
|
[ "Header injection attack" throw ] when ;
|
||||||
|
|
||||||
|
: write-header ( assoc -- )
|
||||||
|
>alist sort-keys [
|
||||||
|
swap url-encode write ": " write
|
||||||
|
header-value>string check-header-string write crlf
|
||||||
|
] assoc-each crlf ;
|
||||||
|
|
||||||
|
: query>assoc ( query -- assoc )
|
||||||
|
dup [
|
||||||
|
"&" split [
|
||||||
|
"=" split1 [ dup [ url-decode ] when ] 2apply
|
||||||
|
] H{ } map>assoc
|
||||||
|
] when ;
|
||||||
|
|
||||||
|
: assoc>query ( hash -- str )
|
||||||
[ [ url-encode ] 2apply "=" swap 3append ] { } assoc>map
|
[ [ url-encode ] 2apply "=" swap 3append ] { } assoc>map
|
||||||
"&" join ;
|
"&" join ;
|
||||||
|
|
||||||
: build-url ( str query-params -- newstr )
|
TUPLE: cookie name value path domain expires http-only ;
|
||||||
|
|
||||||
|
: <cookie> ( value name -- cookie )
|
||||||
|
cookie construct-empty
|
||||||
|
swap >>name swap >>value ;
|
||||||
|
|
||||||
|
: parse-cookies ( string -- seq )
|
||||||
[
|
[
|
||||||
over %
|
f swap
|
||||||
dup assoc-empty? [
|
|
||||||
2drop
|
";" split [
|
||||||
] [
|
[ blank? ] trim "=" split1 swap >lower {
|
||||||
CHAR: ? rot member? "&" "?" ? %
|
{ "expires" [ >>expires ] }
|
||||||
hash>query %
|
{ "domain" [ >>domain ] }
|
||||||
] if
|
{ "path" [ >>path ] }
|
||||||
] "" make ;
|
{ "httponly" [ drop t >>http-only ] }
|
||||||
|
{ "" [ drop ] }
|
||||||
|
[ <cookie> dup , nip ]
|
||||||
|
} case
|
||||||
|
] each
|
||||||
|
|
||||||
|
drop
|
||||||
|
] { } make ;
|
||||||
|
|
||||||
|
: (unparse-cookie) ( key value -- )
|
||||||
|
{
|
||||||
|
{ [ dup f eq? ] [ 2drop ] }
|
||||||
|
{ [ dup t eq? ] [ drop , ] }
|
||||||
|
{ [ t ] [ "=" swap 3append , ] }
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
: unparse-cookie ( cookie -- strings )
|
||||||
|
[
|
||||||
|
dup name>> >lower over value>> (unparse-cookie)
|
||||||
|
"path" over path>> (unparse-cookie)
|
||||||
|
"domain" over domain>> (unparse-cookie)
|
||||||
|
"expires" over expires>> (unparse-cookie)
|
||||||
|
"httponly" over http-only>> (unparse-cookie)
|
||||||
|
drop
|
||||||
|
] { } make ;
|
||||||
|
|
||||||
|
: unparse-cookies ( cookies -- string )
|
||||||
|
[ unparse-cookie ] map concat "; " join ;
|
||||||
|
|
||||||
|
TUPLE: request
|
||||||
|
host
|
||||||
|
port
|
||||||
|
method
|
||||||
|
path
|
||||||
|
query
|
||||||
|
version
|
||||||
|
header
|
||||||
|
post-data
|
||||||
|
post-data-type
|
||||||
|
cookies ;
|
||||||
|
|
||||||
|
: <request>
|
||||||
|
request construct-empty
|
||||||
|
"1.1" >>version
|
||||||
|
http-port >>port
|
||||||
|
H{ } clone >>query
|
||||||
|
V{ } clone >>cookies ;
|
||||||
|
|
||||||
|
: query-param ( request key -- value )
|
||||||
|
swap query>> at ;
|
||||||
|
|
||||||
|
: set-query-param ( request value key -- request )
|
||||||
|
pick query>> set-at ;
|
||||||
|
|
||||||
|
: chop-hostname ( str -- str' )
|
||||||
|
CHAR: / over index over length or tail
|
||||||
|
dup empty? [ drop "/" ] when ;
|
||||||
|
|
||||||
|
: url>path ( url -- path )
|
||||||
|
#! Technically, only proxies are meant to support hostnames
|
||||||
|
#! in HTTP requests, but IE sends these sometimes so we
|
||||||
|
#! just chop the hostname part.
|
||||||
|
url-decode "http://" ?head [ chop-hostname ] when ;
|
||||||
|
|
||||||
|
: read-method ( request -- request )
|
||||||
|
" " read-until [ "Bad request: method" throw ] unless
|
||||||
|
>>method ;
|
||||||
|
|
||||||
|
: read-query ( request -- request )
|
||||||
|
" " read-until
|
||||||
|
[ "Bad request: query params" throw ] unless
|
||||||
|
query>assoc >>query ;
|
||||||
|
|
||||||
|
: read-url ( request -- request )
|
||||||
|
" ?" read-until {
|
||||||
|
{ CHAR: \s [ dup empty? [ drop read-url ] [ url>path >>path ] if ] }
|
||||||
|
{ CHAR: ? [ url>path >>path read-query ] }
|
||||||
|
[ "Bad request: URL" throw ]
|
||||||
|
} case ;
|
||||||
|
|
||||||
|
: parse-version ( string -- version )
|
||||||
|
"HTTP/" ?head [ "Bad version" throw ] unless
|
||||||
|
dup { "1.0" "1.1" } member? [ "Bad version" throw ] unless ;
|
||||||
|
|
||||||
|
: read-request-version ( request -- request )
|
||||||
|
readln [ CHAR: \s = ] left-trim
|
||||||
|
parse-version
|
||||||
|
>>version ;
|
||||||
|
|
||||||
|
: read-request-header ( request -- request )
|
||||||
|
read-header >>header ;
|
||||||
|
|
||||||
|
: header ( request/response key -- value )
|
||||||
|
swap header>> at ;
|
||||||
|
|
||||||
|
SYMBOL: max-post-request
|
||||||
|
|
||||||
|
1024 256 * max-post-request set-global
|
||||||
|
|
||||||
|
: content-length ( header -- n )
|
||||||
|
"content-length" swap at string>number dup [
|
||||||
|
dup max-post-request get > [
|
||||||
|
"content-length > max-post-request" throw
|
||||||
|
] when
|
||||||
|
] when ;
|
||||||
|
|
||||||
|
: read-post-data ( request -- request )
|
||||||
|
dup header>> content-length [ read >>post-data ] when* ;
|
||||||
|
|
||||||
|
: parse-host ( string -- host port )
|
||||||
|
"." ?tail drop ":" split1
|
||||||
|
[ string>number ] [ http-port ] if* ;
|
||||||
|
|
||||||
|
: extract-host ( request -- request )
|
||||||
|
dup "host" header parse-host >r >>host r> >>port ;
|
||||||
|
|
||||||
|
: extract-post-data-type ( request -- request )
|
||||||
|
dup "content-type" header >>post-data-type ;
|
||||||
|
|
||||||
|
: extract-cookies ( request -- request )
|
||||||
|
dup "cookie" header [ parse-cookies >>cookies ] when* ;
|
||||||
|
|
||||||
|
: read-request ( -- request )
|
||||||
|
<request>
|
||||||
|
read-method
|
||||||
|
read-url
|
||||||
|
read-request-version
|
||||||
|
read-request-header
|
||||||
|
read-post-data
|
||||||
|
extract-host
|
||||||
|
extract-post-data-type
|
||||||
|
extract-cookies ;
|
||||||
|
|
||||||
|
: write-method ( request -- request )
|
||||||
|
dup method>> write bl ;
|
||||||
|
|
||||||
|
: write-url ( request -- request )
|
||||||
|
dup path>> url-encode write
|
||||||
|
dup query>> dup assoc-empty? [ drop ] [
|
||||||
|
"?" write
|
||||||
|
assoc>query write
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
: write-request-url ( request -- request )
|
||||||
|
write-url bl ;
|
||||||
|
|
||||||
|
: write-version ( request -- request )
|
||||||
|
"HTTP/" write dup request-version write crlf ;
|
||||||
|
|
||||||
|
: write-request-header ( request -- request )
|
||||||
|
dup header>> >hashtable
|
||||||
|
over host>> [ "host" pick set-at ] when*
|
||||||
|
over post-data>> [ length "content-length" pick set-at ] when*
|
||||||
|
over post-data-type>> [ "content-type" pick set-at ] when*
|
||||||
|
over cookies>> f like [ unparse-cookies "cookie" pick set-at ] when*
|
||||||
|
write-header ;
|
||||||
|
|
||||||
|
: write-post-data ( request -- request )
|
||||||
|
dup post-data>> [ write ] when* ;
|
||||||
|
|
||||||
|
: write-request ( request -- )
|
||||||
|
write-method
|
||||||
|
write-request-url
|
||||||
|
write-version
|
||||||
|
write-request-header
|
||||||
|
write-post-data
|
||||||
|
flush
|
||||||
|
drop ;
|
||||||
|
|
||||||
|
: request-url ( request -- url )
|
||||||
|
[
|
||||||
|
dup host>> [
|
||||||
|
"http://" write
|
||||||
|
dup host>> url-encode write
|
||||||
|
":" write
|
||||||
|
dup port>> number>string write
|
||||||
|
] when
|
||||||
|
dup path>> "/" head? [ "/" write ] unless
|
||||||
|
write-url
|
||||||
|
drop
|
||||||
|
] with-string-writer ;
|
||||||
|
|
||||||
|
: set-header ( request/response value key -- request/response )
|
||||||
|
pick header>> set-at ;
|
||||||
|
|
||||||
|
GENERIC: write-response ( response -- )
|
||||||
|
|
||||||
|
GENERIC: write-full-response ( request response -- )
|
||||||
|
|
||||||
|
TUPLE: response
|
||||||
|
version
|
||||||
|
code
|
||||||
|
message
|
||||||
|
header
|
||||||
|
cookies
|
||||||
|
body ;
|
||||||
|
|
||||||
|
: <response>
|
||||||
|
response construct-empty
|
||||||
|
"1.1" >>version
|
||||||
|
H{ } clone >>header
|
||||||
|
"close" "connection" set-header
|
||||||
|
now timestamp>http-string "date" set-header
|
||||||
|
V{ } clone >>cookies ;
|
||||||
|
|
||||||
|
: read-response-version
|
||||||
|
" \t" read-until
|
||||||
|
[ "Bad response: version" throw ] unless
|
||||||
|
parse-version
|
||||||
|
>>version ;
|
||||||
|
|
||||||
|
: read-response-code
|
||||||
|
" \t" read-until [ "Bad response: code" throw ] unless
|
||||||
|
string>number [ "Bad response: code" throw ] unless*
|
||||||
|
>>code ;
|
||||||
|
|
||||||
|
: read-response-message
|
||||||
|
readln >>message ;
|
||||||
|
|
||||||
|
: read-response-header
|
||||||
|
read-header >>header
|
||||||
|
dup "set-cookie" header [ parse-cookies >>cookies ] when* ;
|
||||||
|
|
||||||
|
: read-response ( -- response )
|
||||||
|
<response>
|
||||||
|
read-response-version
|
||||||
|
read-response-code
|
||||||
|
read-response-message
|
||||||
|
read-response-header ;
|
||||||
|
|
||||||
|
: write-response-version ( response -- response )
|
||||||
|
"HTTP/" write
|
||||||
|
dup version>> write bl ;
|
||||||
|
|
||||||
|
: write-response-code ( response -- response )
|
||||||
|
dup code>> number>string write bl ;
|
||||||
|
|
||||||
|
: write-response-message ( response -- response )
|
||||||
|
dup message>> write crlf ;
|
||||||
|
|
||||||
|
: write-response-header ( response -- response )
|
||||||
|
dup header>> clone
|
||||||
|
over cookies>> f like
|
||||||
|
[ unparse-cookies "set-cookie" pick set-at ] when*
|
||||||
|
write-header ;
|
||||||
|
|
||||||
|
: write-response-body ( response -- response )
|
||||||
|
dup body>> {
|
||||||
|
{ [ dup not ] [ drop ] }
|
||||||
|
{ [ dup string? ] [ write ] }
|
||||||
|
{ [ dup callable? ] [ call ] }
|
||||||
|
{ [ t ] [ stdio get stream-copy ] }
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
M: response write-response ( respose -- )
|
||||||
|
write-response-version
|
||||||
|
write-response-code
|
||||||
|
write-response-message
|
||||||
|
write-response-header
|
||||||
|
flush
|
||||||
|
drop ;
|
||||||
|
|
||||||
|
M: response write-full-response ( request response -- )
|
||||||
|
dup write-response
|
||||||
|
swap method>> "HEAD" = [ write-response-body ] unless ;
|
||||||
|
|
||||||
|
: set-content-type ( request/response content-type -- request/response )
|
||||||
|
"content-type" set-header ;
|
||||||
|
|
||||||
|
: get-cookie ( request/response name -- cookie/f )
|
||||||
|
>r cookies>> r> [ swap name>> = ] curry find nip ;
|
||||||
|
|
||||||
|
: delete-cookie ( request/response name -- )
|
||||||
|
over cookies>> >r get-cookie r> delete ;
|
||||||
|
|
||||||
|
: put-cookie ( request/response cookie -- request/response )
|
||||||
|
[ dupd name>> get-cookie [ dupd delete-cookie ] when* ] keep
|
||||||
|
over cookies>> push ;
|
||||||
|
|
||||||
|
TUPLE: raw-response
|
||||||
|
version
|
||||||
|
code
|
||||||
|
message
|
||||||
|
body ;
|
||||||
|
|
||||||
|
: <raw-response> ( -- response )
|
||||||
|
raw-response construct-empty
|
||||||
|
"1.1" >>version ;
|
||||||
|
|
||||||
|
M: raw-response write-response ( respose -- )
|
||||||
|
write-response-version
|
||||||
|
write-response-code
|
||||||
|
write-response-message
|
||||||
|
write-response-body
|
||||||
|
drop ;
|
||||||
|
|
||||||
|
M: raw-response write-full-response ( response -- )
|
||||||
|
write-response nip ;
|
||||||
|
|
|
||||||
|
|
@ -30,5 +30,6 @@ H{
|
||||||
{ "pdf" "application/pdf" }
|
{ "pdf" "application/pdf" }
|
||||||
|
|
||||||
{ "factor" "text/plain" }
|
{ "factor" "text/plain" }
|
||||||
|
{ "cgi" "application/x-cgi-script" }
|
||||||
{ "fhtml" "application/x-factor-server-page" }
|
{ "fhtml" "application/x-factor-server-page" }
|
||||||
} "mime-types" set-global
|
} "mime-types" set-global
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,37 @@
|
||||||
|
IN: http.server.actions.tests
|
||||||
|
USING: http.server.actions tools.test math math.parser
|
||||||
|
multiline namespaces http io.streams.string http.server
|
||||||
|
sequences ;
|
||||||
|
|
||||||
|
[ + ]
|
||||||
|
{ { "a" [ string>number ] } { "b" [ string>number ] } }
|
||||||
|
"GET" <action> "action-1" set
|
||||||
|
|
||||||
|
STRING: action-request-test-1
|
||||||
|
GET http://foo/bar?a=12&b=13 HTTP/1.1
|
||||||
|
|
||||||
|
blah
|
||||||
|
;
|
||||||
|
|
||||||
|
[ 25 ] [
|
||||||
|
action-request-test-1 [ read-request ] with-string-reader
|
||||||
|
"/blah"
|
||||||
|
"action-1" get call-responder
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ "X" <repetition> concat append ]
|
||||||
|
{ { +path+ [ ] } { "xxx" [ string>number ] } }
|
||||||
|
"POST" <action> "action-2" set
|
||||||
|
|
||||||
|
STRING: action-request-test-2
|
||||||
|
POST http://foo/bar/baz HTTP/1.1
|
||||||
|
content-length: 5
|
||||||
|
|
||||||
|
xxx=4
|
||||||
|
;
|
||||||
|
|
||||||
|
[ "/blahXXXX" ] [
|
||||||
|
action-request-test-2 [ read-request ] with-string-reader
|
||||||
|
"/blah"
|
||||||
|
"action-2" get call-responder
|
||||||
|
] unit-test
|
||||||
|
|
@ -0,0 +1,30 @@
|
||||||
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: accessors new-slots sequences kernel assocs combinators
|
||||||
|
http.server http hashtables namespaces ;
|
||||||
|
IN: http.server.actions
|
||||||
|
|
||||||
|
SYMBOL: +path+
|
||||||
|
|
||||||
|
TUPLE: action quot params method ;
|
||||||
|
|
||||||
|
C: <action> action
|
||||||
|
|
||||||
|
: extract-params ( request path -- assoc )
|
||||||
|
>r dup method>> {
|
||||||
|
{ "GET" [ query>> ] }
|
||||||
|
{ "POST" [ post-data>> query>assoc ] }
|
||||||
|
} case r> +path+ associate union ;
|
||||||
|
|
||||||
|
: push-params ( assoc action -- ... )
|
||||||
|
params>> [ first2 >r swap at r> call ] with each ;
|
||||||
|
|
||||||
|
M: action call-responder ( request path action -- response )
|
||||||
|
pick request set
|
||||||
|
pick method>> over method>> = [
|
||||||
|
>r extract-params r>
|
||||||
|
[ push-params ] keep
|
||||||
|
quot>> call
|
||||||
|
] [
|
||||||
|
3drop <400>
|
||||||
|
] if ;
|
||||||
|
|
@ -0,0 +1,50 @@
|
||||||
|
! Copyright (c) 2007 Chris Double.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
IN: http.server.authentication.basic
|
||||||
|
USING: accessors new-slots quotations assocs kernel splitting
|
||||||
|
base64 crypto.sha2 html.elements io combinators http.server
|
||||||
|
http sequences ;
|
||||||
|
|
||||||
|
! 'users' is a quotation or an assoc. The quotation
|
||||||
|
! has stack effect ( sha-256-string username -- ? ).
|
||||||
|
! It should perform the user authentication. 'sha-256-string'
|
||||||
|
! is the plain text password provided by the user passed through
|
||||||
|
! 'string>sha-256-string'. If 'users' is an assoc then
|
||||||
|
! it is a mapping of usernames to sha-256 hashed passwords.
|
||||||
|
TUPLE: realm responder name users ;
|
||||||
|
|
||||||
|
C: <realm> realm
|
||||||
|
|
||||||
|
: user-authorized? ( password username realm -- ? )
|
||||||
|
users>> {
|
||||||
|
{ [ dup callable? ] [ call ] }
|
||||||
|
{ [ dup assoc? ] [ at = ] }
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
: authorization-ok? ( realm header -- bool )
|
||||||
|
#! Given the realm and the 'Authorization' header,
|
||||||
|
#! authenticate the user.
|
||||||
|
dup [
|
||||||
|
" " split1 swap "Basic" = [
|
||||||
|
base64> ":" split1 string>sha-256-string
|
||||||
|
spin user-authorized?
|
||||||
|
] [
|
||||||
|
2drop f
|
||||||
|
] if
|
||||||
|
] [
|
||||||
|
2drop f
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
: <401> ( realm -- response )
|
||||||
|
401 "Unauthorized" <trivial-response>
|
||||||
|
"Basic realm=\"" rot name>> "\"" 3append
|
||||||
|
"WWW-Authenticate" set-header
|
||||||
|
[
|
||||||
|
<html> <body>
|
||||||
|
"Username or Password is invalid" write
|
||||||
|
</body> </html>
|
||||||
|
] >>body ;
|
||||||
|
|
||||||
|
M: realm call-responder ( request path realm -- response )
|
||||||
|
pick "authorization" header dupd authorization-ok?
|
||||||
|
[ responder>> call-responder ] [ 2nip <401> ] if ;
|
||||||
|
|
@ -0,0 +1,135 @@
|
||||||
|
! Copyright (C) 2004 Chris Double.
|
||||||
|
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: html http http.server io kernel math namespaces
|
||||||
|
continuations calendar sequences assocs new-slots hashtables
|
||||||
|
accessors arrays alarms quotations combinators ;
|
||||||
|
IN: http.server.callbacks
|
||||||
|
|
||||||
|
SYMBOL: responder
|
||||||
|
|
||||||
|
TUPLE: callback-responder responder callbacks ;
|
||||||
|
|
||||||
|
: <callback-responder> ( responder -- responder' )
|
||||||
|
#! A continuation responder is a special type of session
|
||||||
|
#! manager. However it works entirely differently from
|
||||||
|
#! the URL and cookie session managers.
|
||||||
|
H{ } clone callback-responder construct-boa ;
|
||||||
|
|
||||||
|
TUPLE: callback cont quot expires alarm responder ;
|
||||||
|
|
||||||
|
: timeout 20 minutes ;
|
||||||
|
|
||||||
|
: timeout-callback ( callback -- )
|
||||||
|
dup alarm>> cancel-alarm
|
||||||
|
dup responder>> callbacks>> delete-at ;
|
||||||
|
|
||||||
|
: touch-callback ( callback -- )
|
||||||
|
dup expires>> [
|
||||||
|
dup alarm>> [ cancel-alarm ] when*
|
||||||
|
dup [ timeout-callback ] curry timeout later >>alarm
|
||||||
|
] when drop ;
|
||||||
|
|
||||||
|
: <callback> ( cont quot expires? -- callback )
|
||||||
|
[ f responder get callback construct-boa ] keep
|
||||||
|
[ dup touch-callback ] when ;
|
||||||
|
|
||||||
|
: invoke-callback ( request exit-cont callback -- response )
|
||||||
|
[ quot>> 3array ] keep cont>> continue-with ;
|
||||||
|
|
||||||
|
: register-callback ( cont quot expires? -- id )
|
||||||
|
<callback>
|
||||||
|
responder get callbacks>> generate-key
|
||||||
|
[ responder get callbacks>> set-at ] keep ;
|
||||||
|
|
||||||
|
SYMBOL: exit-continuation
|
||||||
|
|
||||||
|
: exit-with exit-continuation get continue-with ;
|
||||||
|
|
||||||
|
: forward-to-url ( url -- * )
|
||||||
|
#! When executed inside a 'show' call, this will force a
|
||||||
|
#! HTTP 302 to occur to instruct the browser to forward to
|
||||||
|
#! the request URL.
|
||||||
|
request get swap <temporary-redirect> exit-with ;
|
||||||
|
|
||||||
|
: cont-id "factorcontid" ;
|
||||||
|
|
||||||
|
: id>url ( id -- url )
|
||||||
|
request get
|
||||||
|
swap cont-id associate >>query
|
||||||
|
request-url ;
|
||||||
|
|
||||||
|
: forward-to-id ( id -- * )
|
||||||
|
#! When executed inside a 'show' call, this will force a
|
||||||
|
#! HTTP 302 to occur to instruct the browser to forward to
|
||||||
|
#! the request URL.
|
||||||
|
id>url forward-to-url ;
|
||||||
|
|
||||||
|
: restore-request ( pair -- )
|
||||||
|
first3 >r exit-continuation set request set r> call ;
|
||||||
|
|
||||||
|
: resume-page ( request page responder callback -- * )
|
||||||
|
dup touch-callback
|
||||||
|
>r 2drop exit-continuation get
|
||||||
|
r> invoke-callback ;
|
||||||
|
|
||||||
|
SYMBOL: post-refresh-get?
|
||||||
|
|
||||||
|
: redirect-to-here ( -- )
|
||||||
|
#! Force a redirect to the client browser so that the browser
|
||||||
|
#! goes to the current point in the code. This forces an URL
|
||||||
|
#! change on the browser so that refreshing that URL will
|
||||||
|
#! immediately run from this code point. This prevents the
|
||||||
|
#! "this request will issue a POST" warning from the browser
|
||||||
|
#! and prevents re-running the previous POST logic. This is
|
||||||
|
#! known as the 'post-refresh-get' pattern.
|
||||||
|
post-refresh-get? get [
|
||||||
|
[
|
||||||
|
[ ] t register-callback forward-to-id
|
||||||
|
] callcc1 restore-request
|
||||||
|
] [
|
||||||
|
post-refresh-get? on
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
SYMBOL: current-show
|
||||||
|
|
||||||
|
: store-current-show ( -- )
|
||||||
|
#! Store the current continuation in the variable 'current-show'
|
||||||
|
#! so it can be returned to later by 'quot-id'. Note that it
|
||||||
|
#! recalls itself when the continuation is called to ensure that
|
||||||
|
#! it resets its value back to the most recent show call.
|
||||||
|
[ current-show set f ] callcc1
|
||||||
|
[ restore-request store-current-show ] when* ;
|
||||||
|
|
||||||
|
: show-final ( quot -- * )
|
||||||
|
>r redirect-to-here store-current-show
|
||||||
|
r> call exit-with ; inline
|
||||||
|
|
||||||
|
M: callback-responder call-responder
|
||||||
|
[
|
||||||
|
[
|
||||||
|
exit-continuation set
|
||||||
|
dup responder set
|
||||||
|
pick request set
|
||||||
|
pick cont-id query-param over callbacks>> at [
|
||||||
|
resume-page
|
||||||
|
] [
|
||||||
|
responder>> call-responder
|
||||||
|
"Continuation responder pages must use show-final" throw
|
||||||
|
] if*
|
||||||
|
] with-scope
|
||||||
|
] callcc1 >r 3drop r> ;
|
||||||
|
|
||||||
|
: show-page ( quot -- )
|
||||||
|
>r redirect-to-here store-current-show r>
|
||||||
|
[
|
||||||
|
[ ] register-callback
|
||||||
|
with-scope
|
||||||
|
exit-with
|
||||||
|
] callcc1 restore-request ; inline
|
||||||
|
|
||||||
|
: quot-id ( quot -- id )
|
||||||
|
current-show get swap t register-callback ;
|
||||||
|
|
||||||
|
: quot-url ( quot -- url )
|
||||||
|
quot-id id>url ;
|
||||||
|
|
@ -0,0 +1,65 @@
|
||||||
|
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: namespaces kernel assocs io.files combinators
|
||||||
|
arrays io.launcher io http.server.static http.server
|
||||||
|
http accessors sequences strings math.parser ;
|
||||||
|
IN: http.server.cgi
|
||||||
|
|
||||||
|
: post? request get method>> "POST" = ;
|
||||||
|
|
||||||
|
: cgi-variables ( script-path -- assoc )
|
||||||
|
#! This needs some work.
|
||||||
|
[
|
||||||
|
"CGI/1.0" "GATEWAY_INTERFACE" set
|
||||||
|
"HTTP/" request get version>> append "SERVER_PROTOCOL" set
|
||||||
|
"Factor" "SERVER_SOFTWARE" set
|
||||||
|
|
||||||
|
dup "PATH_TRANSLATED" set
|
||||||
|
"SCRIPT_FILENAME" set
|
||||||
|
|
||||||
|
request get path>> "SCRIPT_NAME" set
|
||||||
|
|
||||||
|
request get host>> "SERVER_NAME" set
|
||||||
|
request get port>> number>string "SERVER_PORT" set
|
||||||
|
"" "PATH_INFO" set
|
||||||
|
"" "REMOTE_HOST" set
|
||||||
|
"" "REMOTE_ADDR" set
|
||||||
|
"" "AUTH_TYPE" set
|
||||||
|
"" "REMOTE_USER" set
|
||||||
|
"" "REMOTE_IDENT" set
|
||||||
|
|
||||||
|
request get method>> "REQUEST_METHOD" set
|
||||||
|
request get query>> assoc>query "QUERY_STRING" set
|
||||||
|
request get "cookie" header "HTTP_COOKIE" set
|
||||||
|
|
||||||
|
request get "user-agent" header "HTTP_USER_AGENT" set
|
||||||
|
request get "accept" header "HTTP_ACCEPT" set
|
||||||
|
|
||||||
|
post? [
|
||||||
|
request get post-data-type>> "CONTENT_TYPE" set
|
||||||
|
request get post-data>> length number>string "CONTENT_LENGTH" set
|
||||||
|
] when
|
||||||
|
] H{ } make-assoc ;
|
||||||
|
|
||||||
|
: cgi-descriptor ( name -- desc )
|
||||||
|
[
|
||||||
|
dup 1array +arguments+ set
|
||||||
|
cgi-variables +environment+ set
|
||||||
|
] H{ } make-assoc ;
|
||||||
|
|
||||||
|
: serve-cgi ( name -- response )
|
||||||
|
<raw-response>
|
||||||
|
200 >>code
|
||||||
|
"CGI output follows" >>message
|
||||||
|
swap [
|
||||||
|
stdio get swap cgi-descriptor <process-stream> [
|
||||||
|
post? [
|
||||||
|
request get post-data>> write flush
|
||||||
|
] when
|
||||||
|
stdio get swap (stream-copy)
|
||||||
|
] with-stream
|
||||||
|
] curry >>body ;
|
||||||
|
|
||||||
|
: enable-cgi ( responder -- responder )
|
||||||
|
[ serve-cgi ] "application/x-cgi-script"
|
||||||
|
pick special>> set-at ;
|
||||||
|
|
@ -0,0 +1,14 @@
|
||||||
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: db http.server kernel new-slots accessors
|
||||||
|
continuations namespaces ;
|
||||||
|
IN: http.server.db
|
||||||
|
|
||||||
|
TUPLE: db-persistence responder db params ;
|
||||||
|
|
||||||
|
C: <db-persistence> db-persistence
|
||||||
|
|
||||||
|
M: db-persistence call-responder
|
||||||
|
dup db>> over params>> make-db dup db-open [
|
||||||
|
db set responder>> call-responder
|
||||||
|
] with-disposal ;
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
Slava Pestov
|
|
||||||
|
|
@ -1,225 +0,0 @@
|
||||||
! Copyright (C) 2004, 2008 Slava Pestov.
|
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
|
||||||
USING: arrays assocs hashtables html html.elements splitting
|
|
||||||
http io kernel math math.parser namespaces parser sequences
|
|
||||||
strings io.server vectors assocs.lib logging ;
|
|
||||||
|
|
||||||
IN: http.server.responders
|
|
||||||
|
|
||||||
! Variables
|
|
||||||
SYMBOL: vhosts
|
|
||||||
SYMBOL: responders
|
|
||||||
|
|
||||||
: >header ( value key -- multi-hash )
|
|
||||||
H{ } clone [ insert-at ] keep ;
|
|
||||||
|
|
||||||
: print-header ( alist -- )
|
|
||||||
[ swap write ": " write print ] multi-assoc-each nl ;
|
|
||||||
|
|
||||||
: response ( msg -- ) "HTTP/1.0 " write print ;
|
|
||||||
|
|
||||||
: error-body ( error -- )
|
|
||||||
<html> <body> <h1> write </h1> </body> </html> ;
|
|
||||||
|
|
||||||
: error-head ( error -- )
|
|
||||||
response
|
|
||||||
H{ { "Content-Type" V{ "text/html" } } } print-header nl ;
|
|
||||||
|
|
||||||
: httpd-error ( error -- )
|
|
||||||
#! This must be run from handle-request
|
|
||||||
dup error-head
|
|
||||||
"head" "method" get = [ drop ] [ error-body ] if ;
|
|
||||||
|
|
||||||
\ httpd-error ERROR add-error-logging
|
|
||||||
|
|
||||||
: bad-request ( -- )
|
|
||||||
[
|
|
||||||
! Make httpd-error print a body
|
|
||||||
"get" "method" set
|
|
||||||
"400 Bad request" httpd-error
|
|
||||||
] with-scope ;
|
|
||||||
|
|
||||||
: serving-content ( mime -- )
|
|
||||||
"200 Document follows" response
|
|
||||||
"Content-Type" >header print-header ;
|
|
||||||
|
|
||||||
: serving-html "text/html" serving-content ;
|
|
||||||
|
|
||||||
: serve-html ( quot -- )
|
|
||||||
serving-html with-html-stream ;
|
|
||||||
|
|
||||||
: serving-text "text/plain" serving-content ;
|
|
||||||
|
|
||||||
: redirect ( to response -- )
|
|
||||||
response "Location" >header print-header ;
|
|
||||||
|
|
||||||
: permanent-redirect ( to -- )
|
|
||||||
"301 Moved Permanently" redirect ;
|
|
||||||
|
|
||||||
: temporary-redirect ( to -- )
|
|
||||||
"307 Temporary Redirect" redirect ;
|
|
||||||
|
|
||||||
: directory-no/ ( -- )
|
|
||||||
[
|
|
||||||
"request" get % CHAR: / ,
|
|
||||||
"raw-query" get [ CHAR: ? , % ] when*
|
|
||||||
] "" make permanent-redirect ;
|
|
||||||
|
|
||||||
: query>hash ( query -- hash )
|
|
||||||
dup [
|
|
||||||
"&" split [
|
|
||||||
"=" split1 [ dup [ url-decode ] when ] 2apply 2array
|
|
||||||
] map
|
|
||||||
] when >hashtable ;
|
|
||||||
|
|
||||||
SYMBOL: max-post-request
|
|
||||||
|
|
||||||
1024 256 * max-post-request set-global
|
|
||||||
|
|
||||||
: content-length ( header -- n )
|
|
||||||
"content-length" swap peek-at string>number dup [
|
|
||||||
dup max-post-request get > [
|
|
||||||
"Content-Length > max-post-request" throw
|
|
||||||
] when
|
|
||||||
] when ;
|
|
||||||
|
|
||||||
: read-post-request ( header -- str hash )
|
|
||||||
content-length [ read dup query>hash ] [ f f ] if* ;
|
|
||||||
|
|
||||||
LOG: log-headers DEBUG
|
|
||||||
|
|
||||||
: interesting-headers ( assoc -- string )
|
|
||||||
[
|
|
||||||
[
|
|
||||||
drop {
|
|
||||||
"user-agent"
|
|
||||||
"referer"
|
|
||||||
"x-forwarded-for"
|
|
||||||
"host"
|
|
||||||
} member?
|
|
||||||
] assoc-subset [
|
|
||||||
": " swap 3append % "\n" %
|
|
||||||
] multi-assoc-each
|
|
||||||
] "" make ;
|
|
||||||
|
|
||||||
: prepare-url ( url -- url )
|
|
||||||
#! This is executed in the with-request namespace.
|
|
||||||
"?" split1
|
|
||||||
dup "raw-query" set query>hash "query" set
|
|
||||||
dup "request" set ;
|
|
||||||
|
|
||||||
: prepare-header ( -- )
|
|
||||||
read-header
|
|
||||||
dup "header" set
|
|
||||||
dup interesting-headers log-headers
|
|
||||||
read-post-request "response" set "raw-response" set ;
|
|
||||||
|
|
||||||
! Responders are called in a new namespace with these
|
|
||||||
! variables:
|
|
||||||
|
|
||||||
! - method -- one of get, post, or head.
|
|
||||||
! - request -- the entire URL requested, including responder
|
|
||||||
! name
|
|
||||||
! - responder-url -- the component of the URL for the responder
|
|
||||||
! - raw-query -- raw query string
|
|
||||||
! - query -- a hashtable of query parameters, eg
|
|
||||||
! foo.bar?a=b&c=d becomes
|
|
||||||
! H{ { "a" "b" } { "c" "d" } }
|
|
||||||
! - header -- a hashtable of headers from the user's client
|
|
||||||
! - response -- a hashtable of the POST request response
|
|
||||||
! - raw-response -- raw POST request response
|
|
||||||
|
|
||||||
: query-param ( key -- value ) "query" get at ;
|
|
||||||
|
|
||||||
: header-param ( key -- value )
|
|
||||||
"header" get peek-at ;
|
|
||||||
|
|
||||||
: host ( -- string )
|
|
||||||
#! The host the current responder was called from.
|
|
||||||
"host" header-param ":" split1 drop ;
|
|
||||||
|
|
||||||
: add-responder ( responder -- )
|
|
||||||
#! Add a responder object to the list.
|
|
||||||
"responder" over at responders get set-at ;
|
|
||||||
|
|
||||||
: make-responder ( quot -- )
|
|
||||||
#! quot has stack effect ( url -- )
|
|
||||||
[
|
|
||||||
[
|
|
||||||
drop "GET method not implemented" httpd-error
|
|
||||||
] "get" set
|
|
||||||
[
|
|
||||||
drop "POST method not implemented" httpd-error
|
|
||||||
] "post" set
|
|
||||||
[
|
|
||||||
drop "HEAD method not implemented" httpd-error
|
|
||||||
] "head" set
|
|
||||||
[
|
|
||||||
drop bad-request
|
|
||||||
] "bad" set
|
|
||||||
|
|
||||||
call
|
|
||||||
] H{ } make-assoc add-responder ;
|
|
||||||
|
|
||||||
: add-simple-responder ( name quot -- )
|
|
||||||
[
|
|
||||||
[ drop ] swap append dup "get" set "post" set
|
|
||||||
"responder" set
|
|
||||||
] make-responder ;
|
|
||||||
|
|
||||||
: vhost ( name -- vhost )
|
|
||||||
vhosts get at [ "default" vhost ] unless* ;
|
|
||||||
|
|
||||||
: responder ( name -- responder )
|
|
||||||
responders get at [ "404" responder ] unless* ;
|
|
||||||
|
|
||||||
: set-default-responder ( name -- )
|
|
||||||
responder "default" responders get set-at ;
|
|
||||||
|
|
||||||
: call-responder ( method argument responder -- )
|
|
||||||
over "argument" set [ swap get with-scope ] bind ;
|
|
||||||
|
|
||||||
: serve-default-responder ( method url -- )
|
|
||||||
"/" "responder-url" set
|
|
||||||
"default" responder call-responder ;
|
|
||||||
|
|
||||||
: trim-/ ( url -- url )
|
|
||||||
#! Trim a leading /, if there is one.
|
|
||||||
"/" ?head drop ;
|
|
||||||
|
|
||||||
: serve-explicit-responder ( method url -- )
|
|
||||||
"/" split1
|
|
||||||
"/responder/" pick "/" 3append "responder-url" set
|
|
||||||
dup [
|
|
||||||
swap responder call-responder
|
|
||||||
] [
|
|
||||||
! Just a responder name by itself
|
|
||||||
drop "request" get "/" append permanent-redirect 2drop
|
|
||||||
] if ;
|
|
||||||
|
|
||||||
: serve-responder ( method path host -- )
|
|
||||||
#! Responder paths come in two forms:
|
|
||||||
#! /foo/bar... - default responder used
|
|
||||||
#! /responder/foo/bar - responder foo, argument bar
|
|
||||||
vhost [
|
|
||||||
trim-/ "responder/" ?head [
|
|
||||||
serve-explicit-responder
|
|
||||||
] [
|
|
||||||
serve-default-responder
|
|
||||||
] if
|
|
||||||
] bind ;
|
|
||||||
|
|
||||||
\ serve-responder DEBUG add-input-logging
|
|
||||||
|
|
||||||
: no-such-responder ( -- )
|
|
||||||
"404 No such responder" httpd-error ;
|
|
||||||
|
|
||||||
! create a responders hash if it doesn't already exist
|
|
||||||
global [
|
|
||||||
responders [ H{ } assoc-like ] change
|
|
||||||
|
|
||||||
! 404 error message pages are served by this guy
|
|
||||||
"404" [ no-such-responder ] add-simple-responder
|
|
||||||
|
|
||||||
H{ } clone "default" associate vhosts set
|
|
||||||
] bind
|
|
||||||
|
|
@ -1,39 +1,61 @@
|
||||||
USING: webapps.file http.server.responders http
|
USING: http.server tools.test kernel namespaces accessors
|
||||||
http.server namespaces io tools.test strings io.server
|
new-slots io http math sequences assocs ;
|
||||||
logging ;
|
|
||||||
IN: http.server.tests
|
IN: http.server.tests
|
||||||
|
|
||||||
[ ] [ f [ "404 not found" httpd-error ] with-logging ] unit-test
|
TUPLE: mock-responder path ;
|
||||||
|
|
||||||
[ "inspect/global" ] [ "/inspect/global" trim-/ ] unit-test
|
C: <mock-responder> mock-responder
|
||||||
|
|
||||||
[ "index.html" ]
|
M: mock-responder call-responder
|
||||||
[ "http://www.jedit.org/index.html" url>path ] unit-test
|
2nip
|
||||||
|
path>> on
|
||||||
|
"text/plain" <content> ;
|
||||||
|
|
||||||
[ "foo/bar" ]
|
: check-dispatch ( tag path -- ? )
|
||||||
[ "http://www.jedit.org/foo/bar" url>path ] unit-test
|
over off
|
||||||
|
<request> swap default-host get call-responder
|
||||||
|
write-response get ;
|
||||||
|
|
||||||
[ "" ]
|
[
|
||||||
[ "http://www.jedit.org/" url>path ] unit-test
|
<dispatcher>
|
||||||
|
"foo" <mock-responder> "foo" add-responder
|
||||||
|
"bar" <mock-responder> "bar" add-responder
|
||||||
|
<dispatcher>
|
||||||
|
"123" <mock-responder> "123" add-responder
|
||||||
|
"default" <mock-responder> >>default
|
||||||
|
"baz" add-responder
|
||||||
|
default-host set
|
||||||
|
|
||||||
[ "" ]
|
[ "foo" ] [
|
||||||
[ "http://www.jedit.org" url>path ] unit-test
|
"foo" default-host get find-responder path>> nip
|
||||||
|
] unit-test
|
||||||
|
|
||||||
[ "foobar" ]
|
[ "bar" ] [
|
||||||
[ "foobar" secure-path ] unit-test
|
"bar" default-host get find-responder path>> nip
|
||||||
|
] unit-test
|
||||||
|
|
||||||
[ f ]
|
[ t ] [ "foo" "foo" check-dispatch ] unit-test
|
||||||
[ "foobar/../baz" secure-path ] unit-test
|
[ f ] [ "foo" "bar" check-dispatch ] unit-test
|
||||||
|
[ t ] [ "bar" "bar" check-dispatch ] unit-test
|
||||||
|
[ t ] [ "default" "baz/xxx" check-dispatch ] unit-test
|
||||||
|
[ t ] [ "default" "baz/xxx//" check-dispatch ] unit-test
|
||||||
|
[ t ] [ "default" "/baz/xxx//" check-dispatch ] unit-test
|
||||||
|
[ t ] [ "123" "baz/123" check-dispatch ] unit-test
|
||||||
|
[ t ] [ "123" "baz///123" check-dispatch ] unit-test
|
||||||
|
|
||||||
[ ] [ f [ "GET ../index.html" parse-request ] with-logging ] unit-test
|
[ t ] [
|
||||||
[ ] [ f [ "POO" parse-request ] with-logging ] unit-test
|
<request>
|
||||||
|
"baz" >>path
|
||||||
|
"baz" default-host get call-responder
|
||||||
|
dup code>> 300 399 between? >r
|
||||||
|
header>> "location" swap at "baz/" tail? r> and
|
||||||
|
] unit-test
|
||||||
|
] with-scope
|
||||||
|
|
||||||
[ H{ { "Foo" "Bar" } } ] [ "Foo=Bar" query>hash ] unit-test
|
[
|
||||||
|
<dispatcher>
|
||||||
|
"default" <mock-responder> >>default
|
||||||
|
default-host set
|
||||||
|
|
||||||
[ H{ { "Foo" "Bar" } { "Baz" "Quux" } } ]
|
[ "/default" ] [ "/default" default-host get find-responder drop ] unit-test
|
||||||
[ "Foo=Bar&Baz=Quux" query>hash ] unit-test
|
] with-scope
|
||||||
|
|
||||||
[ H{ { "Baz" " " } } ]
|
|
||||||
[ "Baz=%20" query>hash ] unit-test
|
|
||||||
|
|
||||||
[ H{ { "Foo" f } } ] [ "Foo" query>hash ] unit-test
|
|
||||||
|
|
|
||||||
|
|
@ -1,65 +1,171 @@
|
||||||
! Copyright (C) 2003, 2008 Slava Pestov.
|
! Copyright (C) 2003, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: assocs kernel namespaces io io.timeouts strings splitting
|
USING: assocs kernel namespaces io io.timeouts strings splitting
|
||||||
threads http http.server.responders sequences prettyprint
|
threads http sequences prettyprint io.server logging calendar
|
||||||
io.server logging calendar io.encodings.latin1 ;
|
new-slots html.elements accessors math.parser combinators.lib
|
||||||
|
vocabs.loader debugger html continuations random combinators
|
||||||
|
io.encodings.latin1 ;
|
||||||
IN: http.server
|
IN: http.server
|
||||||
|
|
||||||
: (url>path) ( uri -- path )
|
GENERIC: call-responder ( request path responder -- response )
|
||||||
url-decode "http://" ?head [
|
|
||||||
"/" split1 dup "" ? nip
|
|
||||||
] when ;
|
|
||||||
|
|
||||||
: url>path ( uri -- path )
|
TUPLE: trivial-responder response ;
|
||||||
"?" split1 dup [
|
|
||||||
>r (url>path) "?" r> 3append
|
|
||||||
] [
|
|
||||||
drop (url>path)
|
|
||||||
] if ;
|
|
||||||
|
|
||||||
: secure-path ( path -- path )
|
C: <trivial-responder> trivial-responder
|
||||||
".." over subseq? [ drop f ] when ;
|
|
||||||
|
|
||||||
: request-method ( cmd -- method )
|
M: trivial-responder call-responder nip response>> call ;
|
||||||
H{
|
|
||||||
{ "GET" "get" }
|
|
||||||
{ "POST" "post" }
|
|
||||||
{ "HEAD" "head" }
|
|
||||||
} at "bad" or ;
|
|
||||||
|
|
||||||
: (handle-request) ( arg cmd -- method path host )
|
: trivial-response-body ( code message -- )
|
||||||
request-method dup "method" set swap
|
<html>
|
||||||
prepare-url prepare-header host ;
|
<body>
|
||||||
|
<h1> swap number>string write bl write </h1>
|
||||||
|
</body>
|
||||||
|
</html> ;
|
||||||
|
|
||||||
: handle-request ( arg cmd -- )
|
: <trivial-response> ( code message -- response )
|
||||||
[ (handle-request) serve-responder ] with-scope ;
|
<response>
|
||||||
|
2over [ trivial-response-body ] 2curry >>body
|
||||||
|
"text/html" set-content-type
|
||||||
|
swap >>message
|
||||||
|
swap >>code ;
|
||||||
|
|
||||||
: parse-request ( request -- )
|
: <400> ( -- response )
|
||||||
" " split1 dup [
|
400 "Bad request" <trivial-response> ;
|
||||||
" HTTP" split1 drop url>path secure-path dup [
|
|
||||||
swap handle-request
|
: <404> ( -- response )
|
||||||
|
404 "Not Found" <trivial-response> ;
|
||||||
|
|
||||||
|
SYMBOL: 404-responder
|
||||||
|
|
||||||
|
[ drop <404> ] <trivial-responder> 404-responder set-global
|
||||||
|
|
||||||
|
: modify-for-redirect ( request to -- url )
|
||||||
|
{
|
||||||
|
{ [ dup "http://" head? ] [ nip ] }
|
||||||
|
{ [ dup "/" head? ] [ >>path request-url ] }
|
||||||
|
{ [ t ] [ >r dup path>> "/" last-split1 drop "/" r> 3append >>path request-url ] }
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
: <redirect> ( request to code message -- response )
|
||||||
|
<trivial-response>
|
||||||
|
-rot modify-for-redirect
|
||||||
|
"location" set-header ;
|
||||||
|
|
||||||
|
\ <redirect> DEBUG add-input-logging
|
||||||
|
|
||||||
|
: <permanent-redirect> ( request to -- response )
|
||||||
|
301 "Moved Permanently" <redirect> ;
|
||||||
|
|
||||||
|
: <temporary-redirect> ( request to -- response )
|
||||||
|
307 "Temporary Redirect" <redirect> ;
|
||||||
|
|
||||||
|
: <content> ( content-type -- response )
|
||||||
|
<response>
|
||||||
|
200 >>code
|
||||||
|
swap set-content-type ;
|
||||||
|
|
||||||
|
TUPLE: dispatcher default responders ;
|
||||||
|
|
||||||
|
: <dispatcher> ( -- dispatcher )
|
||||||
|
404-responder H{ } clone dispatcher construct-boa ;
|
||||||
|
|
||||||
|
: set-main ( dispatcher name -- dispatcher )
|
||||||
|
[ <permanent-redirect> ] curry
|
||||||
|
<trivial-responder> >>default ;
|
||||||
|
|
||||||
|
: split-path ( path -- rest first )
|
||||||
|
[ CHAR: / = ] left-trim "/" split1 swap ;
|
||||||
|
|
||||||
|
: find-responder ( path dispatcher -- path responder )
|
||||||
|
over split-path pick responders>> at*
|
||||||
|
[ >r >r 2drop r> r> ] [ 2drop default>> ] if ;
|
||||||
|
|
||||||
|
: redirect-with-/ ( request -- response )
|
||||||
|
dup path>> "/" append <permanent-redirect> ;
|
||||||
|
|
||||||
|
M: dispatcher call-responder
|
||||||
|
over [
|
||||||
|
3dup find-responder call-responder [
|
||||||
|
>r 3drop r>
|
||||||
] [
|
] [
|
||||||
2drop bad-request
|
default>> [
|
||||||
] if
|
call-responder
|
||||||
|
] [
|
||||||
|
3drop f
|
||||||
|
] if*
|
||||||
|
] if*
|
||||||
] [
|
] [
|
||||||
2drop bad-request
|
2drop redirect-with-/
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
\ parse-request NOTICE add-input-logging
|
: add-responder ( dispatcher responder path -- dispatcher )
|
||||||
|
pick responders>> set-at ;
|
||||||
|
|
||||||
|
: add-main-responder ( dispatcher responder path -- dispatcher )
|
||||||
|
[ add-responder ] keep set-main ;
|
||||||
|
|
||||||
|
: <webapp> ( class -- dispatcher )
|
||||||
|
<dispatcher> swap construct-delegate ; inline
|
||||||
|
|
||||||
|
SYMBOL: virtual-hosts
|
||||||
|
SYMBOL: default-host
|
||||||
|
|
||||||
|
virtual-hosts global [ drop H{ } clone ] cache drop
|
||||||
|
default-host global [ drop 404-responder get-global ] cache drop
|
||||||
|
|
||||||
|
: find-virtual-host ( host -- responder )
|
||||||
|
virtual-hosts get at [ default-host get ] unless* ;
|
||||||
|
|
||||||
|
SYMBOL: development-mode
|
||||||
|
|
||||||
|
: <500> ( error -- response )
|
||||||
|
500 "Internal server error" <trivial-response>
|
||||||
|
swap [
|
||||||
|
"Internal server error" [
|
||||||
|
development-mode get [
|
||||||
|
[ print-error nl :c ] with-html-stream
|
||||||
|
] [
|
||||||
|
500 "Internal server error"
|
||||||
|
trivial-response-body
|
||||||
|
] if
|
||||||
|
] simple-page
|
||||||
|
] curry >>body ;
|
||||||
|
|
||||||
|
: do-response ( request response -- )
|
||||||
|
dup write-response
|
||||||
|
swap method>> "HEAD" =
|
||||||
|
[ drop ] [ write-response-body ] if ;
|
||||||
|
|
||||||
|
: do-request ( request -- request )
|
||||||
|
[
|
||||||
|
dup dup path>> over host>>
|
||||||
|
find-virtual-host call-responder
|
||||||
|
[ <404> ] unless*
|
||||||
|
] [ dup \ do-request log-error <500> ] recover ;
|
||||||
|
|
||||||
|
: default-timeout 1 minutes stdio get set-timeout ;
|
||||||
|
|
||||||
|
LOG: httpd-hit NOTICE
|
||||||
|
|
||||||
|
: log-request ( request -- )
|
||||||
|
{ method>> host>> path>> } map-exec-with httpd-hit ;
|
||||||
|
|
||||||
|
: handle-client ( -- )
|
||||||
|
default-timeout
|
||||||
|
development-mode get-global
|
||||||
|
[ global [ refresh-all ] bind ] when
|
||||||
|
read-request
|
||||||
|
dup log-request
|
||||||
|
do-request do-response ;
|
||||||
|
|
||||||
: httpd ( port -- )
|
: httpd ( port -- )
|
||||||
internet-server "http.server" latin1 [
|
internet-server "http.server"
|
||||||
1 minutes stdio get set-timeout
|
latin1 [ handle-client ] with-server ;
|
||||||
readln [ parse-request ] when*
|
|
||||||
] with-server ;
|
|
||||||
|
|
||||||
: httpd-main ( -- ) 8888 httpd ;
|
: httpd-main ( -- ) 8888 httpd ;
|
||||||
|
|
||||||
MAIN: httpd-main
|
MAIN: httpd-main
|
||||||
|
|
||||||
! Load default webapps
|
: generate-key ( assoc -- str )
|
||||||
USE: webapps.file
|
4 big-random >hex dup pick key?
|
||||||
USE: webapps.callback
|
[ drop generate-key ] [ nip ] if ;
|
||||||
USE: webapps.continuation
|
|
||||||
USE: webapps.cgi
|
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1 @@
|
||||||
|
Doug Coleman
|
||||||
|
|
@ -0,0 +1,34 @@
|
||||||
|
IN: http.server.sessions.tests
|
||||||
|
USING: tools.test http.server.sessions math namespaces
|
||||||
|
kernel accessors ;
|
||||||
|
|
||||||
|
: with-session \ session swap with-variable ; inline
|
||||||
|
|
||||||
|
"1234" f <session> [
|
||||||
|
[ ] [ 3 "x" sset ] unit-test
|
||||||
|
|
||||||
|
[ 9 ] [ "x" sget sq ] unit-test
|
||||||
|
|
||||||
|
[ ] [ "x" [ 1- ] schange ] unit-test
|
||||||
|
|
||||||
|
[ 4 ] [ "x" sget sq ] unit-test
|
||||||
|
] with-session
|
||||||
|
|
||||||
|
[ t ] [ f <url-sessions> url-sessions? ] unit-test
|
||||||
|
[ t ] [ f <cookie-sessions> cookie-sessions? ] unit-test
|
||||||
|
|
||||||
|
[ ] [
|
||||||
|
f <url-sessions>
|
||||||
|
[ 0 "x" sset ] >>init
|
||||||
|
"manager" set
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ { 5 0 } ] [
|
||||||
|
[
|
||||||
|
"manager" get new-session
|
||||||
|
dup "manager" get get-session [ 5 "a" sset ] with-session
|
||||||
|
dup "manager" get get-session [ "a" sget , ] with-session
|
||||||
|
dup "manager" get get-session [ "x" sget , ] with-session
|
||||||
|
"manager" get get-session delete-session
|
||||||
|
] { } make
|
||||||
|
] unit-test
|
||||||
|
|
@ -0,0 +1,112 @@
|
||||||
|
! Copyright (C) 2008 Doug Coleman, Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: assocs calendar kernel math.parser namespaces random
|
||||||
|
boxes alarms new-slots accessors http http.server
|
||||||
|
quotations hashtables sequences ;
|
||||||
|
IN: http.server.sessions
|
||||||
|
|
||||||
|
! ! ! ! ! !
|
||||||
|
! WARNING: this session manager is vulnerable to XSRF attacks
|
||||||
|
! ! ! ! ! !
|
||||||
|
|
||||||
|
GENERIC: init-session ( responder -- )
|
||||||
|
|
||||||
|
TUPLE: session-manager responder sessions ;
|
||||||
|
|
||||||
|
: <session-manager> ( responder class -- responder' )
|
||||||
|
>r H{ } clone session-manager construct-boa r>
|
||||||
|
construct-delegate ; inline
|
||||||
|
|
||||||
|
TUPLE: session id manager namespace alarm ;
|
||||||
|
|
||||||
|
: <session> ( id manager -- session )
|
||||||
|
H{ } clone <box> \ session construct-boa ;
|
||||||
|
|
||||||
|
: timeout ( -- dt ) 20 minutes ;
|
||||||
|
|
||||||
|
: cancel-timeout ( session -- )
|
||||||
|
alarm>> [ cancel-alarm ] if-box? ;
|
||||||
|
|
||||||
|
: delete-session ( session -- )
|
||||||
|
dup cancel-timeout
|
||||||
|
dup manager>> sessions>> delete-at ;
|
||||||
|
|
||||||
|
: touch-session ( session -- )
|
||||||
|
dup cancel-timeout
|
||||||
|
dup [ delete-session ] curry timeout later
|
||||||
|
swap session-alarm >box ;
|
||||||
|
|
||||||
|
: session ( -- assoc ) \ session get namespace>> ;
|
||||||
|
|
||||||
|
: sget ( key -- value ) session at ;
|
||||||
|
|
||||||
|
: sset ( value key -- ) session set-at ;
|
||||||
|
|
||||||
|
: schange ( key quot -- ) session swap change-at ; inline
|
||||||
|
|
||||||
|
: new-session ( responder -- id )
|
||||||
|
[ sessions>> generate-key dup ] keep
|
||||||
|
[ <session> dup touch-session ] keep
|
||||||
|
[ swap \ session [ responder>> init-session ] with-variable ] 2keep
|
||||||
|
>r over r> sessions>> set-at ;
|
||||||
|
|
||||||
|
: get-session ( id responder -- session )
|
||||||
|
sessions>> tuck at* [
|
||||||
|
nip dup touch-session
|
||||||
|
] [
|
||||||
|
2drop f
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
: call-responder/session ( request path responder session -- response )
|
||||||
|
\ session set responder>> call-responder ;
|
||||||
|
|
||||||
|
: sessions ( -- manager/f )
|
||||||
|
\ session get dup [ manager>> ] when ;
|
||||||
|
|
||||||
|
GENERIC: session-link* ( url query sessions -- string )
|
||||||
|
|
||||||
|
M: object session-link* 2drop url-encode ;
|
||||||
|
|
||||||
|
: session-link ( url query -- string ) sessions session-link* ;
|
||||||
|
|
||||||
|
TUPLE: url-sessions ;
|
||||||
|
|
||||||
|
: <url-sessions> ( responder -- responder' )
|
||||||
|
url-sessions <session-manager> ;
|
||||||
|
|
||||||
|
: sess-id "factorsessid" ;
|
||||||
|
|
||||||
|
M: url-sessions call-responder ( request path responder -- response )
|
||||||
|
pick sess-id query-param over get-session [
|
||||||
|
call-responder/session
|
||||||
|
] [
|
||||||
|
new-session nip sess-id set-query-param
|
||||||
|
dup request-url <temporary-redirect>
|
||||||
|
] if* ;
|
||||||
|
|
||||||
|
M: url-sessions session-link*
|
||||||
|
drop
|
||||||
|
\ session get id>> sess-id associate union assoc>query
|
||||||
|
>r url-encode r>
|
||||||
|
dup assoc-empty? [ drop ] [ "?" swap 3append ] if ;
|
||||||
|
|
||||||
|
TUPLE: cookie-sessions ;
|
||||||
|
|
||||||
|
: <cookie-sessions> ( responder -- responder' )
|
||||||
|
cookie-sessions <session-manager> ;
|
||||||
|
|
||||||
|
: get-session-cookie ( request responder -- cookie )
|
||||||
|
>r sess-id get-cookie dup
|
||||||
|
[ value>> r> get-session ] [ r> 2drop f ] if ;
|
||||||
|
|
||||||
|
: <session-cookie> ( id -- cookie )
|
||||||
|
sess-id <cookie> ;
|
||||||
|
|
||||||
|
M: cookie-sessions call-responder ( request path responder -- response )
|
||||||
|
3dup nip get-session-cookie [
|
||||||
|
call-responder/session
|
||||||
|
] [
|
||||||
|
dup new-session
|
||||||
|
[ over get-session call-responder/session ] keep
|
||||||
|
<session-cookie> put-cookie
|
||||||
|
] if* ;
|
||||||
|
|
@ -0,0 +1,101 @@
|
||||||
|
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: calendar html io io.files kernel math math.parser http
|
||||||
|
http.server namespaces parser sequences strings assocs
|
||||||
|
hashtables debugger http.mime sorting html.elements logging
|
||||||
|
calendar.format new-slots accessors ;
|
||||||
|
IN: http.server.static
|
||||||
|
|
||||||
|
SYMBOL: responder
|
||||||
|
|
||||||
|
! special maps mime types to quots with effect ( path -- )
|
||||||
|
TUPLE: file-responder root hook special ;
|
||||||
|
|
||||||
|
: unix-time>timestamp ( n -- timestamp )
|
||||||
|
>r unix-1970 r> seconds time+ ;
|
||||||
|
|
||||||
|
: file-http-date ( filename -- string )
|
||||||
|
file-modified unix-time>timestamp timestamp>http-string ;
|
||||||
|
|
||||||
|
: last-modified-matches? ( filename -- ? )
|
||||||
|
file-http-date dup [
|
||||||
|
request get "if-modified-since" header =
|
||||||
|
] when ;
|
||||||
|
|
||||||
|
: <304> ( -- response )
|
||||||
|
304 "Not modified" <trivial-response> ;
|
||||||
|
|
||||||
|
: <file-responder> ( root hook -- responder )
|
||||||
|
H{ } clone file-responder construct-boa ;
|
||||||
|
|
||||||
|
: <static> ( root -- responder )
|
||||||
|
[
|
||||||
|
<content>
|
||||||
|
over file-length "content-length" set-header
|
||||||
|
over file-http-date "last-modified" set-header
|
||||||
|
swap [ <file-reader> stdio get stream-copy ] curry >>body
|
||||||
|
] <file-responder> ;
|
||||||
|
|
||||||
|
: serve-static ( filename mime-type -- response )
|
||||||
|
over last-modified-matches?
|
||||||
|
[ 2drop <304> ] [ responder get hook>> call ] if ;
|
||||||
|
|
||||||
|
: serving-path ( filename -- filename )
|
||||||
|
"" or responder get root>> swap path+ ;
|
||||||
|
|
||||||
|
: serve-file ( filename -- response )
|
||||||
|
dup mime-type
|
||||||
|
dup responder get special>> at
|
||||||
|
[ call ] [ serve-static ] ?if ;
|
||||||
|
|
||||||
|
\ serve-file NOTICE add-input-logging
|
||||||
|
|
||||||
|
: file. ( name dirp -- )
|
||||||
|
[ "/" append ] when
|
||||||
|
dup <a =href a> write </a> ;
|
||||||
|
|
||||||
|
: directory. ( path -- )
|
||||||
|
dup file-name [
|
||||||
|
<h1> dup file-name write </h1>
|
||||||
|
<ul>
|
||||||
|
directory sort-keys
|
||||||
|
[ <li> file. </li> ] assoc-each
|
||||||
|
</ul>
|
||||||
|
] simple-html-document ;
|
||||||
|
|
||||||
|
: list-directory ( directory -- response )
|
||||||
|
"text/html" <content>
|
||||||
|
swap [ directory. ] curry >>body ;
|
||||||
|
|
||||||
|
: find-index ( filename -- path )
|
||||||
|
{ "index.html" "index.fhtml" }
|
||||||
|
[ dupd path+ exists? ] find nip
|
||||||
|
dup [ path+ ] [ nip ] if ;
|
||||||
|
|
||||||
|
: serve-directory ( filename -- response )
|
||||||
|
dup "/" tail? [
|
||||||
|
dup find-index
|
||||||
|
[ serve-file ] [ list-directory ] ?if
|
||||||
|
] [
|
||||||
|
drop request get redirect-with-/
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
: serve-object ( filename -- response )
|
||||||
|
serving-path dup exists? [
|
||||||
|
dup directory? [ serve-directory ] [ serve-file ] if
|
||||||
|
] [
|
||||||
|
drop <404>
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
M: file-responder call-responder ( request path responder -- response )
|
||||||
|
over [
|
||||||
|
".." pick subseq? [
|
||||||
|
3drop <400>
|
||||||
|
] [
|
||||||
|
responder set
|
||||||
|
swap request set
|
||||||
|
serve-object
|
||||||
|
] if
|
||||||
|
] [
|
||||||
|
2drop redirect-with-/
|
||||||
|
] if ;
|
||||||
|
|
@ -4,7 +4,8 @@
|
||||||
USING: continuations sequences kernel parser namespaces io
|
USING: continuations sequences kernel parser namespaces io
|
||||||
io.files io.streams.string html html.elements
|
io.files io.streams.string html html.elements
|
||||||
source-files debugger combinators math quotations generic
|
source-files debugger combinators math quotations generic
|
||||||
strings splitting io.encodings.utf8 ;
|
strings splitting accessors http.server.static http.server
|
||||||
|
assocs io.encodings.utf8 ;
|
||||||
|
|
||||||
IN: http.server.templating
|
IN: http.server.templating
|
||||||
|
|
||||||
|
|
@ -93,3 +94,13 @@ DEFER: <% delimiter
|
||||||
|
|
||||||
: template-convert ( infile outfile -- )
|
: template-convert ( infile outfile -- )
|
||||||
utf8 [ run-template-file ] with-file-writer ;
|
utf8 [ run-template-file ] with-file-writer ;
|
||||||
|
|
||||||
|
! file responder integration
|
||||||
|
: serve-fhtml ( filename -- response )
|
||||||
|
"text/html" <content>
|
||||||
|
swap [ run-template-file ] curry >>body ;
|
||||||
|
|
||||||
|
: enable-fhtml ( responder -- responder )
|
||||||
|
[ serve-fhtml ]
|
||||||
|
"application/x-factor-server-page"
|
||||||
|
pick special>> set-at ;
|
||||||
|
|
|
||||||
|
|
@ -367,14 +367,14 @@ M: lambda-method definer drop \ M:: \ ; ;
|
||||||
M: lambda-method definition
|
M: lambda-method definition
|
||||||
"lambda" word-prop lambda-body ;
|
"lambda" word-prop lambda-body ;
|
||||||
|
|
||||||
: method-stack-effect
|
: method-stack-effect ( method -- effect )
|
||||||
dup "lambda" word-prop lambda-vars
|
dup "lambda" word-prop lambda-vars
|
||||||
swap "method-generic" word-prop stack-effect
|
swap "method-generic" word-prop stack-effect
|
||||||
dup [ effect-out ] when
|
dup [ effect-out ] when
|
||||||
<effect> ;
|
<effect> ;
|
||||||
|
|
||||||
M: lambda-method synopsis*
|
M: lambda-method synopsis*
|
||||||
dup dup definer.
|
dup dup dup definer.
|
||||||
"method-specializer" word-prop pprint*
|
"method-specializer" word-prop pprint*
|
||||||
"method-generic" word-prop pprint*
|
"method-generic" word-prop pprint*
|
||||||
method-stack-effect effect>string comment. ;
|
method-stack-effect effect>string comment. ;
|
||||||
|
|
|
||||||
|
|
@ -8,5 +8,5 @@ M: integer foo + ;
|
||||||
|
|
||||||
"resource:extra/tools/crossref/test/foo.factor" run-file
|
"resource:extra/tools/crossref/test/foo.factor" run-file
|
||||||
|
|
||||||
[ t ] [ integer \ foo method method-word \ + usage member? ] unit-test
|
[ t ] [ integer \ foo method \ + usage member? ] unit-test
|
||||||
[ t ] [ \ foo usage [ pathname? ] contains? ] unit-test
|
[ t ] [ \ foo usage [ pathname? ] contains? ] unit-test
|
||||||
|
|
|
||||||
|
|
@ -1,5 +1,6 @@
|
||||||
USING: cocoa cocoa.messages cocoa.application cocoa.nibs
|
USING: cocoa cocoa.messages cocoa.application cocoa.nibs
|
||||||
assocs namespaces kernel words compiler sequences ui.cocoa ;
|
assocs namespaces kernel words compiler.units sequences
|
||||||
|
ui.cocoa ;
|
||||||
|
|
||||||
"stop-after-last-window?" get
|
"stop-after-last-window?" get
|
||||||
global [
|
global [
|
||||||
|
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
Slava Pestov
|
|
||||||
|
|
@ -1,75 +0,0 @@
|
||||||
! Copyright (C) 2007, 2008 Slava Pestov.
|
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
|
||||||
USING: namespaces kernel assocs io.files combinators
|
|
||||||
arrays io.launcher io http.server.responders webapps.file
|
|
||||||
sequences strings math.parser unicode.case io.encodings.binary ;
|
|
||||||
IN: webapps.cgi
|
|
||||||
|
|
||||||
SYMBOL: cgi-root
|
|
||||||
|
|
||||||
: post? "method" get "post" = ;
|
|
||||||
|
|
||||||
: cgi-variables ( script-path -- assoc )
|
|
||||||
#! This needs some work.
|
|
||||||
[
|
|
||||||
"CGI/1.0" "GATEWAY_INTERFACE" set
|
|
||||||
"HTTP/1.0" "SERVER_PROTOCOL" set
|
|
||||||
"Factor" "SERVER_SOFTWARE" set
|
|
||||||
|
|
||||||
dup "PATH_TRANSLATED" set
|
|
||||||
"SCRIPT_FILENAME" set
|
|
||||||
|
|
||||||
"request" get "SCRIPT_NAME" set
|
|
||||||
|
|
||||||
host "SERVER_NAME" set
|
|
||||||
"" "SERVER_PORT" set
|
|
||||||
"" "PATH_INFO" set
|
|
||||||
"" "REMOTE_HOST" set
|
|
||||||
"" "REMOTE_ADDR" set
|
|
||||||
"" "AUTH_TYPE" set
|
|
||||||
"" "REMOTE_USER" set
|
|
||||||
"" "REMOTE_IDENT" set
|
|
||||||
|
|
||||||
"method" get >upper "REQUEST_METHOD" set
|
|
||||||
"raw-query" get "QUERY_STRING" set
|
|
||||||
"cookie" header-param "HTTP_COOKIE" set
|
|
||||||
|
|
||||||
"user-agent" header-param "HTTP_USER_AGENT" set
|
|
||||||
"accept" header-param "HTTP_ACCEPT" set
|
|
||||||
|
|
||||||
post? [
|
|
||||||
"content-type" header-param "CONTENT_TYPE" set
|
|
||||||
"raw-response" get length number>string "CONTENT_LENGTH" set
|
|
||||||
] when
|
|
||||||
] H{ } make-assoc ;
|
|
||||||
|
|
||||||
: cgi-descriptor ( name -- desc )
|
|
||||||
[
|
|
||||||
cgi-root get swap path+ dup 1array +arguments+ set
|
|
||||||
cgi-variables +environment+ set
|
|
||||||
] H{ } make-assoc ;
|
|
||||||
|
|
||||||
: (do-cgi) ( name -- )
|
|
||||||
"200 CGI output follows" response
|
|
||||||
stdio get swap cgi-descriptor binary <process-stream> [
|
|
||||||
post? [
|
|
||||||
"raw-response" get write flush
|
|
||||||
] when
|
|
||||||
stdio get swap (stream-copy)
|
|
||||||
] with-stream ;
|
|
||||||
|
|
||||||
: serve-regular-file ( -- )
|
|
||||||
cgi-root get doc-root [ file-responder ] with-variable ;
|
|
||||||
|
|
||||||
: do-cgi ( name -- )
|
|
||||||
{
|
|
||||||
{ [ dup ".cgi" tail? not ] [ drop serve-regular-file ] }
|
|
||||||
{ [ dup empty? ] [ "403 forbidden" httpd-error ] }
|
|
||||||
{ [ cgi-root get not ] [ "404 cgi-root not set" httpd-error ] }
|
|
||||||
{ [ ".." over subseq? ] [ "403 forbidden" httpd-error ] }
|
|
||||||
{ [ t ] [ (do-cgi) ] }
|
|
||||||
} cond ;
|
|
||||||
|
|
||||||
global [
|
|
||||||
"cgi" [ "argument" get do-cgi ] add-simple-responder
|
|
||||||
] bind
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
Slava Pestov
|
|
||||||
|
|
@ -1,136 +0,0 @@
|
||||||
! Copyright (C) 2004, 2008 Slava Pestov.
|
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
|
||||||
USING: calendar html io io.files kernel math math.parser
|
|
||||||
http.server.responders http.server.templating namespaces parser
|
|
||||||
sequences strings assocs hashtables debugger http.mime sorting
|
|
||||||
html.elements logging calendar.format io.encodings.binary ;
|
|
||||||
IN: webapps.file
|
|
||||||
|
|
||||||
SYMBOL: doc-root
|
|
||||||
|
|
||||||
: serving-path ( filename -- filename )
|
|
||||||
"" or doc-root get swap path+ ;
|
|
||||||
|
|
||||||
: unix-time>timestamp ( n -- timestamp )
|
|
||||||
>r unix-1970 r> seconds time+ ;
|
|
||||||
|
|
||||||
: file-http-date ( filename -- string )
|
|
||||||
file-modified unix-time>timestamp timestamp>http-string ;
|
|
||||||
|
|
||||||
: file-response ( filename mime-type -- )
|
|
||||||
"200 OK" response
|
|
||||||
[
|
|
||||||
"Content-Type" set
|
|
||||||
dup file-length number>string "Content-Length" set
|
|
||||||
file-http-date "Last-Modified" set
|
|
||||||
now timestamp>http-string "Date" set
|
|
||||||
] H{ } make-assoc print-header ;
|
|
||||||
|
|
||||||
: last-modified-matches? ( filename -- bool )
|
|
||||||
file-http-date dup [
|
|
||||||
"if-modified-since" header-param =
|
|
||||||
] when ;
|
|
||||||
|
|
||||||
: not-modified-response ( -- )
|
|
||||||
"304 Not Modified" response
|
|
||||||
now timestamp>http-string "Date" associate print-header ;
|
|
||||||
|
|
||||||
! You can override how files are served in a custom responder
|
|
||||||
SYMBOL: serve-file-hook
|
|
||||||
|
|
||||||
[
|
|
||||||
dupd
|
|
||||||
file-response
|
|
||||||
binary <file-reader> stdio get stream-copy
|
|
||||||
] serve-file-hook set-global
|
|
||||||
|
|
||||||
: serve-static ( filename mime-type -- )
|
|
||||||
over last-modified-matches? [
|
|
||||||
2drop not-modified-response
|
|
||||||
] [
|
|
||||||
"method" get "head" = [
|
|
||||||
file-response
|
|
||||||
] [
|
|
||||||
serve-file-hook get call
|
|
||||||
] if
|
|
||||||
] if ;
|
|
||||||
|
|
||||||
SYMBOL: page
|
|
||||||
|
|
||||||
: run-page ( filename -- )
|
|
||||||
dup
|
|
||||||
[ [ dup page set run-template-file ] with-scope ] try
|
|
||||||
drop ;
|
|
||||||
|
|
||||||
\ run-page DEBUG add-input-logging
|
|
||||||
|
|
||||||
: include-page ( filename -- )
|
|
||||||
serving-path run-page ;
|
|
||||||
|
|
||||||
: serve-fhtml ( filename -- )
|
|
||||||
serving-html
|
|
||||||
"method" get "head" = [ drop ] [ run-page ] if ;
|
|
||||||
|
|
||||||
: serve-file ( filename -- )
|
|
||||||
dup mime-type dup "application/x-factor-server-page" =
|
|
||||||
[ drop serve-fhtml ] [ serve-static ] if ;
|
|
||||||
|
|
||||||
\ serve-file NOTICE add-input-logging
|
|
||||||
|
|
||||||
: file. ( name dirp -- )
|
|
||||||
[ "/" append ] when
|
|
||||||
dup <a =href a> write </a> ;
|
|
||||||
|
|
||||||
: directory. ( path request -- )
|
|
||||||
dup [
|
|
||||||
<h1> write </h1>
|
|
||||||
<ul>
|
|
||||||
directory sort-keys
|
|
||||||
[ <li> file. </li> ] assoc-each
|
|
||||||
</ul>
|
|
||||||
] simple-html-document ;
|
|
||||||
|
|
||||||
: list-directory ( directory -- )
|
|
||||||
serving-html
|
|
||||||
"method" get "head" = [
|
|
||||||
drop
|
|
||||||
] [
|
|
||||||
"request" get directory.
|
|
||||||
] if ;
|
|
||||||
|
|
||||||
: find-index ( filename -- path )
|
|
||||||
{ "index.html" "index.fhtml" }
|
|
||||||
[ dupd path+ exists? ] find nip
|
|
||||||
dup [ path+ ] [ nip ] if ;
|
|
||||||
|
|
||||||
: serve-directory ( filename -- )
|
|
||||||
dup "/" tail? [
|
|
||||||
dup find-index
|
|
||||||
[ serve-file ] [ list-directory ] ?if
|
|
||||||
] [
|
|
||||||
drop directory-no/
|
|
||||||
] if ;
|
|
||||||
|
|
||||||
: serve-object ( filename -- )
|
|
||||||
serving-path dup exists? [
|
|
||||||
dup directory? [ serve-directory ] [ serve-file ] if
|
|
||||||
] [
|
|
||||||
drop "404 not found" httpd-error
|
|
||||||
] if ;
|
|
||||||
|
|
||||||
: file-responder ( -- )
|
|
||||||
doc-root get [
|
|
||||||
"argument" get serve-object
|
|
||||||
] [
|
|
||||||
"404 doc-root not set" httpd-error
|
|
||||||
] if ;
|
|
||||||
|
|
||||||
global [
|
|
||||||
! Serves files from a directory stored in the doc-root
|
|
||||||
! variable. You can set the variable in the global
|
|
||||||
! namespace, or inside the responder.
|
|
||||||
"file" [ file-responder ] add-simple-responder
|
|
||||||
|
|
||||||
! The root directory is served by...
|
|
||||||
"file" set-default-responder
|
|
||||||
] bind
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
Slava Pestov
|
|
||||||
|
|
@ -1,35 +0,0 @@
|
||||||
! Copyright (C) 2007 Slava Pestov.
|
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
|
||||||
USING: io.files namespaces webapps.file http.server.responders
|
|
||||||
xmode.code2html kernel html sequences io.encodings.utf8 ;
|
|
||||||
IN: webapps.source
|
|
||||||
|
|
||||||
! This responder is a potential security problem. Make sure you
|
|
||||||
! don't have sensitive files stored under vm/, core/, extra/
|
|
||||||
! or misc/.
|
|
||||||
|
|
||||||
: check-source-path ( path -- ? )
|
|
||||||
{ "vm/" "core/" "extra/" "misc/" }
|
|
||||||
[ head? ] with contains? ;
|
|
||||||
|
|
||||||
: source-responder ( path mime-type -- )
|
|
||||||
drop
|
|
||||||
serving-html
|
|
||||||
[
|
|
||||||
dup file-name swap utf8 <file-reader> htmlize-stream
|
|
||||||
] with-html-stream ;
|
|
||||||
|
|
||||||
global [
|
|
||||||
! Serve up our own source code
|
|
||||||
"source" [
|
|
||||||
"argument" get check-source-path [
|
|
||||||
[
|
|
||||||
"" resource-path doc-root set
|
|
||||||
[ source-responder ] serve-file-hook set
|
|
||||||
file-responder
|
|
||||||
] with-scope
|
|
||||||
] [
|
|
||||||
"403 forbidden" httpd-error
|
|
||||||
] if
|
|
||||||
] add-simple-responder
|
|
||||||
] bind
|
|
||||||
|
|
@ -0,0 +1,15 @@
|
||||||
|
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: io.files namespaces http.server http.server.static http
|
||||||
|
xmode.code2html kernel html sequences accessors ;
|
||||||
|
IN: xmode.code2html.responder
|
||||||
|
|
||||||
|
: <sources> ( root -- responder )
|
||||||
|
[
|
||||||
|
drop
|
||||||
|
"text/html" <content>
|
||||||
|
over file-http-date "last-modified" set-header
|
||||||
|
swap [
|
||||||
|
dup file-name swap <file-reader> htmlize-stream
|
||||||
|
] curry >>body
|
||||||
|
] <file-responder> ;
|
||||||
Loading…
Reference in New Issue