New HTTPD work in progress
Slava Pestov
parent
5e3aa52a75
commit
cc3f226cd3
|
|
@ -1 +0,0 @@
|
|||
Chris Double
|
||||
|
|
@ -1,69 +0,0 @@
|
|||
! Copyright (C) 2007 Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax crypto.sha2 ;
|
||||
IN: http.basic-authentication
|
||||
|
||||
HELP: realms
|
||||
{ $description
|
||||
"A hashtable mapping a basic authentication realm (a string) "
|
||||
"to either a quotation or a hashtable. The quotation has "
|
||||
"stack effect ( username sha-256-string -- bool ). It "
|
||||
"is expected to perform the user authentication when called." $nl
|
||||
"If the realm maps to a hashtable then the hashtable should be a "
|
||||
"mapping of usernames to sha-256 hashed passwords." $nl
|
||||
"If the 'realms' variable does not exist in the current scope then "
|
||||
"authentication will always fail." }
|
||||
{ $see-also add-realm with-basic-authentication } ;
|
||||
|
||||
HELP: add-realm
|
||||
{ $values
|
||||
{ "data" "a quotation or a hashtable" } { "name" "a string" } }
|
||||
{ $description
|
||||
"Adds the authentication data to the " { $link realms } ". 'data' can be "
|
||||
"a quotation with stack effect ( username sha-256-string -- bool ) or "
|
||||
"a hashtable mapping username strings to sha-256-string passwords." }
|
||||
{ $examples
|
||||
{ $code "H{ { \"admin\" \"...\" } { \"user\" \"...\" } } \"my-realm\" add-realm" }
|
||||
{ $code "[ \"...\" = swap \"admin\" = and ] \"my-realm\" add-realm" }
|
||||
}
|
||||
{ $see-also with-basic-authentication realms } ;
|
||||
|
||||
HELP: with-basic-authentication
|
||||
{ $values
|
||||
{ "realm" "a string" } { "quot" "a quotation with stack effect ( -- )" } }
|
||||
{ $description
|
||||
"Checks if the HTTP request has the correct authorisation headers "
|
||||
"for basic authentication within the named realm. If the headers "
|
||||
"are not present then a '401' HTTP response results from the "
|
||||
"request, otherwise the quotation is called." }
|
||||
{ $examples
|
||||
{ $code "\"my-realm\" [\n serving-html \"<html><body>Success!</body></html>\" write\n] with-basic-authentication" } }
|
||||
{ $see-also add-realm realms }
|
||||
;
|
||||
|
||||
ARTICLE: { "http-authentication" "basic-authentication" } "Basic Authentication"
|
||||
"The Basic Authentication system provides a simple browser based "
|
||||
"authentication method to web applications. When the browser requests "
|
||||
"a resource protected with basic authentication the server responds with "
|
||||
"a '401' response code which means the user is unauthorized."
|
||||
$nl
|
||||
"When the browser receives this it prompts the user for a username and "
|
||||
"password. This is sent back to the server in a special HTTP header. The "
|
||||
"server then checks this against its authentication information and either "
|
||||
"accepts or rejects the users request."
|
||||
$nl
|
||||
"Authentication is split up into " { $link realms } ". Each realm can have "
|
||||
"a different database of username and password information. A responder can "
|
||||
"require basic authentication by using the " { $link with-basic-authentication } " word."
|
||||
$nl
|
||||
"Username and password information can be maintained using " { $link realms } " and " { $link add-realm } "."
|
||||
$nl
|
||||
"All passwords on the server should be stored as sha-256 strings generated with the " { $link string>sha-256-string } " word."
|
||||
$nl
|
||||
"Note that Basic Authentication itself is insecure in that it "
|
||||
"sends the username and password as clear text (although it is "
|
||||
"base64 encoded this is not much help). To prevent eavesdropping "
|
||||
"it is best to use Basic Authentication with SSL." ;
|
||||
|
||||
IN: http.basic-authentication
|
||||
ABOUT: { "http-authentication" "basic-authentication" }
|
||||
|
|
@ -1,66 +0,0 @@
|
|||
! Copyright (c) 2007 Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel crypto.sha2 http.basic-authentication tools.test
|
||||
namespaces base64 sequences ;
|
||||
|
||||
{ t } [
|
||||
[
|
||||
H{ } clone realms set
|
||||
H{ { "admin" "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" } } "test-realm" add-realm
|
||||
"test-realm" "Basic " "admin:password" >base64 append authorization-ok?
|
||||
] with-scope
|
||||
] unit-test
|
||||
|
||||
{ f } [
|
||||
[
|
||||
H{ } clone realms set
|
||||
H{ { "admin" "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" } } "test-realm" add-realm
|
||||
"test-realm" "Basic " "admin:passwordx" >base64 append authorization-ok?
|
||||
] with-scope
|
||||
] unit-test
|
||||
|
||||
{ f } [
|
||||
[
|
||||
H{ } clone realms set
|
||||
H{ { "admin" "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" } } "test-realm" add-realm
|
||||
"test-realm" "Basic " "xadmin:password" >base64 append authorization-ok?
|
||||
] with-scope
|
||||
] unit-test
|
||||
|
||||
{ t } [
|
||||
[
|
||||
H{ } clone realms set
|
||||
[ "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" = swap "admin" = and ] "test-realm" add-realm
|
||||
"test-realm" "Basic " "admin:password" >base64 append authorization-ok?
|
||||
] with-scope
|
||||
] unit-test
|
||||
|
||||
{ f } [
|
||||
[
|
||||
H{ } clone realms set
|
||||
[ "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" = swap "admin" = and ] "test-realm" add-realm
|
||||
"test-realm" "Basic " "xadmin:password" >base64 append authorization-ok?
|
||||
] with-scope
|
||||
] unit-test
|
||||
|
||||
{ f } [
|
||||
[
|
||||
H{ } clone realms set
|
||||
[ "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" = swap "admin" = and ] "test-realm" add-realm
|
||||
"test-realm" "Basic " "admin:xpassword" >base64 append authorization-ok?
|
||||
] with-scope
|
||||
] unit-test
|
||||
|
||||
{ f } [
|
||||
[
|
||||
f realms set
|
||||
"test-realm" "Basic " "admin:password" >base64 append authorization-ok?
|
||||
] with-scope
|
||||
] unit-test
|
||||
|
||||
{ f } [
|
||||
[
|
||||
H{ } clone realms set
|
||||
"test-realm" "Basic " "admin:password" >base64 append authorization-ok?
|
||||
] with-scope
|
||||
] unit-test
|
||||
|
|
@ -1,65 +0,0 @@
|
|||
! Copyright (c) 2007 Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel base64 http.server crypto.sha2 namespaces assocs
|
||||
quotations hashtables combinators splitting sequences
|
||||
http.server.responders io html.elements ;
|
||||
IN: http.basic-authentication
|
||||
|
||||
! 'realms' is a hashtable mapping a realm (a string) to
|
||||
! either a quotation or a hashtable. The quotation
|
||||
! has stack effect ( username sha-256-string -- bool ).
|
||||
! It should perform the user authentication. 'sha-256-string'
|
||||
! is the plain text password provided by the user passed through
|
||||
! 'string>sha-256-string'. If 'realms' maps to a hashtable then
|
||||
! it is a mapping of usernames to sha-256 hashed passwords.
|
||||
!
|
||||
! 'realms' can be set on a per vhost basis in the vhosts
|
||||
! table.
|
||||
!
|
||||
! If there are no realms then authentication fails.
|
||||
SYMBOL: realms
|
||||
|
||||
: add-realm ( data name -- )
|
||||
#! Add the named realm to the realms table.
|
||||
#! 'data' should be a hashtable or a quotation.
|
||||
realms get [ H{ } clone dup realms set ] unless*
|
||||
set-at ;
|
||||
|
||||
: user-authorized? ( username password realm -- bool )
|
||||
realms get dup [
|
||||
at {
|
||||
{ [ dup quotation? ] [ call ] }
|
||||
{ [ dup hashtable? ] [ swapd at = ] }
|
||||
{ [ t ] [ 3drop f ] }
|
||||
} cond
|
||||
] [
|
||||
3drop drop f
|
||||
] if ;
|
||||
|
||||
: authorization-ok? ( realm header -- bool )
|
||||
#! Given the realm and the 'Authorization' header,
|
||||
#! authenticate the user.
|
||||
dup [
|
||||
" " split dup first "Basic" = [
|
||||
second base64> ":" split first2 string>sha-256-string rot
|
||||
user-authorized?
|
||||
] [
|
||||
2drop f
|
||||
] if
|
||||
] [
|
||||
2drop f
|
||||
] if ;
|
||||
|
||||
: authentication-error ( realm -- )
|
||||
"401 Unauthorized" response
|
||||
"Basic realm=\"" swap "\"" 3append "WWW-Authenticate" associate print-header
|
||||
<html> <body>
|
||||
"Username or Password is invalid" write
|
||||
</body> </html> ;
|
||||
|
||||
: with-basic-authentication ( realm quot -- )
|
||||
#! Check if the user is authenticated in the given realm
|
||||
#! to run the specified quotation. If not, use Basic
|
||||
#! Authentication to ask for authorization details.
|
||||
over "authorization" header-param authorization-ok?
|
||||
[ nip call ] [ drop authentication-error ] if ;
|
||||
|
|
@ -1 +0,0 @@
|
|||
HTTP Basic Authentication implementation
|
||||
|
|
@ -1 +0,0 @@
|
|||
web
|
||||
|
|
@ -16,6 +16,8 @@ tuple-syntax namespaces ;
|
|||
host: "www.apple.com"
|
||||
path: "/index.html"
|
||||
port: 80
|
||||
version: "1.1"
|
||||
cookies: V{ }
|
||||
}
|
||||
] [
|
||||
[
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! 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
|
||||
splitting continuations calendar vectors hashtables
|
||||
accessors ;
|
||||
IN: http.client
|
||||
|
||||
|
|
@ -32,7 +32,7 @@ DEFER: (http-request)
|
|||
|
||||
: do-redirect ( response -- response stream )
|
||||
dup response-code 300 399 between? [
|
||||
header>> "location" peek-at
|
||||
header>> "location" swap at
|
||||
dup "http://" head? [
|
||||
absolute-redirect
|
||||
] [
|
||||
|
|
@ -44,7 +44,7 @@ DEFER: (http-request)
|
|||
|
||||
: (http-request) ( request -- response stream )
|
||||
dup host>> over port>> <inet> <client> stdio set
|
||||
write-request flush read-response
|
||||
dup "r" set-global write-request flush read-response
|
||||
do-redirect ;
|
||||
|
||||
PRIVATE>
|
||||
|
|
@ -59,8 +59,7 @@ PRIVATE>
|
|||
] with-scope ;
|
||||
|
||||
: <get-request> ( -- request )
|
||||
request construct-empty
|
||||
"GET" >>method ;
|
||||
<request> "GET" >>method ;
|
||||
|
||||
: http-get-stream ( url -- response stream )
|
||||
<get-request> http-request ;
|
||||
|
|
@ -86,7 +85,7 @@ PRIVATE>
|
|||
dup download-name download-to ;
|
||||
|
||||
: <post-request> ( content-type content -- request )
|
||||
request construct-empty
|
||||
<request>
|
||||
"POST" >>method
|
||||
swap >>post-data
|
||||
swap >>post-data-type ;
|
||||
|
|
|
|||
|
|
@ -29,12 +29,14 @@ blah
|
|||
|
||||
[
|
||||
TUPLE{ request
|
||||
port: 80
|
||||
method: "GET"
|
||||
path: "bar"
|
||||
query: f
|
||||
query: H{ }
|
||||
version: "1.1"
|
||||
header: H{ { "some-header" V{ "1" "2" } } { "content-length" V{ "4" } } }
|
||||
header: H{ { "some-header" "1; 2" } { "content-length" "4" } }
|
||||
post-data: "blah"
|
||||
cookies: V{ }
|
||||
}
|
||||
] [
|
||||
read-request-test-1 [
|
||||
|
|
@ -45,8 +47,7 @@ blah
|
|||
STRING: read-request-test-1'
|
||||
GET bar HTTP/1.1
|
||||
content-length: 4
|
||||
some-header: 1
|
||||
some-header: 2
|
||||
some-header: 1; 2
|
||||
|
||||
blah
|
||||
;
|
||||
|
|
@ -60,18 +61,20 @@ read-request-test-1' 1array [
|
|||
] unit-test
|
||||
|
||||
STRING: read-request-test-2
|
||||
HEAD http://foo/bar HTTP/1.0
|
||||
HEAD http://foo/bar HTTP/1.1
|
||||
Host: www.sex.com
|
||||
;
|
||||
|
||||
[
|
||||
TUPLE{ request
|
||||
port: 80
|
||||
method: "HEAD"
|
||||
path: "bar"
|
||||
query: f
|
||||
version: "1.0"
|
||||
header: H{ { "host" V{ "www.sex.com" } } }
|
||||
query: H{ }
|
||||
version: "1.1"
|
||||
header: H{ { "host" "www.sex.com" } }
|
||||
host: "www.sex.com"
|
||||
cookies: V{ }
|
||||
}
|
||||
] [
|
||||
read-request-test-2 [
|
||||
|
|
@ -80,7 +83,7 @@ Host: www.sex.com
|
|||
] unit-test
|
||||
|
||||
STRING: read-response-test-1
|
||||
HTTP/1.0 404 not found
|
||||
HTTP/1.1 404 not found
|
||||
Content-Type: text/html
|
||||
|
||||
blah
|
||||
|
|
@ -88,10 +91,11 @@ blah
|
|||
|
||||
[
|
||||
TUPLE{ response
|
||||
version: "1.0"
|
||||
version: "1.1"
|
||||
code: 404
|
||||
message: "not found"
|
||||
header: H{ { "content-type" V{ "text/html" } } }
|
||||
header: H{ { "content-type" "text/html" } }
|
||||
cookies: V{ }
|
||||
}
|
||||
] [
|
||||
read-response-test-1
|
||||
|
|
@ -100,7 +104,7 @@ blah
|
|||
|
||||
|
||||
STRING: read-response-test-1'
|
||||
HTTP/1.0 404 not found
|
||||
HTTP/1.1 404 not found
|
||||
content-type: text/html
|
||||
|
||||
|
||||
|
|
@ -113,3 +117,8 @@ read-response-test-1' 1array [
|
|||
! 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
|
||||
|
|
|
|||
|
|
@ -2,34 +2,13 @@
|
|||
! 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 ;
|
||||
io.encodings.utf8 namespaces unicode.case combinators
|
||||
vectors sorting new-slots accessors calendar calendar.format
|
||||
quotations arrays ;
|
||||
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?
|
||||
|
|
@ -73,6 +52,54 @@ IN: http
|
|||
: url-decode ( str -- str )
|
||||
[ 0 swap url-decode-iter ] "" make decode-utf8 ;
|
||||
|
||||
: 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 [
|
||||
|
|
@ -84,6 +111,50 @@ IN: http
|
|||
[ [ url-encode ] 2apply "=" swap 3append ] { } assoc>map
|
||||
"&" join ;
|
||||
|
||||
TUPLE: cookie name value path domain expires http-only ;
|
||||
|
||||
: <cookie> ( value name -- cookie )
|
||||
cookie construct-empty
|
||||
swap >>name swap >>value ;
|
||||
|
||||
: parse-cookies ( string -- seq )
|
||||
[
|
||||
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
|
||||
|
|
@ -93,12 +164,21 @@ query
|
|||
version
|
||||
header
|
||||
post-data
|
||||
post-data-type ;
|
||||
post-data-type
|
||||
cookies ;
|
||||
|
||||
: <request>
|
||||
request construct-empty
|
||||
"1.0" >>version
|
||||
http-port >>port ;
|
||||
"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 ;
|
||||
|
||||
: url>path ( url -- path )
|
||||
url-decode "http://" ?head
|
||||
|
|
@ -132,12 +212,15 @@ post-data-type ;
|
|||
: 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" peek-at string>number dup [
|
||||
"content-length" swap at string>number dup [
|
||||
dup max-post-request get > [
|
||||
"content-length > max-post-request" throw
|
||||
] when
|
||||
|
|
@ -151,10 +234,13 @@ SYMBOL: max-post-request
|
|||
[ string>number ] [ http-port ] if* ;
|
||||
|
||||
: extract-host ( request -- request )
|
||||
dup header>> "host" peek-at parse-host >r >>host r> >>port ;
|
||||
dup "host" header parse-host >r >>host r> >>port ;
|
||||
|
||||
: extract-post-data-type ( request -- request )
|
||||
dup header>> "content-type" peek-at >>post-data-type ;
|
||||
dup "content-type" header >>post-data-type ;
|
||||
|
||||
: extract-cookies ( request -- request )
|
||||
dup "cookie" header [ parse-cookies >>cookies ] when* ;
|
||||
|
||||
: read-request ( -- request )
|
||||
<request>
|
||||
|
|
@ -164,7 +250,8 @@ SYMBOL: max-post-request
|
|||
read-request-header
|
||||
read-post-data
|
||||
extract-host
|
||||
extract-post-data-type ;
|
||||
extract-post-data-type
|
||||
extract-cookies ;
|
||||
|
||||
: write-method ( request -- request )
|
||||
dup method>> write bl ;
|
||||
|
|
@ -184,9 +271,10 @@ SYMBOL: max-post-request
|
|||
|
||||
: 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*
|
||||
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 )
|
||||
|
|
@ -194,7 +282,7 @@ SYMBOL: max-post-request
|
|||
|
||||
: write-request ( request -- )
|
||||
write-method
|
||||
write-url
|
||||
write-request-url
|
||||
write-version
|
||||
write-request-header
|
||||
write-post-data
|
||||
|
|
@ -209,30 +297,42 @@ SYMBOL: max-post-request
|
|||
":" write
|
||||
dup port>> number>string write
|
||||
] when
|
||||
"/" write
|
||||
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 ;
|
||||
header
|
||||
cookies
|
||||
body ;
|
||||
|
||||
: <response>
|
||||
response construct-empty
|
||||
"1.0" >>version
|
||||
H{ } clone >>header ;
|
||||
"1.1" >>version
|
||||
H{ } clone >>header
|
||||
"close" "connection" set-header
|
||||
now timestamp>http-string "date" set-header
|
||||
V{ } clone >>cookies ;
|
||||
|
||||
: read-response-version
|
||||
" " read-until
|
||||
" \t" read-until
|
||||
[ "Bad response: version" throw ] unless
|
||||
parse-version
|
||||
>>version ;
|
||||
|
||||
: read-response-code
|
||||
" " read-until [ "Bad response: code" throw ] unless
|
||||
" \t" read-until [ "Bad response: code" throw ] unless
|
||||
string>number [ "Bad response: code" throw ] unless*
|
||||
>>code ;
|
||||
|
||||
|
|
@ -240,7 +340,8 @@ header ;
|
|||
readln >>message ;
|
||||
|
||||
: read-response-header
|
||||
read-header >>header ;
|
||||
read-header >>header
|
||||
dup "set-cookie" header [ parse-cookies >>cookies ] when* ;
|
||||
|
||||
: read-response ( -- response )
|
||||
<response>
|
||||
|
|
@ -260,9 +361,20 @@ header ;
|
|||
dup message>> write crlf ;
|
||||
|
||||
: write-response-header ( response -- response )
|
||||
dup header>> write-header ;
|
||||
dup header>> clone
|
||||
over cookies>> f like
|
||||
[ unparse-cookies "set-cookie" pick set-at ] when*
|
||||
write-header ;
|
||||
|
||||
: write-response ( respose -- )
|
||||
: 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
|
||||
|
|
@ -270,8 +382,39 @@ header ;
|
|||
flush
|
||||
drop ;
|
||||
|
||||
: set-response-header ( response value key -- response )
|
||||
pick header>> -rot replace-at drop ;
|
||||
M: response write-full-response ( request response -- )
|
||||
dup write-response
|
||||
swap method>> "HEAD" = [ write-response-body ] unless ;
|
||||
|
||||
: set-content-type ( response content-type -- response )
|
||||
"content-type" set-response-header ;
|
||||
: set-content-type ( request/response content-type -- request/response )
|
||||
"content-type" set-header ;
|
||||
|
||||
: get-cookie ( request/response name -- cookie/f )
|
||||
>r cookies>> r> [ swap name>> = ] curry find nip ;
|
||||
|
||||
: delete-cookie ( request/response name -- )
|
||||
over cookies>> >r get-cookie r> delete ;
|
||||
|
||||
: put-cookie ( request/response cookie -- request/response )
|
||||
[ dupd name>> get-cookie [ dupd delete-cookie ] when* ] keep
|
||||
over cookies>> push ;
|
||||
|
||||
TUPLE: raw-response
|
||||
version
|
||||
code
|
||||
message
|
||||
body ;
|
||||
|
||||
: <raw-response> ( -- response )
|
||||
raw-response construct-empty
|
||||
"1.1" >>version ;
|
||||
|
||||
M: raw-response write-response ( respose -- )
|
||||
write-response-version
|
||||
write-response-code
|
||||
write-response-message
|
||||
write-response-body
|
||||
drop ;
|
||||
|
||||
M: raw-response write-full-response ( response -- )
|
||||
write-response nip ;
|
||||
|
|
|
|||
|
|
@ -30,5 +30,6 @@ H{
|
|||
{ "pdf" "application/pdf" }
|
||||
|
||||
{ "factor" "text/plain" }
|
||||
{ "cgi" "application/x-cgi-script" }
|
||||
{ "fhtml" "application/x-factor-server-page" }
|
||||
} "mime-types" set-global
|
||||
|
|
|
|||
|
|
@ -0,0 +1,50 @@
|
|||
! Copyright (c) 2007 Chris Double.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: http.server.authentication.basic
|
||||
USING: accessors new-slots quotations assocs kernel splitting
|
||||
base64 crypto.sha2 html.elements io combinators http.server
|
||||
http sequences ;
|
||||
|
||||
! 'users' is a quotation or an assoc. The quotation
|
||||
! has stack effect ( sha-256-string username -- ? ).
|
||||
! It should perform the user authentication. 'sha-256-string'
|
||||
! is the plain text password provided by the user passed through
|
||||
! 'string>sha-256-string'. If 'users' is an assoc then
|
||||
! it is a mapping of usernames to sha-256 hashed passwords.
|
||||
TUPLE: realm responder name users ;
|
||||
|
||||
C: <realm> realm
|
||||
|
||||
: user-authorized? ( password username realm -- ? )
|
||||
users>> {
|
||||
{ [ dup callable? ] [ call ] }
|
||||
{ [ dup assoc? ] [ at = ] }
|
||||
} cond ;
|
||||
|
||||
: authorization-ok? ( realm header -- bool )
|
||||
#! Given the realm and the 'Authorization' header,
|
||||
#! authenticate the user.
|
||||
dup [
|
||||
" " split1 swap "Basic" = [
|
||||
base64> ":" split1 string>sha-256-string
|
||||
spin user-authorized?
|
||||
] [
|
||||
2drop f
|
||||
] if
|
||||
] [
|
||||
2drop f
|
||||
] if ;
|
||||
|
||||
: <401> ( realm -- response )
|
||||
401 "Unauthorized" <trivial-response>
|
||||
"Basic realm=\"" rot name>> "\"" 3append
|
||||
"WWW-Authenticate" set-header
|
||||
[
|
||||
<html> <body>
|
||||
"Username or Password is invalid" write
|
||||
</body> </html>
|
||||
] >>body ;
|
||||
|
||||
M: realm call-responder ( request path realm -- response )
|
||||
pick "authorization" header dupd authorization-ok?
|
||||
[ responder>> call-responder ] [ 2nip <401> ] if ;
|
||||
|
|
@ -0,0 +1,170 @@
|
|||
! 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.
|
||||
<temporary-redirect> exit-with ;
|
||||
|
||||
: cont-id "factorcontid" ;
|
||||
|
||||
: id>url ( id -- url )
|
||||
request get clone
|
||||
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 store-current-show redirect-to-here r> call exit-with
|
||||
] with-scope ; 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 store-current-show redirect-to-here r>
|
||||
[
|
||||
[ ] register-callback
|
||||
call
|
||||
exit-with
|
||||
] callcc1 restore-request
|
||||
] with-scope ; inline
|
||||
|
||||
: quot-id ( quot -- id )
|
||||
current-show get swap t register-callback ;
|
||||
|
||||
: quot-url ( quot -- url )
|
||||
quot-id id>url ;
|
||||
|
||||
! SYMBOL: current-show
|
||||
!
|
||||
! : store-current-show ( -- )
|
||||
! #! Store the current continuation in the variable 'current-show'
|
||||
! #! so it can be returned to later by href callbacks. Note that it
|
||||
! #! recalls itself when the continuation is called to ensure that
|
||||
! #! it resets its value back to the most recent show call.
|
||||
! [ ( 0 -- )
|
||||
! [ ( 0 1 -- )
|
||||
! current-show set ( 0 -- )
|
||||
! continue
|
||||
! ] callcc1
|
||||
! nip
|
||||
! store-current-show
|
||||
! ] callcc0 ;
|
||||
!
|
||||
|
||||
!
|
||||
! : show-final ( quot -- * )
|
||||
! store-current-show
|
||||
! redirect-to-here
|
||||
! call
|
||||
! exit-with ; inline
|
||||
!
|
||||
! : show-page ( quot -- request )
|
||||
! store-current-show redirect-to-here
|
||||
! [
|
||||
! register-continuation
|
||||
! call
|
||||
! exit-with
|
||||
! ] callcc1 restore-request ; inline
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -1,45 +1,53 @@
|
|||
USING: http.server tools.test kernel namespaces accessors
|
||||
new-slots assocs.lib io http math sequences ;
|
||||
new-slots io http math sequences assocs ;
|
||||
IN: temporary
|
||||
|
||||
TUPLE: mock-responder ;
|
||||
TUPLE: mock-responder path ;
|
||||
|
||||
: <mock-responder> ( path -- responder )
|
||||
<responder> mock-responder construct-delegate ;
|
||||
C: <mock-responder> mock-responder
|
||||
|
||||
M: mock-responder do-responder
|
||||
M: mock-responder call-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 ;
|
||||
write-response get ;
|
||||
|
||||
[
|
||||
"" <dispatcher>
|
||||
"foo" <mock-responder> add-responder
|
||||
"bar" <mock-responder> add-responder
|
||||
"baz/" <dispatcher>
|
||||
"123" <mock-responder> add-responder
|
||||
<dispatcher>
|
||||
"foo" <mock-responder> "foo" add-responder
|
||||
"bar" <mock-responder> "bar" add-responder
|
||||
<dispatcher>
|
||||
"123" <mock-responder> "123" add-responder
|
||||
"default" <mock-responder> >>default
|
||||
add-responder
|
||||
"baz" add-responder
|
||||
default-host set
|
||||
|
||||
[ "foo" ] [
|
||||
"foo" default-host get find-responder path>> nip
|
||||
] unit-test
|
||||
|
||||
[ "bar" ] [
|
||||
"bar" default-host get find-responder path>> nip
|
||||
] 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
|
||||
|
||||
[ 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
|
||||
header>> "location" swap at "baz/" tail? r> and
|
||||
] unit-test
|
||||
] with-scope
|
||||
|
|
|
|||
|
|
@ -2,24 +2,17 @@
|
|||
! 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 ;
|
||||
new-slots html.elements accessors math.parser combinators.lib
|
||||
vocabs.loader debugger html continuations random ;
|
||||
IN: http.server
|
||||
|
||||
TUPLE: responder path directory ;
|
||||
GENERIC: call-responder ( request path responder -- response )
|
||||
|
||||
: <responder> ( path -- responder )
|
||||
"/" ?tail responder construct-boa ;
|
||||
TUPLE: trivial-responder response ;
|
||||
|
||||
GENERIC: do-responder ( request path responder -- quot response )
|
||||
C: <trivial-responder> trivial-responder
|
||||
|
||||
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>> ;
|
||||
M: trivial-responder call-responder 2nip response>> call ;
|
||||
|
||||
: trivial-response-body ( code message -- )
|
||||
<html>
|
||||
|
|
@ -28,23 +21,30 @@ M: trivial-responder do-responder
|
|||
</body>
|
||||
</html> ;
|
||||
|
||||
: <trivial-response> ( code message -- quot response )
|
||||
[ [ trivial-response-body ] 2curry ] 2keep <response>
|
||||
: <trivial-response> ( code message -- response )
|
||||
<response>
|
||||
2over [ trivial-response-body ] 2curry >>body
|
||||
"text/html" set-content-type
|
||||
swap >>message
|
||||
swap >>code ;
|
||||
|
||||
: <404> ( -- quot response )
|
||||
: <404> ( -- response )
|
||||
404 "Not Found" <trivial-response> ;
|
||||
|
||||
: <redirect> ( to code message -- quot response )
|
||||
<trivial-response>
|
||||
rot "location" set-response-header ;
|
||||
SYMBOL: 404-responder
|
||||
|
||||
: <permanent-redirect> ( to -- quot response )
|
||||
[ <404> ] <trivial-responder> 404-responder set-global
|
||||
|
||||
: <redirect> ( to code message -- response )
|
||||
<trivial-response>
|
||||
swap "location" set-header ;
|
||||
|
||||
\ <redirect> DEBUG add-input-logging
|
||||
|
||||
: <permanent-redirect> ( to -- response )
|
||||
301 "Moved Permanently" <redirect> ;
|
||||
|
||||
: <temporary-redirect> ( to -- quot response )
|
||||
: <temporary-redirect> ( to -- response )
|
||||
307 "Temporary Redirect" <redirect> ;
|
||||
|
||||
: <content> ( content-type -- response )
|
||||
|
|
@ -52,66 +52,58 @@ M: trivial-responder do-responder
|
|||
200 >>code
|
||||
swap set-content-type ;
|
||||
|
||||
TUPLE: dispatcher responders default ;
|
||||
TUPLE: dispatcher default responders ;
|
||||
|
||||
: responder-matches? ( path responder -- ? )
|
||||
path>> head? ;
|
||||
: get-responder ( name dispatcher -- responder )
|
||||
tuck responders>> at [ ] [ default>> ] ?if ;
|
||||
|
||||
TUPLE: no-/-responder ;
|
||||
: find-responder ( path dispatcher -- path responder )
|
||||
>r [ CHAR: / = ] left-trim "/" split1
|
||||
swap [ CHAR: / = ] right-trim r> get-responder ;
|
||||
|
||||
M: no-/-responder do-responder
|
||||
2drop
|
||||
: redirect-with-/ ( request -- response )
|
||||
dup path>> "/" append >>path
|
||||
request-url <permanent-redirect> ;
|
||||
|
||||
: <no-/-responder> ( -- responder )
|
||||
"" <responder> no-/-responder construct-delegate ;
|
||||
M: dispatcher call-responder
|
||||
over [
|
||||
find-responder call-responder
|
||||
] [
|
||||
2drop redirect-with-/
|
||||
] if ;
|
||||
|
||||
<no-/-responder> no-/-responder set-global
|
||||
: <dispatcher> ( -- dispatcher )
|
||||
404-responder get-global H{ } clone
|
||||
dispatcher construct-boa ;
|
||||
|
||||
: 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 ;
|
||||
: add-responder ( dispatcher responder path -- dispatcher )
|
||||
pick responders>> set-at ;
|
||||
|
||||
SYMBOL: virtual-hosts
|
||||
SYMBOL: default-host
|
||||
|
||||
virtual-hosts global [ drop H{ } clone ] cache drop
|
||||
default-host global [ drop 404-responder ] 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* ;
|
||||
|
||||
: <500> ( error -- response )
|
||||
500 "Internal server error" <trivial-response>
|
||||
swap [
|
||||
"Internal server error" [
|
||||
[ print-error nl :c ] with-html-stream
|
||||
] simple-page
|
||||
] curry >>body ;
|
||||
|
||||
: handle-request ( request -- )
|
||||
[
|
||||
dup path>> over host>> find-virtual-host
|
||||
call-responder
|
||||
write-response
|
||||
] keep method>> "HEAD" = [ drop ] [ call ] if ;
|
||||
dup dup path>> over host>>
|
||||
find-virtual-host call-responder
|
||||
] [ <500> ] recover
|
||||
dup write-response
|
||||
swap method>> "HEAD" =
|
||||
[ drop ] [ write-response-body ] if ;
|
||||
|
||||
: default-timeout 1 minutes stdio get set-timeout ;
|
||||
|
||||
|
|
@ -120,12 +112,21 @@ LOG: httpd-hit NOTICE
|
|||
: log-request ( request -- )
|
||||
{ method>> host>> path>> } map-exec-with httpd-hit ;
|
||||
|
||||
SYMBOL: development-mode
|
||||
|
||||
: (httpd) ( -- )
|
||||
default-timeout
|
||||
development-mode get-global
|
||||
[ global [ refresh-all ] bind ] when
|
||||
read-request dup log-request handle-request ;
|
||||
|
||||
: httpd ( port -- )
|
||||
internet-server "http.server" [
|
||||
default-timeout
|
||||
read-request dup log-request handle-request
|
||||
] with-server ;
|
||||
internet-server "http.server" [ (httpd) ] with-server ;
|
||||
|
||||
: httpd-main ( -- ) 8888 httpd ;
|
||||
|
||||
MAIN: httpd-main
|
||||
|
||||
: generate-key ( assoc -- str )
|
||||
4 big-random >hex dup pick key?
|
||||
[ drop generate-key ] [ nip ] if ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1,32 @@
|
|||
IN: temporary
|
||||
USING: tools.test http.server.sessions math namespaces
|
||||
kernel accessors ;
|
||||
|
||||
"1234" f <session> [
|
||||
[ ] [ 3 "x" sset ] unit-test
|
||||
|
||||
[ 9 ] [ "x" sget sq ] unit-test
|
||||
|
||||
[ ] [ "x" [ 1- ] schange ] unit-test
|
||||
|
||||
[ 4 ] [ "x" sget sq ] unit-test
|
||||
] with-session
|
||||
|
||||
[ t ] [ f <url-sessions> url-sessions? ] unit-test
|
||||
[ t ] [ f <cookie-sessions> cookie-sessions? ] unit-test
|
||||
|
||||
[ ] [
|
||||
f <url-sessions>
|
||||
[ 0 "x" sset ] >>init
|
||||
"manager" set
|
||||
] unit-test
|
||||
|
||||
[ { 5 0 } ] [
|
||||
[
|
||||
"manager" get new-session
|
||||
dup "manager" get get-session [ 5 "a" sset ] with-session
|
||||
dup "manager" get get-session [ "a" sget , ] with-session
|
||||
dup "manager" get get-session [ "x" sget , ] with-session
|
||||
"manager" get get-session delete-session
|
||||
] { } make
|
||||
] unit-test
|
||||
|
|
@ -0,0 +1,112 @@
|
|||
! Copyright (C) 2008 Doug Coleman, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs calendar kernel math.parser namespaces random
|
||||
boxes alarms new-slots accessors http http.server
|
||||
quotations hashtables sequences ;
|
||||
IN: http.server.sessions
|
||||
|
||||
! ! ! ! ! !
|
||||
! WARNING: this session manager is vulnerable to XSRF attacks
|
||||
! ! ! ! ! !
|
||||
|
||||
TUPLE: session-manager responder init 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>> ?box [ cancel-alarm ] [ drop ] if ;
|
||||
|
||||
: 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
|
||||
|
||||
: with-session ( session quot -- )
|
||||
>r \ session r> with-variable ; inline
|
||||
|
||||
: new-session ( responder -- id )
|
||||
[ sessions>> generate-key dup ] keep
|
||||
[ <session> dup touch-session ] keep
|
||||
[ init>> with-session ] 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 )
|
||||
[ responder>> call-responder ] with-session ;
|
||||
|
||||
: 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
|
||||
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 -- cookie )
|
||||
sess-id get-cookie ;
|
||||
|
||||
: <session-cookie> ( id -- cookie )
|
||||
sess-id <cookie> ;
|
||||
|
||||
M: cookie-sessions call-responder ( request path responder -- response )
|
||||
pick get-session-cookie value>> over get-session [
|
||||
call-responder/session
|
||||
] [
|
||||
dup new-session
|
||||
[ over get-session call-responder/session ] keep
|
||||
<session-cookie> put-cookie
|
||||
] if* ;
|
||||
|
|
@ -0,0 +1,95 @@
|
|||
! 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 )
|
||||
[
|
||||
responder set
|
||||
swap request set
|
||||
serve-object
|
||||
] with-scope ;
|
||||
|
|
@ -4,7 +4,8 @@
|
|||
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 ;
|
||||
strings splitting accessors http.server.static http.server
|
||||
assocs ;
|
||||
|
||||
IN: http.server.templating
|
||||
|
||||
|
|
@ -82,10 +83,10 @@ DEFER: <% delimiter
|
|||
templating-vocab use+
|
||||
! so that reload works properly
|
||||
dup source-file file set
|
||||
dup ?resource-path file-contents
|
||||
?resource-path file-contents
|
||||
[ eval-template ] [ html-error. drop ] recover
|
||||
] with-file-vocabs
|
||||
] assert-depth drop ;
|
||||
] curry assert-depth ;
|
||||
|
||||
: run-relative-template-file ( filename -- )
|
||||
file get source-file-path parent-directory
|
||||
|
|
@ -93,3 +94,13 @@ DEFER: <% delimiter
|
|||
|
||||
: template-convert ( infile outfile -- )
|
||||
[ 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 ;
|
||||
|
|
|
|||
|
|
@ -1 +0,0 @@
|
|||
Slava Pestov
|
||||
|
|
@ -1,75 +0,0 @@
|
|||
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces kernel assocs io.files combinators
|
||||
arrays io.launcher io http.server.responders webapps.file
|
||||
sequences strings math.parser unicode.case ;
|
||||
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 <process-stream> [
|
||||
post? [
|
||||
"raw-response" get write flush
|
||||
] when
|
||||
stdio get swap (stream-copy)
|
||||
] with-stream ;
|
||||
|
||||
: serve-regular-file ( -- )
|
||||
cgi-root get doc-root [ file-responder ] with-variable ;
|
||||
|
||||
: do-cgi ( name -- )
|
||||
{
|
||||
{ [ dup ".cgi" tail? not ] [ drop serve-regular-file ] }
|
||||
{ [ dup empty? ] [ "403 forbidden" httpd-error ] }
|
||||
{ [ cgi-root get not ] [ "404 cgi-root not set" httpd-error ] }
|
||||
{ [ ".." over subseq? ] [ "403 forbidden" httpd-error ] }
|
||||
{ [ t ] [ (do-cgi) ] }
|
||||
} cond ;
|
||||
|
||||
global [
|
||||
"cgi" [ "argument" get do-cgi ] add-simple-responder
|
||||
] bind
|
||||
|
|
@ -1 +0,0 @@
|
|||
Slava Pestov
|
||||
|
|
@ -1,136 +0,0 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: calendar html io io.files kernel math math.parser
|
||||
http.server.responders http.server.templating namespaces parser
|
||||
sequences strings assocs hashtables debugger http.mime sorting
|
||||
html.elements logging calendar.format ;
|
||||
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
|
||||
<file-reader> stdio get stream-copy
|
||||
] serve-file-hook set-global
|
||||
|
||||
: serve-static ( filename mime-type -- )
|
||||
over last-modified-matches? [
|
||||
2drop not-modified-response
|
||||
] [
|
||||
"method" get "head" = [
|
||||
file-response
|
||||
] [
|
||||
serve-file-hook get call
|
||||
] if
|
||||
] if ;
|
||||
|
||||
SYMBOL: page
|
||||
|
||||
: run-page ( filename -- )
|
||||
dup
|
||||
[ [ dup page set run-template-file ] with-scope ] try
|
||||
drop ;
|
||||
|
||||
\ run-page DEBUG add-input-logging
|
||||
|
||||
: include-page ( filename -- )
|
||||
serving-path run-page ;
|
||||
|
||||
: serve-fhtml ( filename -- )
|
||||
serving-html
|
||||
"method" get "head" = [ drop ] [ run-page ] if ;
|
||||
|
||||
: serve-file ( filename -- )
|
||||
dup mime-type dup "application/x-factor-server-page" =
|
||||
[ drop serve-fhtml ] [ serve-static ] if ;
|
||||
|
||||
\ serve-file NOTICE add-input-logging
|
||||
|
||||
: file. ( name dirp -- )
|
||||
[ "/" append ] when
|
||||
dup <a =href a> write </a> ;
|
||||
|
||||
: directory. ( path request -- )
|
||||
dup [
|
||||
<h1> write </h1>
|
||||
<ul>
|
||||
directory sort-keys
|
||||
[ <li> file. </li> ] assoc-each
|
||||
</ul>
|
||||
] simple-html-document ;
|
||||
|
||||
: list-directory ( directory -- )
|
||||
serving-html
|
||||
"method" get "head" = [
|
||||
drop
|
||||
] [
|
||||
"request" get directory.
|
||||
] if ;
|
||||
|
||||
: find-index ( filename -- path )
|
||||
{ "index.html" "index.fhtml" }
|
||||
[ dupd path+ exists? ] find nip
|
||||
dup [ path+ ] [ nip ] if ;
|
||||
|
||||
: serve-directory ( filename -- )
|
||||
dup "/" tail? [
|
||||
dup find-index
|
||||
[ serve-file ] [ list-directory ] ?if
|
||||
] [
|
||||
drop directory-no/
|
||||
] if ;
|
||||
|
||||
: serve-object ( filename -- )
|
||||
serving-path dup exists? [
|
||||
dup directory? [ serve-directory ] [ serve-file ] if
|
||||
] [
|
||||
drop "404 not found" httpd-error
|
||||
] if ;
|
||||
|
||||
: file-responder ( -- )
|
||||
doc-root get [
|
||||
"argument" get serve-object
|
||||
] [
|
||||
"404 doc-root not set" httpd-error
|
||||
] if ;
|
||||
|
||||
global [
|
||||
! Serves files from a directory stored in the doc-root
|
||||
! variable. You can set the variable in the global
|
||||
! namespace, or inside the responder.
|
||||
"file" [ file-responder ] add-simple-responder
|
||||
|
||||
! The root directory is served by...
|
||||
"file" set-default-responder
|
||||
] bind
|
||||
|
|
@ -1 +0,0 @@
|
|||
Slava Pestov
|
||||
|
|
@ -1,35 +0,0 @@
|
|||
! Copyright (C) 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io.files namespaces webapps.file http.server.responders
|
||||
xmode.code2html kernel html sequences ;
|
||||
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 <file-reader> htmlize-stream
|
||||
] with-html-stream ;
|
||||
|
||||
global [
|
||||
! Serve up our own source code
|
||||
"source" [
|
||||
"argument" get check-source-path [
|
||||
[
|
||||
"" resource-path doc-root set
|
||||
[ source-responder ] serve-file-hook set
|
||||
file-responder
|
||||
] with-scope
|
||||
] [
|
||||
"403 forbidden" httpd-error
|
||||
] if
|
||||
] add-simple-responder
|
||||
] bind
|
||||
|
|
@ -0,0 +1,15 @@
|
|||
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io.files namespaces http.server http.server.static http
|
||||
xmode.code2html kernel html sequences accessors ;
|
||||
IN: xmode.code2html.responder
|
||||
|
||||
: <sources> ( root -- responder )
|
||||
[
|
||||
drop
|
||||
"text/html" <content>
|
||||
over file-http-date "last-modified" set-header
|
||||
swap [
|
||||
dup file-name swap <file-reader> htmlize-stream
|
||||
] curry >>body
|
||||
] <file-responder> ;
|
||||
Loading…
Reference in New Issue