steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Oops

db4
Slava Pestov 2008-02-29 19:11:26 -06:00
parent 373a88a77a
commit 85ab4c3b5d
32 changed files with 0 additions and 1083 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
extra/http.good/authors.txt
View File

@ -1 +0,0 @@
Slava Pestov

1
extra/http.good/basic-authentication/authors.txt
View File

@ -1 +0,0 @@
Chris Double

69
extra/http.good/basic-authentication/basic-authentication-docs.factor
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" }

66
extra/http.good/basic-authentication/basic-authentication-tests.factor
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

65
extra/http.good/basic-authentication/basic-authentication.factor
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 ;

1
extra/http.good/basic-authentication/summary.txt
View File

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

1
extra/http.good/basic-authentication/tags.txt
View File

@ -1 +0,0 @@
web

1
extra/http.good/client/authors.txt
View File

@ -1 +0,0 @@
Slava Pestov

26
extra/http.good/client/client-tests.factor
View File

@ -1,26 +0,0 @@
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
[ "/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
}
] [
[
"http://www.apple.com/index.html"
<get-request>
request-with-url
] with-scope
] unit-test

96
extra/http.good/client/client.factor
View File

@ -1,96 +0,0 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! 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 continuations assocs.lib calendar vectors hashtables
accessors ;
IN: http.client
: parse-url ( url -- resource host port )
"http://" ?head [ "Only http:// supported" throw ] unless
"/" split1 [ "/" swap append ] [ "/" ] if*
swap parse-host ;
<PRIVATE
: store-path ( request path -- request )
"?" split1 >r >>path r> dup [ query>assoc ] when >>query ;
! 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 ;
DEFER: (http-request)
: absolute-redirect ( url -- request )
"request" get request-with-url ;
: relative-redirect ( path -- request )
"request" get swap store-path ;
: do-redirect ( response -- response stream )
dup response-code 300 399 between? [
header>> "location" peek-at
dup "http://" head? [
absolute-redirect
] [
relative-redirect
] if "GET" >>method (http-request)
] [
stdio get
] if ;
: (http-request) ( request -- response stream )
dup host>> over port>> <inet> <client> stdio set
write-request flush read-response
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 construct-empty
"GET" >>method ;
: http-get-stream ( url -- response stream )
<get-request> http-request ;
: success? ( code -- ? ) 200 = ;
: check-response ( response stream -- stream )
swap code>> success?
[ dispose "HTTP download failed" throw ] unless ;
: http-get ( url -- string )
http-get-stream check-response contents ;
: download-name ( url -- name )
file-name "?" split1 drop "/" ?tail drop ;
: download-to ( url file -- )
#! Downloads the contents of a URL to a file.
swap http-get-stream check-response
[ swap <file-writer> stream-copy ] with-disposal ;
: download ( url -- )
dup download-name download-to ;
: <post-request> ( content-type content -- request )
request construct-empty
"POST" >>method
swap >>post-data
swap >>post-data-type ;
: http-post ( content-type content url -- response string )
#! The content is URL encoded for you.
-rot url-encode <post-request> http-request contents ;

1
extra/http.good/client/summary.txt
View File

@ -1 +0,0 @@
HTTP client

2
extra/http.good/client/tags.txt
View File

@ -1,2 +0,0 @@
web
network

115
extra/http.good/http-tests.factor
View File

