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.factor
db4
Daniel Ehrenberg 2008-03-05 17:04:43 -06:00
commit 5805db7ac4
48 changed files with 1407 additions and 858 deletions

View File

@ -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

View File

@ -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 -- )

View File

@ -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
[ ] [

View File

@ -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 ;

View File

@ -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 )

View File

@ -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

View File

@ -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 ) ;

View File

@ -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 )

View File

@ -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 ;

View File

@ -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:

View File

@ -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/" %

View File

@ -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 -- )

View File

@ -1 +0,0 @@
Chris Double

View File

@ -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" }

View File

@ -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

View File

@ -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 ;

View File

@ -1 +0,0 @@
HTTP Basic Authentication implementation

View File

@ -1 +0,0 @@
web

View File

@ -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

View File

@ -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 ;

113
extra/http/http-tests.factor Normal file → Executable file
View File

@ -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

View File

@ -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 ;

1
extra/http/mime/mime.factor Normal file → Executable file
View File

@ -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

View File

@ -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

View File

@ -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 ;

View File

@ -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 ;

View File

@ -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 ;

View File

@ -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 ;

14
extra/http/server/db/db.factor Executable file
View File

@ -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 ;

View File

@ -1 +0,0 @@
Slava Pestov

View File

@ -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

View File

@ -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

View File

@ -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 ;

View File

@ -0,0 +1 @@
Doug Coleman

View File

@ -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

View File

@ -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* ;

View File

@ -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 ;

View File

@ -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 ;

View File

@ -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. ;

View File

@ -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

View File

@ -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 [

View File

@ -1 +0,0 @@
Slava Pestov

View File

@ -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

View File

@ -1 +0,0 @@
Slava Pestov

View File

@ -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

View File

@ -1 +0,0 @@
Slava Pestov

View File

@ -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

View File

@ -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> ;