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
|
||||
[ f ] [ \ tuple \ c class< ] unit-test
|
||||
|
||||
DEFER: bah
|
||||
FORGET: bah
|
||||
! DEFER: bah
|
||||
! FORGET: bah
|
||||
UNION: bah fixnum alien ;
|
||||
[ 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 ;
|
||||
|
||||
M: generic definer drop f f ;
|
||||
|
||||
M: generic definition drop f ;
|
||||
|
||||
: make-generic ( word -- )
|
||||
|
|
|
|||
|
|
@ -141,7 +141,7 @@ SYMBOL: quot-uses-b
|
|||
|
||||
[ { + } ] [ \ 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
|
||||
|
||||
[ ] [
|
||||
|
|
|
|||
|
|
@ -68,7 +68,7 @@ SYMBOL: bootstrapping?
|
|||
: crossref? ( word -- ? )
|
||||
{
|
||||
{ [ dup "forgotten" word-prop ] [ f ] }
|
||||
{ [ dup "method-definition" word-prop ] [ t ] }
|
||||
{ [ dup "method-def" word-prop ] [ t ] }
|
||||
{ [ dup word-vocabulary ] [ t ] }
|
||||
{ [ t ] [ f ] }
|
||||
} cond nip ;
|
||||
|
|
|
|||
|
|
@ -16,13 +16,16 @@ IN: assocs.lib
|
|||
: at-default ( key assoc -- value/key )
|
||||
dupd at [ nip ] when* ;
|
||||
|
||||
: replace-at ( assoc value key -- assoc )
|
||||
>r >r dup r> 1vector r> rot set-at ;
|
||||
|
||||
: insert-at ( value key assoc -- )
|
||||
[ ?push ] change-at ;
|
||||
|
||||
: peek-at* ( key assoc -- obj ? )
|
||||
at* dup [ >r peek r> ] when ;
|
||||
: peek-at* ( assoc key -- obj ? )
|
||||
swap at* dup [ >r peek r> ] when ;
|
||||
|
||||
: peek-at ( key assoc -- obj )
|
||||
: peek-at ( assoc key -- obj )
|
||||
peek-at* drop ;
|
||||
|
||||
: >multi-assoc ( assoc -- new-assoc )
|
||||
|
|
|
|||
|
|
@ -21,7 +21,7 @@ IN: benchmark
|
|||
] with-row
|
||||
[
|
||||
[
|
||||
swap [ ($vocab-link) ] with-cell
|
||||
swap [ dup ($vocab-link) ] with-cell
|
||||
first2 pprint-cell pprint-cell
|
||||
] with-row
|
||||
] 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_reset ( 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_double ( sqlite3_stmt* pStmt, int index, double x ) ;
|
||||
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%
|
||||
[ ", " 0% ]
|
||||
[ dup sql-spec-column-name 0% " = " 0% bind% ] interleave
|
||||
";" 0%
|
||||
] if
|
||||
";" 0%
|
||||
] sqlite-make ;
|
||||
|
||||
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
|
||||
[ bind-tuple ] keep execute-statement ;
|
||||
|
||||
: select-tuples ( tuple -- tuple )
|
||||
: select-tuples ( tuple -- tuples )
|
||||
dup dup class <select-by-slots-statement> [
|
||||
[ bind-tuple ] keep query-tuples
|
||||
] with-disposal ;
|
||||
|
|
|
|||
|
|
@ -39,7 +39,8 @@ M: tuple-class group-words
|
|||
: define-mimic ( group mimicker mimicked -- )
|
||||
>r >r group-words r> r> [
|
||||
pick "methods" word-prop at dup
|
||||
[ method-def spin define-method ] [ 3drop ] if
|
||||
[ "method-def" word-prop spin define-method ]
|
||||
[ 3drop ] if
|
||||
] 2curry each ;
|
||||
|
||||
: MIMIC:
|
||||
|
|
|
|||
|
|
@ -35,6 +35,17 @@ SYMBOL: current-action
|
|||
SYMBOL: validators-errored
|
||||
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 )
|
||||
[
|
||||
"/responder/" %
|
||||
|
|
|
|||
|
|
@ -173,7 +173,7 @@ M: f print-element drop ;
|
|||
|
||||
: $vocabulary ( element -- )
|
||||
first word-vocabulary [
|
||||
"Vocabulary" $heading nl ($vocab-link)
|
||||
"Vocabulary" $heading nl dup ($vocab-link)
|
||||
] when* ;
|
||||
|
||||
: 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" 8888 ] [ "localhost:8888" parse-host ] unit-test
|
||||
[ "localhost:8888" "/foo" ] [ "http://localhost:8888/foo" 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" "localhost" 8888 ] [ "http://localhost:8888/foo" parse-url ] unit-test
|
||||
[ "/" "localhost" 8888 ] [ "http://localhost:8888" parse-url ] 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/" 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.
|
||||
USING: assocs http kernel math math.parser namespaces sequences
|
||||
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
|
||||
|
||||
: parse-host ( url -- host port )
|
||||
#! Extract the host name and port number from an HTTP URL.
|
||||
":" 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
|
||||
: parse-url ( url -- resource host port )
|
||||
"http://" ?head [ "Only http:// supported" throw ] unless
|
||||
"/" split1 [ "/" swap append ] [ "/" ] if*
|
||||
>r dup empty? [ drop domain get ] [ dup domain set ] if r> ;
|
||||
swap parse-host ;
|
||||
|
||||
: parse-response ( line -- code )
|
||||
"HTTP/" ?head [ " " split1 nip ] when
|
||||
" " split1 drop string>number [
|
||||
"Premature end of stream" throw
|
||||
] unless* ;
|
||||
<PRIVATE
|
||||
|
||||
: read-response ( -- code header )
|
||||
#! After sending a GET or POST we read a response line and
|
||||
#! header.
|
||||
flush readln parse-response read-header ;
|
||||
: store-path ( request path -- request )
|
||||
"?" split1 >r >>path r> dup [ query>assoc ] when >>query ;
|
||||
|
||||
: 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 -- )
|
||||
write bl write " HTTP/1.0" write crlf
|
||||
"Host: " write write crlf ;
|
||||
DEFER: (http-request)
|
||||
|
||||
: get-request ( host resource -- )
|
||||
"GET" http-request crlf ;
|
||||
: absolute-redirect ( url -- request )
|
||||
"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 )
|
||||
#! Should this support Location: headers that are
|
||||
#! relative URLs?
|
||||
pick 100 /i 3 = [
|
||||
dispose "location" swap peek-at nip http-get-stream
|
||||
] when ;
|
||||
: do-redirect ( response -- response stream )
|
||||
dup response-code 300 399 between? [
|
||||
header>> "location" swap at
|
||||
dup "http://" head? [
|
||||
absolute-redirect
|
||||
] [
|
||||
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 )
|
||||
#! Opens a stream for reading from an HTTP URL.
|
||||
parse-url over parse-host <inet> <client> [
|
||||
[ [ get-request read-response ] with-stream* ] keep
|
||||
default-timeout
|
||||
] [ ] [ dispose ] cleanup do-redirect ;
|
||||
PRIVATE>
|
||||
|
||||
: http-request ( url request -- response stream )
|
||||
[
|
||||
request-with-url
|
||||
[
|
||||
(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 = ;
|
||||
|
||||
: check-response ( code headers stream -- stream )
|
||||
nip swap success?
|
||||
: check-response ( response stream -- stream )
|
||||
swap code>> success?
|
||||
[ dispose "HTTP download failed" throw ] unless ;
|
||||
|
||||
: http-get ( url -- string )
|
||||
|
|
@ -70,23 +77,18 @@ DEFER: http-get-stream
|
|||
|
||||
: download-to ( url file -- )
|
||||
#! Downloads the contents of a URL to a file.
|
||||
>r http-get-stream check-response
|
||||
r> binary <file-writer> stream-copy ;
|
||||
swap http-get-stream check-response
|
||||
[ swap binary <file-writer> stream-copy ] with-disposal ;
|
||||
|
||||
: download ( url -- )
|
||||
dup download-name download-to ;
|
||||
|
||||
: post-request ( content-type content host resource -- )
|
||||
#! Note: It is up to the caller to url encode the content if
|
||||
#! it is required according to the content-type.
|
||||
"POST" http-request [
|
||||
"Content-Length: " write length number>string write crlf
|
||||
"Content-Type: " write url-encode write crlf
|
||||
crlf
|
||||
] keep write ;
|
||||
: <post-request> ( content-type content -- request )
|
||||
<request>
|
||||
"POST" >>method
|
||||
swap >>post-data
|
||||
swap >>post-data-type ;
|
||||
|
||||
: http-post ( content-type content url -- code headers string )
|
||||
#! Make a POST request. The content is URL encoded for you.
|
||||
parse-url over parse-host <inet> <client> [
|
||||
post-request flush read-response stdio get contents
|
||||
] with-stream ;
|
||||
: http-post ( content-type content url -- response string )
|
||||
#! The content is URL encoded for you.
|
||||
-rot url-encode <post-request> http-request contents ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
[ "hello%20world" ] [ "hello world" url-encode ] unit-test
|
||||
|
|
@ -16,3 +17,113 @@ IN: http.tests
|
|||
[ "%20%21%20" ] [ " ! " url-encode ] 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.
|
||||
USING: hashtables io kernel math namespaces math.parser assocs
|
||||
sequences strings splitting ascii io.encodings.utf8 assocs.lib
|
||||
namespaces unicode.case ;
|
||||
USING: hashtables io io.streams.string kernel math namespaces
|
||||
math.parser assocs sequences strings splitting ascii
|
||||
io.encodings.utf8 namespaces unicode.case combinators
|
||||
vectors sorting new-slots accessors calendar calendar.format
|
||||
quotations arrays ;
|
||||
IN: http
|
||||
|
||||
: header-line ( line -- )
|
||||
": " 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 ;
|
||||
: http-port 80 ; inline
|
||||
|
||||
: url-quotable? ( ch -- ? )
|
||||
#! In a URL, can this character be used without
|
||||
|
|
@ -23,7 +17,7 @@ IN: http
|
|||
over digit? or
|
||||
swap "/_-." member? or ; foldable
|
||||
|
||||
: push-utf8 ( string -- )
|
||||
: push-utf8 ( ch -- )
|
||||
1string encode-utf8 [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ;
|
||||
|
||||
: url-encode ( str -- str )
|
||||
|
|
@ -58,17 +52,375 @@ IN: http
|
|||
: url-decode ( str -- str )
|
||||
[ 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
|
||||
"&" 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 %
|
||||
dup assoc-empty? [
|
||||
2drop
|
||||
] [
|
||||
CHAR: ? rot member? "&" "?" ? %
|
||||
hash>query %
|
||||
] if
|
||||
] "" make ;
|
||||
f swap
|
||||
|
||||
";" split [
|
||||
[ blank? ] trim "=" split1 swap >lower {
|
||||
{ "expires" [ >>expires ] }
|
||||
{ "domain" [ >>domain ] }
|
||||
{ "path" [ >>path ] }
|
||||
{ "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" }
|
||||
|
||||
{ "factor" "text/plain" }
|
||||
{ "cgi" "application/x-cgi-script" }
|
||||
{ "fhtml" "application/x-factor-server-page" }
|
||||
} "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
|
||||
http.server namespaces io tools.test strings io.server
|
||||
logging ;
|
||||
USING: http.server tools.test kernel namespaces accessors
|
||||
new-slots io http math sequences assocs ;
|
||||
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" ]
|
||||
[ "http://www.jedit.org/index.html" url>path ] unit-test
|
||||
M: mock-responder call-responder
|
||||
2nip
|
||||
path>> on
|
||||
"text/plain" <content> ;
|
||||
|
||||
[ "foo/bar" ]
|
||||
[ "http://www.jedit.org/foo/bar" url>path ] unit-test
|
||||
: check-dispatch ( tag path -- ? )
|
||||
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
|
||||
|
||||
[ "" ]
|
||||
[ "http://www.jedit.org" url>path ] unit-test
|
||||
[ "foo" ] [
|
||||
"foo" default-host get find-responder path>> nip
|
||||
] unit-test
|
||||
|
||||
[ "foobar" ]
|
||||
[ "foobar" secure-path ] unit-test
|
||||
[ "bar" ] [
|
||||
"bar" default-host get find-responder path>> nip
|
||||
] unit-test
|
||||
|
||||
[ f ]
|
||||
[ "foobar/../baz" secure-path ] unit-test
|
||||
[ t ] [ "foo" "foo" check-dispatch ] 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
|
||||
[ ] [ f [ "POO" parse-request ] with-logging ] unit-test
|
||||
[ t ] [
|
||||
<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" } } ]
|
||||
[ "Foo=Bar&Baz=Quux" query>hash ] unit-test
|
||||
|
||||
[ H{ { "Baz" " " } } ]
|
||||
[ "Baz=%20" query>hash ] unit-test
|
||||
|
||||
[ H{ { "Foo" f } } ] [ "Foo" query>hash ] unit-test
|
||||
[ "/default" ] [ "/default" default-host get find-responder drop ] unit-test
|
||||
] with-scope
|
||||
|
|
|
|||
|
|
@ -1,65 +1,171 @@
|
|||
! Copyright (C) 2003, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs kernel namespaces io io.timeouts strings splitting
|
||||
threads http http.server.responders sequences prettyprint
|
||||
io.server logging calendar io.encodings.latin1 ;
|
||||
|
||||
threads http sequences prettyprint io.server logging calendar
|
||||
new-slots html.elements accessors math.parser combinators.lib
|
||||
vocabs.loader debugger html continuations random combinators
|
||||
io.encodings.latin1 ;
|
||||
IN: http.server
|
||||
|
||||
: (url>path) ( uri -- path )
|
||||
url-decode "http://" ?head [
|
||||
"/" split1 dup "" ? nip
|
||||
] when ;
|
||||
GENERIC: call-responder ( request path responder -- response )
|
||||
|
||||
: url>path ( uri -- path )
|
||||
"?" split1 dup [
|
||||
>r (url>path) "?" r> 3append
|
||||
] [
|
||||
drop (url>path)
|
||||
] if ;
|
||||
TUPLE: trivial-responder response ;
|
||||
|
||||
: secure-path ( path -- path )
|
||||
".." over subseq? [ drop f ] when ;
|
||||
C: <trivial-responder> trivial-responder
|
||||
|
||||
: request-method ( cmd -- method )
|
||||
H{
|
||||
{ "GET" "get" }
|
||||
{ "POST" "post" }
|
||||
{ "HEAD" "head" }
|
||||
} at "bad" or ;
|
||||
M: trivial-responder call-responder nip response>> call ;
|
||||
|
||||
: (handle-request) ( arg cmd -- method path host )
|
||||
request-method dup "method" set swap
|
||||
prepare-url prepare-header host ;
|
||||
: trivial-response-body ( code message -- )
|
||||
<html>
|
||||
<body>
|
||||
<h1> swap number>string write bl write </h1>
|
||||
</body>
|
||||
</html> ;
|
||||
|
||||
: handle-request ( arg cmd -- )
|
||||
[ (handle-request) serve-responder ] with-scope ;
|
||||
: <trivial-response> ( code message -- response )
|
||||
<response>
|
||||
2over [ trivial-response-body ] 2curry >>body
|
||||
"text/html" set-content-type
|
||||
swap >>message
|
||||
swap >>code ;
|
||||
|
||||
: parse-request ( request -- )
|
||||
" " split1 dup [
|
||||
" HTTP" split1 drop url>path secure-path dup [
|
||||
swap handle-request
|
||||
: <400> ( -- response )
|
||||
400 "Bad request" <trivial-response> ;
|
||||
|
||||
: <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
|
||||
] if
|
||||
default>> [
|
||||
call-responder
|
||||
] [
|
||||
3drop f
|
||||
] if*
|
||||
] if*
|
||||
] [
|
||||
2drop bad-request
|
||||
2drop redirect-with-/
|
||||
] 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 -- )
|
||||
internet-server "http.server" latin1 [
|
||||
1 minutes stdio get set-timeout
|
||||
readln [ parse-request ] when*
|
||||
] with-server ;
|
||||
internet-server "http.server"
|
||||
latin1 [ handle-client ] with-server ;
|
||||
|
||||
: httpd-main ( -- ) 8888 httpd ;
|
||||
|
||||
MAIN: httpd-main
|
||||
|
||||
! Load default webapps
|
||||
USE: webapps.file
|
||||
USE: webapps.callback
|
||||
USE: webapps.continuation
|
||||
USE: webapps.cgi
|
||||
: generate-key ( assoc -- str )
|
||||
4 big-random >hex dup pick key?
|
||||
[ drop generate-key ] [ nip ] if ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
io.files io.streams.string html html.elements
|
||||
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
|
||||
|
||||
|
|
@ -93,3 +94,13 @@ DEFER: <% delimiter
|
|||
|
||||
: template-convert ( infile outfile -- )
|
||||
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
|
||||
"lambda" word-prop lambda-body ;
|
||||
|
||||
: method-stack-effect
|
||||
: method-stack-effect ( method -- effect )
|
||||
dup "lambda" word-prop lambda-vars
|
||||
swap "method-generic" word-prop stack-effect
|
||||
dup [ effect-out ] when
|
||||
<effect> ;
|
||||
|
||||
M: lambda-method synopsis*
|
||||
dup dup definer.
|
||||
dup dup dup definer.
|
||||
"method-specializer" word-prop pprint*
|
||||
"method-generic" word-prop pprint*
|
||||
method-stack-effect effect>string comment. ;
|
||||
|
|
|
|||
|
|
@ -8,5 +8,5 @@ M: integer foo + ;
|
|||
|
||||
"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
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
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
|
||||
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