@ -1,115 +0,0 @@
USING: http tools.test multiline tuple-syntax
io.streams.string kernel arrays splitting sequences ;
IN: temporary
[ "hello%20world" ] [ "hello world" url-encode ] unit-test
[ "hello world" ] [ "hello%20world" url-decode ] unit-test
[ "~hello world" ] [ "%7ehello+world" url-decode ] unit-test
[ "" ] [ "%XX%XX%XX" url-decode ] unit-test
[ "" ] [ "%XX%XX%X" url-decode ] unit-test
[ "hello world" ] [ "hello+world" url-decode ] unit-test
[ "hello world" ] [ "hello%20world" url-decode ] unit-test
[ " ! " ] [ "%20%21%20" url-decode ] unit-test
[ "hello world" ] [ "hello world%" url-decode ] unit-test
[ "hello world" ] [ "hello world%x" url-decode ] unit-test
[ "hello%20world" ] [ "hello world" url-encode ] unit-test
[ "%20%21%20" ] [ " ! " url-encode ] unit-test
[ "\u001234hi\u002045" ] [ "\u001234hi\u002045" url-encode url-decode ] 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
method: "GET"
path: "bar"
query: f
version: "1.1"
header: H{ { "some-header" V{ "1" "2" } } { "content-length" V{ "4" } } }
post-data: "blah"
}
] [
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
some-header: 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.0
Host: www.sex.com
;
[
TUPLE{ request
method: "HEAD"
path: "bar"
query: f
version: "1.0"
header: H{ { "host" V{ "www.sex.com" } } }
host: "www.sex.com"
}
] [
read-request-test-2 [
read-request
] with-string-reader
] unit-test
STRING: read-response-test-1
HTTP/1.0 404 not found
Content-Type: text/html
blah
;
[
TUPLE{ response
version: "1.0"
code: 404
message: "not found"
header: H{ { "content-type" V{ "text/html" } } }
}
] [
read-response-test-1
[ read-response ] with-string-reader
] unit-test
STRING: read-response-test-1'
HTTP/1.0 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

277
extra/http.good/http.factor
View File

@ -1,277 +0,0 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: hashtables io io.streams.string kernel math namespaces
math.parser assocs sequences strings splitting ascii
io.encodings.utf8 assocs.lib namespaces unicode.case combinators
vectors sorting new-slots accessors calendar ;
IN: http
: http-port 80 ; inline
: crlf "\r\n" write ;
: header-line ( line -- )
": " split1 dup [ swap >lower insert ] [ 2drop ] if ;
: read-header-line ( -- )
readln dup
empty? [ drop ] [ header-line read-header-line ] if ;
: read-header ( -- multi-assoc )
[ read-header-line ] H{ } make-assoc ;
: write-header ( multi-assoc -- )
>alist sort-keys
[
swap write ": " write {
{ [ dup number? ] [ number>string ] }
{ [ dup timestamp? ] [ timestamp>http-string ] }
{ [ dup string? ] [ ] }
} cond write crlf
] multi-assoc-each crlf ;
: url-quotable? ( ch -- ? )
#! In a URL, can this character be used without
#! URL-encoding?
dup letter?
over LETTER? or
over digit? or
swap "/_-." member? or ; foldable
: push-utf8 ( ch -- )
1string encode-utf8 [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ;
: url-encode ( str -- str )
[ [
dup url-quotable? [ , ] [ push-utf8 ] if
] each ] "" make ;
: url-decode-hex ( index str -- )
2dup length 2 - >= [
2drop
] [
>r 1+ dup 2 + r> subseq hex> [ , ] when*
] if ;
: url-decode-% ( index str -- index str )
2dup url-decode-hex >r 3 + r> ;
: url-decode-+-or-other ( index str ch -- index str )
dup CHAR: + = [ drop CHAR: \s ] when , >r 1+ r> ;
: url-decode-iter ( index str -- )
2dup length >= [
2drop
] [
2dup nth dup CHAR: % = [
drop url-decode-%
] [
url-decode-+-or-other
] if url-decode-iter
] if ;
: url-decode ( str -- str )
[ 0 swap url-decode-iter ] "" make decode-utf8 ;
: 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 ;
TUPLE: request
host
port
method
path
query
version
header
post-data
post-data-type ;
: <request>
request construct-empty
"1.0" >>version
http-port >>port ;
: url>path ( url -- path )
url-decode "http://" ?head
[ "/" split1 "" or nip ] [ "/" ?head drop ] if ;
: 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 ;
SYMBOL: max-post-request
1024 256 * max-post-request set-global
: content-length ( header -- n )
"content-length" peek-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 header>> "host" peek-at parse-host >r >>host r> >>port ;
: extract-post-data-type ( request -- request )
dup header>> "content-type" peek-at >>post-data-type ;
: read-request ( -- request )
<request>
read-method
read-url
read-request-version
read-request-header
read-post-data
extract-host
extract-post-data-type ;
: 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" replace-at ] when*
over post-data>> [ length "content-length" replace-at ] when*
over post-data-type>> [ "content-type" replace-at ] when*
write-header ;
: write-post-data ( request -- request )
dup post-data>> [ write ] when* ;
: write-request ( request -- )
write-method
write-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
"/" write
write-url
drop
] with-string-writer ;
TUPLE: response
version
code
message
header ;
: <response>
response construct-empty
"1.0" >>version
H{ } clone >>header ;
: read-response-version
" " read-until
[ "Bad response: version" throw ] unless
parse-version
>>version ;
: read-response-code
" " 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 ;
: 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>> write-header ;
: write-response ( respose -- )
write-response-version
write-response-code
write-response-message
write-response-header
flush
drop ;
: set-response-header ( response value key -- response )
pick header>> -rot replace-at drop ;
: set-content-type ( response content-type -- response )
"content-type" set-response-header ;

1
extra/http.good/mime/authors.txt
View File

@ -1 +0,0 @@
Slava Pestov

34
extra/http.good/mime/mime.factor
View File

@ -1,34 +0,0 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io assocs kernel sequences math namespaces splitting ;
IN: http.mime
: file-extension ( filename -- extension )
"." split dup length 1 <= [ drop f ] [ peek ] if ;
: mime-type ( filename -- mime-type )
file-extension "mime-types" get at "application/octet-stream" or ;
H{
{ "html" "text/html" }
{ "txt" "text/plain" }
{ "xml" "text/xml" }
{ "css" "text/css" }
{ "gif" "image/gif" }
{ "png" "image/png" }
{ "jpg" "image/jpeg" }
{ "jpeg" "image/jpeg" }
{ "jar" "application/octet-stream" }
{ "zip" "application/octet-stream" }
{ "tgz" "application/octet-stream" }
{ "tar.gz" "application/octet-stream" }
{ "gz" "application/octet-stream" }
{ "pdf" "application/pdf" }
{ "factor" "text/plain" }
{ "fhtml" "application/x-factor-server-page" }
} "mime-types" set-global

1
extra/http.good/server/authors.txt
View File

@ -1 +0,0 @@
Slava Pestov

45
extra/http.good/server/server-tests.factor
View File

@ -1,45 +0,0 @@
USING: http.server tools.test kernel namespaces accessors
new-slots assocs.lib io http math sequences ;
IN: temporary
TUPLE: mock-responder ;
: <mock-responder> ( path -- responder )
<responder> mock-responder construct-delegate ;
M: mock-responder do-responder
2nip
path>> on
[ "Hello world" print ]
"text/plain" <content> ;
: check-dispatch ( tag path -- ? )
over off
<request> swap default-host get call-responder
write-response call get ;
[
"" <dispatcher>
"foo" <mock-responder> add-responder
"bar" <mock-responder> add-responder
"baz/" <dispatcher>
"123" <mock-responder> add-responder
"default" <mock-responder> >>default
add-responder
default-host set
[ 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 ] [ "123" "baz/123" check-dispatch ] unit-test
[ t ] [
<request>
"baz" >>path
"baz" default-host get call-responder
dup code>> 300 399 between? >r
header>> "location" peek-at "baz/" tail? r> and
nip
] unit-test
] with-scope

131
extra/http.good/server/server.factor
View File

@ -1,131 +0,0 @@
! 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 sequences prettyprint io.server logging calendar
new-slots html.elements accessors math.parser combinators.lib ;
IN: http.server
TUPLE: responder path directory ;
: <responder> ( path -- responder )
"/" ?tail responder construct-boa ;
GENERIC: do-responder ( request path responder -- quot response )
TUPLE: trivial-responder quot response ;
: <trivial-responder> ( quot response -- responder )
trivial-responder construct-boa
"" <responder> over set-delegate ;
M: trivial-responder do-responder
2nip dup quot>> swap response>> ;
: trivial-response-body ( code message -- )
<html>
<body>
<h1> swap number>string write bl write </h1>
</body>
</html> ;
: <trivial-response> ( code message -- quot response )
[ [ trivial-response-body ] 2curry ] 2keep <response>
"text/html" set-content-type
swap >>message
swap >>code ;
: <404> ( -- quot response )
404 "Not Found" <trivial-response> ;
: <redirect> ( to code message -- quot response )
<trivial-response>
rot "location" set-response-header ;
: <permanent-redirect> ( to -- quot response )
301 "Moved Permanently" <redirect> ;
: <temporary-redirect> ( to -- quot response )
307 "Temporary Redirect" <redirect> ;
: <content> ( content-type -- response )
<response>
200 >>code
swap set-content-type ;
TUPLE: dispatcher responders default ;
: responder-matches? ( path responder -- ? )
path>> head? ;
TUPLE: no-/-responder ;
M: no-/-responder do-responder
2drop
dup path>> "/" append >>path
request-url <permanent-redirect> ;
: <no-/-responder> ( -- responder )
"" <responder> no-/-responder construct-delegate ;
<no-/-responder> no-/-responder set-global
: find-responder ( path dispatcher -- path responder )
>r "/" ?head drop r>
[ responders>> [ dupd responder-matches? ] find nip ] keep
default>> or [ path>> ?head drop ] keep ;
: no-trailing-/ ( path responder -- path responder )
over empty? over directory>> and
[ drop no-/-responder get-global ] when ;
: call-responder ( request path responder -- quot response )
no-trailing-/ do-responder ;
SYMBOL: 404-responder
<404> <trivial-responder> 404-responder set-global
M: dispatcher do-responder
find-responder call-responder ;
: <dispatcher> ( path -- dispatcher )
<responder>
dispatcher construct-delegate
404-responder get-global >>default
V{ } clone >>responders ;
: add-responder ( dispatcher responder -- dispatcher )
over responders>> push ;
SYMBOL: virtual-hosts
SYMBOL: default-host
virtual-hosts global [ drop H{ } clone ] cache drop
default-host global [ drop 404-responder ] cache drop
: find-virtual-host ( host -- responder )
virtual-hosts get at [ default-host get ] unless* ;
: handle-request ( request -- )
[
dup path>> over host>> find-virtual-host
call-responder
write-response
] keep method>> "HEAD" = [ drop ] [ call ] if ;
: default-timeout 1 minutes stdio get set-timeout ;
LOG: httpd-hit NOTICE
: log-request ( request -- )
{ method>> host>> path>> } map-exec-with httpd-hit ;
: httpd ( port -- )
internet-server "http.server" [
default-timeout
read-request dup log-request handle-request
] with-server ;
: httpd-main ( -- ) 8888 httpd ;
MAIN: httpd-main

1
extra/http.good/server/summary.txt
View File

@ -1 +0,0 @@
HTTP server

3
extra/http.good/server/tags.txt
View File

@ -1,3 +0,0 @@
enterprise
network
web

2
extra/http.good/server/templating/authors.txt
View File

@ -1,2 +0,0 @@
Slava Pestov
Matthew Willis

17
extra/http.good/server/templating/templating-tests.factor
View File

@ -1,17 +0,0 @@
USING: io io.files io.streams.string http.server.templating kernel tools.test
sequences ;
IN: temporary
: test-template ( path -- ? )
"extra/http/server/templating/test/" swap append
[
".fhtml" append resource-path
[ run-template-file ] with-string-writer
] keep
".html" append resource-path file-contents = ;
[ t ] [ "example" test-template ] unit-test
[ t ] [ "bug" test-template ] unit-test
[ t ] [ "stack" test-template ] unit-test
[ ] [ "<%\n%>" parse-template drop ] unit-test

96
extra/http.good/server/templating/templating.factor
View File

@ -1,96 +0,0 @@
! Copyright (C) 2005 Alex Chapman
! Copyright (C) 2006, 2007 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: continuations sequences kernel parser namespaces io
io.files io.streams.lines io.streams.string html html.elements
source-files debugger combinators math quotations generic
strings splitting ;
IN: http.server.templating
: templating-vocab ( -- vocab-name ) "http.server.templating" ;
! See apps/http-server/test/ or libs/furnace/ for template usage
! examples
! We use a custom lexer so that %> ends a token even if not
! followed by whitespace
TUPLE: template-lexer ;
: <template-lexer> ( lines -- lexer )
<lexer> template-lexer construct-delegate ;
M: template-lexer skip-word
[
{
{ [ 2dup nth CHAR: " = ] [ drop 1+ ] }
{ [ 2dup swap tail-slice "%>" head? ] [ drop 2 + ] }
{ [ t ] [ f skip ] }
} cond
] change-column ;
DEFER: <% delimiter
: check-<% ( lexer -- col )
"<%" over lexer-line-text rot lexer-column start* ;
: found-<% ( accum lexer col -- accum )
[
over lexer-line-text
>r >r lexer-column r> r> subseq parsed
\ write-html parsed
] 2keep 2 + swap set-lexer-column ;
: still-looking ( accum lexer -- accum )
[
dup lexer-line-text swap lexer-column tail
parsed \ print-html parsed
] keep next-line ;
: parse-%> ( accum lexer -- accum )
dup still-parsing? [
dup check-<%
[ found-<% ] [ [ still-looking ] keep parse-%> ] if*
] [
drop
] if ;
: %> lexer get parse-%> ; parsing
: parse-template-lines ( lines -- quot )
<template-lexer> [
V{ } clone lexer get parse-%> f (parse-until)
] with-parser ;
: parse-template ( string -- quot )
[
use [ clone ] change
templating-vocab use+
string-lines parse-template-lines
] with-scope ;
: eval-template ( string -- ) parse-template call ;
: html-error. ( error -- )
<pre> error. </pre> ;
: run-template-file ( filename -- )
[
[
"quiet" on
parser-notes off
templating-vocab use+
dup source-file file set ! so that reload works properly
[
?resource-path file-contents
[ eval-template ] [ html-error. drop ] recover
] keep
] with-file-vocabs
] assert-depth drop ;
: run-relative-template-file ( filename -- )
file get source-file-path parent-directory
swap path+ run-template-file ;
: template-convert ( infile outfile -- )
[ run-template-file ] with-file-writer ;

5
extra/http.good/server/templating/test/bug.fhtml
View File

@ -1,5 +0,0 @@
<%
USING: prettyprint ;
! Hello world
5 pprint
%>

2
extra/http.good/server/templating/test/bug.html
View File

@ -1,2 +0,0 @@
5

8
extra/http.good/server/templating/test/example.fhtml
View File

@ -1,8 +0,0 @@
<% USING: math ; %>
<html>
<head><title>Simple Embedded Factor Example</title></head>
<body>
<% 5 [ %><p>I like repetition</p><% ] times %>
</body>
</html>

9
extra/http.good/server/templating/test/example.html
View File

@ -1,9 +0,0 @@
<html>
<head><title>Simple Embedded Factor Example</title></head>
<body>
<p>I like repetition</p><p>I like repetition</p><p>I like repetition</p><p>I like repetition</p><p>I like repetition</p>
</body>
</html>

1
extra/http.good/server/templating/test/stack.fhtml
View File

@ -1 +0,0 @@
The stack: <% USING: prettyprint ; .s %>

2
extra/http.good/server/templating/test/stack.html
View File

@ -1,2 +0,0 @@
The stack:

1
extra/http.good/summary.txt
View File

@ -1 +0,0 @@
Common code shared by HTTP client and server

2
extra/http.good/tags.txt
View File

@ -1,2 +0,0 @@
web
network