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"
|
host: "www.apple.com"
|
||||||
path: "/index.html"
|
path: "/index.html"
|
||||||
port: 80
|
port: 80
|
||||||
|
version: "1.1"
|
||||||
|
cookies: V{ }
|
||||||
}
|
}
|
||||||
] [
|
] [
|
||||||
[
|
[
|
||||||
|
|
|
||||||
|
|
@ -2,7 +2,7 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: assocs http kernel math math.parser namespaces sequences
|
USING: assocs http kernel math math.parser namespaces sequences
|
||||||
io io.sockets io.streams.string io.files io.timeouts strings
|
io io.sockets io.streams.string io.files io.timeouts strings
|
||||||
splitting continuations assocs.lib calendar vectors hashtables
|
splitting continuations calendar vectors hashtables
|
||||||
accessors ;
|
accessors ;
|
||||||
IN: http.client
|
IN: http.client
|
||||||
|
|
||||||
|
|
@ -32,7 +32,7 @@ DEFER: (http-request)
|
||||||
|
|
||||||
: do-redirect ( response -- response stream )
|
: do-redirect ( response -- response stream )
|
||||||
dup response-code 300 399 between? [
|
dup response-code 300 399 between? [
|
||||||
header>> "location" peek-at
|
header>> "location" swap at
|
||||||
dup "http://" head? [
|
dup "http://" head? [
|
||||||
absolute-redirect
|
absolute-redirect
|
||||||
] [
|
] [
|
||||||
|
|
@ -44,7 +44,7 @@ DEFER: (http-request)
|
||||||
|
|
||||||
: (http-request) ( request -- response stream )
|
: (http-request) ( request -- response stream )
|
||||||
dup host>> over port>> <inet> <client> stdio set
|
dup host>> over port>> <inet> <client> stdio set
|
||||||
write-request flush read-response
|
dup "r" set-global write-request flush read-response
|
||||||
do-redirect ;
|
do-redirect ;
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
@ -59,8 +59,7 @@ PRIVATE>
|
||||||
] with-scope ;
|
] with-scope ;
|
||||||
|
|
||||||
: <get-request> ( -- request )
|
: <get-request> ( -- request )
|
||||||
request construct-empty
|
<request> "GET" >>method ;
|
||||||
"GET" >>method ;
|
|
||||||
|
|
||||||
: http-get-stream ( url -- response stream )
|
: http-get-stream ( url -- response stream )
|
||||||
<get-request> http-request ;
|
<get-request> http-request ;
|
||||||
|
|
@ -86,7 +85,7 @@ PRIVATE>
|
||||||
dup download-name download-to ;
|
dup download-name download-to ;
|
||||||
|
|
||||||
: <post-request> ( content-type content -- request )
|
: <post-request> ( content-type content -- request )
|
||||||
request construct-empty
|
<request>
|
||||||
"POST" >>method
|
"POST" >>method
|
||||||
swap >>post-data
|
swap >>post-data
|
||||||
swap >>post-data-type ;
|
swap >>post-data-type ;
|
||||||
|
|
|
||||||
|
|
@ -29,12 +29,14 @@ blah
|
||||||
|
|
||||||
[
|
[
|
||||||
TUPLE{ request
|
TUPLE{ request
|
||||||
|
port: 80
|
||||||
method: "GET"
|
method: "GET"
|
||||||
path: "bar"
|
path: "bar"
|
||||||
query: f
|
query: H{ }
|
||||||
version: "1.1"
|
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"
|
post-data: "blah"
|
||||||
|
cookies: V{ }
|
||||||
}
|
}
|
||||||
] [
|
] [
|
||||||
read-request-test-1 [
|
read-request-test-1 [
|
||||||
|
|
@ -45,8 +47,7 @@ blah
|
||||||
STRING: read-request-test-1'
|
STRING: read-request-test-1'
|
||||||
GET bar HTTP/1.1
|
GET bar HTTP/1.1
|
||||||
content-length: 4
|
content-length: 4
|
||||||
some-header: 1
|
some-header: 1; 2
|
||||||
some-header: 2
|
|
||||||
|
|
||||||
blah
|
blah
|
||||||
;
|
;
|
||||||
|
|
@ -60,18 +61,20 @@ read-request-test-1' 1array [
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
STRING: read-request-test-2
|
STRING: read-request-test-2
|
||||||
HEAD http://foo/bar HTTP/1.0
|
HEAD http://foo/bar HTTP/1.1
|
||||||
Host: www.sex.com
|
Host: www.sex.com
|
||||||
;
|
;
|
||||||
|
|
||||||
[
|
[
|
||||||
TUPLE{ request
|
TUPLE{ request
|
||||||
|
port: 80
|
||||||
method: "HEAD"
|
method: "HEAD"
|
||||||
path: "bar"
|
path: "bar"
|
||||||
query: f
|
query: H{ }
|
||||||
version: "1.0"
|
version: "1.1"
|
||||||
header: H{ { "host" V{ "www.sex.com" } } }
|
header: H{ { "host" "www.sex.com" } }
|
||||||
host: "www.sex.com"
|
host: "www.sex.com"
|
||||||
|
cookies: V{ }
|
||||||
}
|
}
|
||||||
] [
|
] [
|
||||||
read-request-test-2 [
|
read-request-test-2 [
|
||||||
|
|
@ -80,7 +83,7 @@ Host: www.sex.com
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
STRING: read-response-test-1
|
STRING: read-response-test-1
|
||||||
HTTP/1.0 404 not found
|
HTTP/1.1 404 not found
|
||||||
Content-Type: text/html
|
Content-Type: text/html
|
||||||
|
|
||||||
blah
|
blah
|
||||||
|
|
@ -88,10 +91,11 @@ blah
|
||||||
|
|
||||||
[
|
[
|
||||||
TUPLE{ response
|
TUPLE{ response
|
||||||
version: "1.0"
|
version: "1.1"
|
||||||
code: 404
|
code: 404
|
||||||
message: "not found"
|
message: "not found"
|
||||||
header: H{ { "content-type" V{ "text/html" } } }
|
header: H{ { "content-type" "text/html" } }
|
||||||
|
cookies: V{ }
|
||||||
}
|
}
|
||||||
] [
|
] [
|
||||||
read-response-test-1
|
read-response-test-1
|
||||||
|
|
@ -100,7 +104,7 @@ blah
|
||||||
|
|
||||||
|
|
||||||
STRING: read-response-test-1'
|
STRING: read-response-test-1'
|
||||||
HTTP/1.0 404 not found
|
HTTP/1.1 404 not found
|
||||||
content-type: text/html
|
content-type: text/html
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -113,3 +117,8 @@ read-response-test-1' 1array [
|
||||||
! normalize crlf
|
! normalize crlf
|
||||||
string-lines "\n" join
|
string-lines "\n" join
|
||||||
] unit-test
|
] 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.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: hashtables io io.streams.string kernel math namespaces
|
USING: hashtables io io.streams.string kernel math namespaces
|
||||||
math.parser assocs sequences strings splitting ascii
|
math.parser assocs sequences strings splitting ascii
|
||||||
io.encodings.utf8 assocs.lib namespaces unicode.case combinators
|
io.encodings.utf8 namespaces unicode.case combinators
|
||||||
vectors sorting new-slots accessors calendar ;
|
vectors sorting new-slots accessors calendar calendar.format
|
||||||
|
quotations arrays ;
|
||||||
IN: http
|
IN: http
|
||||||
|
|
||||||
: http-port 80 ; inline
|
: 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 -- ? )
|
: url-quotable? ( ch -- ? )
|
||||||
#! In a URL, can this character be used without
|
#! In a URL, can this character be used without
|
||||||
#! URL-encoding?
|
#! URL-encoding?
|
||||||
|
|
@ -73,6 +52,54 @@ IN: http
|
||||||
: url-decode ( str -- str )
|
: url-decode ( str -- str )
|
||||||
[ 0 swap url-decode-iter ] "" make decode-utf8 ;
|
[ 0 swap url-decode-iter ] "" make decode-utf8 ;
|
||||||
|
|
||||||
|
: 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 )
|
: query>assoc ( query -- assoc )
|
||||||
dup [
|
dup [
|
||||||
"&" split [
|
"&" split [
|
||||||
|
|
@ -84,6 +111,50 @@ IN: http
|
||||||
[ [ url-encode ] 2apply "=" swap 3append ] { } assoc>map
|
[ [ url-encode ] 2apply "=" swap 3append ] { } assoc>map
|
||||||
"&" join ;
|
"&" 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
|
TUPLE: request
|
||||||
host
|
host
|
||||||
port
|
port
|
||||||
|
|
@ -93,12 +164,21 @@ query
|
||||||
version
|
version
|
||||||
header
|
header
|
||||||
post-data
|
post-data
|
||||||
post-data-type ;
|
post-data-type
|
||||||
|
cookies ;
|
||||||
|
|
||||||
: <request>
|
: <request>
|
||||||
request construct-empty
|
request construct-empty
|
||||||
"1.0" >>version
|
"1.1" >>version
|
||||||
http-port >>port ;
|
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>path ( url -- path )
|
||||||
url-decode "http://" ?head
|
url-decode "http://" ?head
|
||||||
|
|
@ -132,12 +212,15 @@ post-data-type ;
|
||||||
: read-request-header ( request -- request )
|
: read-request-header ( request -- request )
|
||||||
read-header >>header ;
|
read-header >>header ;
|
||||||
|
|
||||||
|
: header ( request/response key -- value )
|
||||||
|
swap header>> at ;
|
||||||
|
|
||||||
SYMBOL: max-post-request
|
SYMBOL: max-post-request
|
||||||
|
|
||||||
1024 256 * max-post-request set-global
|
1024 256 * max-post-request set-global
|
||||||
|
|
||||||
: content-length ( header -- n )
|
: content-length ( header -- n )
|
||||||
"content-length" peek-at string>number dup [
|
"content-length" swap at string>number dup [
|
||||||
dup max-post-request get > [
|
dup max-post-request get > [
|
||||||
"content-length > max-post-request" throw
|
"content-length > max-post-request" throw
|
||||||
] when
|
] when
|
||||||
|
|
@ -151,10 +234,13 @@ SYMBOL: max-post-request
|
||||||
[ string>number ] [ http-port ] if* ;
|
[ string>number ] [ http-port ] if* ;
|
||||||
|
|
||||||
: extract-host ( request -- request )
|
: 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 )
|
: 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 )
|
: read-request ( -- request )
|
||||||
<request>
|
<request>
|
||||||
|
|
@ -164,7 +250,8 @@ SYMBOL: max-post-request
|
||||||
read-request-header
|
read-request-header
|
||||||
read-post-data
|
read-post-data
|
||||||
extract-host
|
extract-host
|
||||||
extract-post-data-type ;
|
extract-post-data-type
|
||||||
|
extract-cookies ;
|
||||||
|
|
||||||
: write-method ( request -- request )
|
: write-method ( request -- request )
|
||||||
dup method>> write bl ;
|
dup method>> write bl ;
|
||||||
|
|
@ -184,9 +271,10 @@ SYMBOL: max-post-request
|
||||||
|
|
||||||
: write-request-header ( request -- request )
|
: write-request-header ( request -- request )
|
||||||
dup header>> >hashtable
|
dup header>> >hashtable
|
||||||
over host>> [ "host" replace-at ] when*
|
over host>> [ "host" pick set-at ] when*
|
||||||
over post-data>> [ length "content-length" replace-at ] when*
|
over post-data>> [ length "content-length" pick set-at ] when*
|
||||||
over post-data-type>> [ "content-type" replace-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-header ;
|
||||||
|
|
||||||
: write-post-data ( request -- request )
|
: write-post-data ( request -- request )
|
||||||
|
|
@ -194,7 +282,7 @@ SYMBOL: max-post-request
|
||||||
|
|
||||||
: write-request ( request -- )
|
: write-request ( request -- )
|
||||||
write-method
|
write-method
|
||||||
write-url
|
write-request-url
|
||||||
write-version
|
write-version
|
||||||
write-request-header
|
write-request-header
|
||||||
write-post-data
|
write-post-data
|
||||||
|
|
@ -209,30 +297,42 @@ SYMBOL: max-post-request
|
||||||
":" write
|
":" write
|
||||||
dup port>> number>string write
|
dup port>> number>string write
|
||||||
] when
|
] when
|
||||||
"/" write
|
dup path>> "/" head? [ "/" write ] unless
|
||||||
write-url
|
write-url
|
||||||
drop
|
drop
|
||||||
] with-string-writer ;
|
] 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
|
TUPLE: response
|
||||||
version
|
version
|
||||||
code
|
code
|
||||||
message
|
message
|
||||||
header ;
|
header
|
||||||
|
cookies
|
||||||
|
body ;
|
||||||
|
|
||||||
: <response>
|
: <response>
|
||||||
response construct-empty
|
response construct-empty
|
||||||
"1.0" >>version
|
"1.1" >>version
|
||||||
H{ } clone >>header ;
|
H{ } clone >>header
|
||||||
|
"close" "connection" set-header
|
||||||
|
now timestamp>http-string "date" set-header
|
||||||
|
V{ } clone >>cookies ;
|
||||||
|
|
||||||
: read-response-version
|
: read-response-version
|
||||||
" " read-until
|
" \t" read-until
|
||||||
[ "Bad response: version" throw ] unless
|
[ "Bad response: version" throw ] unless
|
||||||
parse-version
|
parse-version
|
||||||
>>version ;
|
>>version ;
|
||||||
|
|
||||||
: read-response-code
|
: 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*
|
string>number [ "Bad response: code" throw ] unless*
|
||||||
>>code ;
|
>>code ;
|
||||||
|
|
||||||
|
|
@ -240,7 +340,8 @@ header ;
|
||||||
readln >>message ;
|
readln >>message ;
|
||||||
|
|
||||||
: read-response-header
|
: read-response-header
|
||||||
read-header >>header ;
|
read-header >>header
|
||||||
|
dup "set-cookie" header [ parse-cookies >>cookies ] when* ;
|
||||||
|
|
||||||
: read-response ( -- response )
|
: read-response ( -- response )
|
||||||
<response>
|
<response>
|
||||||
|
|
@ -260,9 +361,20 @@ header ;
|
||||||
dup message>> write crlf ;
|
dup message>> write crlf ;
|
||||||
|
|
||||||
: write-response-header ( response -- response )
|
: 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-version
|
||||||
write-response-code
|
write-response-code
|
||||||
write-response-message
|
write-response-message
|
||||||
|
|
@ -270,8 +382,39 @@ header ;
|
||||||
flush
|
flush
|
||||||
drop ;
|
drop ;
|
||||||
|
|
||||||
: set-response-header ( response value key -- response )
|
M: response write-full-response ( request response -- )
|
||||||
pick header>> -rot replace-at drop ;
|
dup write-response
|
||||||
|
swap method>> "HEAD" = [ write-response-body ] unless ;
|
||||||
|
|
||||||
: set-content-type ( response content-type -- response )
|
: set-content-type ( request/response content-type -- request/response )
|
||||||
"content-type" set-response-header ;
|
"content-type" set-header ;
|
||||||
|
|
||||||
|
: get-cookie ( request/response name -- cookie/f )
|
||||||
|
>r cookies>> r> [ swap name>> = ] curry find nip ;
|
||||||
|
|
||||||
|
: delete-cookie ( request/response name -- )
|
||||||
|
over cookies>> >r get-cookie r> delete ;
|
||||||
|
|
||||||
|
: put-cookie ( request/response cookie -- request/response )
|
||||||
|
[ dupd name>> get-cookie [ dupd delete-cookie ] when* ] keep
|
||||||
|
over cookies>> push ;
|
||||||
|
|
||||||
|
TUPLE: raw-response
|
||||||
|
version
|
||||||
|
code
|
||||||
|
message
|
||||||
|
body ;
|
||||||
|
|
||||||
|
: <raw-response> ( -- response )
|
||||||
|
raw-response construct-empty
|
||||||
|
"1.1" >>version ;
|
||||||
|
|
||||||
|
M: raw-response write-response ( respose -- )
|
||||||
|
write-response-version
|
||||||
|
write-response-code
|
||||||
|
write-response-message
|
||||||
|
write-response-body
|
||||||
|
drop ;
|
||||||
|
|
||||||
|
M: raw-response write-full-response ( response -- )
|
||||||
|
write-response nip ;
|
||||||
|
|
|
||||||
|
|
@ -30,5 +30,6 @@ H{
|
||||||
{ "pdf" "application/pdf" }
|
{ "pdf" "application/pdf" }
|
||||||
|
|
||||||
{ "factor" "text/plain" }
|
{ "factor" "text/plain" }
|
||||||
|
{ "cgi" "application/x-cgi-script" }
|
||||||
{ "fhtml" "application/x-factor-server-page" }
|
{ "fhtml" "application/x-factor-server-page" }
|
||||||
} "mime-types" set-global
|
} "mime-types" set-global
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,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
|
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
|
IN: temporary
|
||||||
|
|
||||||
TUPLE: mock-responder ;
|
TUPLE: mock-responder path ;
|
||||||
|
|
||||||
: <mock-responder> ( path -- responder )
|
C: <mock-responder> mock-responder
|
||||||
<responder> mock-responder construct-delegate ;
|
|
||||||
|
|
||||||
M: mock-responder do-responder
|
M: mock-responder call-responder
|
||||||
2nip
|
2nip
|
||||||
path>> on
|
path>> on
|
||||||
[ "Hello world" print ]
|
|
||||||
"text/plain" <content> ;
|
"text/plain" <content> ;
|
||||||
|
|
||||||
: check-dispatch ( tag path -- ? )
|
: check-dispatch ( tag path -- ? )
|
||||||
over off
|
over off
|
||||||
<request> swap default-host get call-responder
|
<request> swap default-host get call-responder
|
||||||
write-response call get ;
|
write-response get ;
|
||||||
|
|
||||||
[
|
[
|
||||||
"" <dispatcher>
|
<dispatcher>
|
||||||
"foo" <mock-responder> add-responder
|
"foo" <mock-responder> "foo" add-responder
|
||||||
"bar" <mock-responder> add-responder
|
"bar" <mock-responder> "bar" add-responder
|
||||||
"baz/" <dispatcher>
|
<dispatcher>
|
||||||
"123" <mock-responder> add-responder
|
"123" <mock-responder> "123" add-responder
|
||||||
"default" <mock-responder> >>default
|
"default" <mock-responder> >>default
|
||||||
add-responder
|
"baz" add-responder
|
||||||
default-host set
|
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
|
[ t ] [ "foo" "foo" check-dispatch ] unit-test
|
||||||
[ f ] [ "foo" "bar" check-dispatch ] unit-test
|
[ f ] [ "foo" "bar" check-dispatch ] unit-test
|
||||||
[ t ] [ "bar" "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 ] [ "default" "/baz/xxx//" check-dispatch ] unit-test
|
||||||
[ t ] [ "123" "baz/123" check-dispatch ] unit-test
|
[ t ] [ "123" "baz/123" check-dispatch ] unit-test
|
||||||
|
[ t ] [ "123" "baz///123" check-dispatch ] unit-test
|
||||||
|
|
||||||
[ t ] [
|
[ t ] [
|
||||||
<request>
|
<request>
|
||||||
"baz" >>path
|
"baz" >>path
|
||||||
"baz" default-host get call-responder
|
"baz" default-host get call-responder
|
||||||
dup code>> 300 399 between? >r
|
dup code>> 300 399 between? >r
|
||||||
header>> "location" peek-at "baz/" tail? r> and
|
header>> "location" swap at "baz/" tail? r> and
|
||||||
nip
|
|
||||||
] unit-test
|
] unit-test
|
||||||
] with-scope
|
] with-scope
|
||||||
|
|
|
||||||
|
|
@ -2,24 +2,17 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: assocs kernel namespaces io io.timeouts strings splitting
|
USING: assocs kernel namespaces io io.timeouts strings splitting
|
||||||
threads http sequences prettyprint io.server logging calendar
|
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
|
IN: http.server
|
||||||
|
|
||||||
TUPLE: responder path directory ;
|
GENERIC: call-responder ( request path responder -- response )
|
||||||
|
|
||||||
: <responder> ( path -- responder )
|
TUPLE: trivial-responder response ;
|
||||||
"/" ?tail responder construct-boa ;
|
|
||||||
|
|
||||||
GENERIC: do-responder ( request path responder -- quot response )
|
C: <trivial-responder> trivial-responder
|
||||||
|
|
||||||
TUPLE: trivial-responder quot response ;
|
M: trivial-responder call-responder 2nip response>> call ;
|
||||||
|
|
||||||
: <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 -- )
|
: trivial-response-body ( code message -- )
|
||||||
<html>
|
<html>
|
||||||
|
|
@ -28,23 +21,30 @@ M: trivial-responder do-responder
|
||||||
</body>
|
</body>
|
||||||
</html> ;
|
</html> ;
|
||||||
|
|
||||||
: <trivial-response> ( code message -- quot response )
|
: <trivial-response> ( code message -- response )
|
||||||
[ [ trivial-response-body ] 2curry ] 2keep <response>
|
<response>
|
||||||
|
2over [ trivial-response-body ] 2curry >>body
|
||||||
"text/html" set-content-type
|
"text/html" set-content-type
|
||||||
swap >>message
|
swap >>message
|
||||||
swap >>code ;
|
swap >>code ;
|
||||||
|
|
||||||
: <404> ( -- quot response )
|
: <404> ( -- response )
|
||||||
404 "Not Found" <trivial-response> ;
|
404 "Not Found" <trivial-response> ;
|
||||||
|
|
||||||
: <redirect> ( to code message -- quot response )
|
SYMBOL: 404-responder
|
||||||
<trivial-response>
|
|
||||||
rot "location" set-response-header ;
|
|
||||||
|
|
||||||
: <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> ;
|
301 "Moved Permanently" <redirect> ;
|
||||||
|
|
||||||
: <temporary-redirect> ( to -- quot response )
|
: <temporary-redirect> ( to -- response )
|
||||||
307 "Temporary Redirect" <redirect> ;
|
307 "Temporary Redirect" <redirect> ;
|
||||||
|
|
||||||
: <content> ( content-type -- response )
|
: <content> ( content-type -- response )
|
||||||
|
|
@ -52,66 +52,58 @@ M: trivial-responder do-responder
|
||||||
200 >>code
|
200 >>code
|
||||||
swap set-content-type ;
|
swap set-content-type ;
|
||||||
|
|
||||||
TUPLE: dispatcher responders default ;
|
TUPLE: dispatcher default responders ;
|
||||||
|
|
||||||
: responder-matches? ( path responder -- ? )
|
: get-responder ( name dispatcher -- responder )
|
||||||
path>> head? ;
|
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
|
: redirect-with-/ ( request -- response )
|
||||||
2drop
|
|
||||||
dup path>> "/" append >>path
|
dup path>> "/" append >>path
|
||||||
request-url <permanent-redirect> ;
|
request-url <permanent-redirect> ;
|
||||||
|
|
||||||
: <no-/-responder> ( -- responder )
|
M: dispatcher call-responder
|
||||||
"" <responder> no-/-responder construct-delegate ;
|
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 )
|
: add-responder ( dispatcher responder path -- dispatcher )
|
||||||
>r "/" ?head drop r>
|
pick responders>> set-at ;
|
||||||
[ 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: virtual-hosts
|
||||||
SYMBOL: default-host
|
SYMBOL: default-host
|
||||||
|
|
||||||
virtual-hosts global [ drop H{ } clone ] cache drop
|
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 )
|
: find-virtual-host ( host -- responder )
|
||||||
virtual-hosts get at [ default-host get ] unless* ;
|
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 -- )
|
: handle-request ( request -- )
|
||||||
[
|
[
|
||||||
dup path>> over host>> find-virtual-host
|
dup dup path>> over host>>
|
||||||
call-responder
|
find-virtual-host call-responder
|
||||||
write-response
|
] [ <500> ] recover
|
||||||
] keep method>> "HEAD" = [ drop ] [ call ] if ;
|
dup write-response
|
||||||
|
swap method>> "HEAD" =
|
||||||
|
[ drop ] [ write-response-body ] if ;
|
||||||
|
|
||||||
: default-timeout 1 minutes stdio get set-timeout ;
|
: default-timeout 1 minutes stdio get set-timeout ;
|
||||||
|
|
||||||
|
|
@ -120,12 +112,21 @@ LOG: httpd-hit NOTICE
|
||||||
: log-request ( request -- )
|
: log-request ( request -- )
|
||||||
{ method>> host>> path>> } map-exec-with httpd-hit ;
|
{ 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 -- )
|
: httpd ( port -- )
|
||||||
internet-server "http.server" [
|
internet-server "http.server" [ (httpd) ] with-server ;
|
||||||
default-timeout
|
|
||||||
read-request dup log-request handle-request
|
|
||||||
] with-server ;
|
|
||||||
|
|
||||||
: httpd-main ( -- ) 8888 httpd ;
|
: httpd-main ( -- ) 8888 httpd ;
|
||||||
|
|
||||||
MAIN: httpd-main
|
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
|
USING: continuations sequences kernel parser namespaces io
|
||||||
io.files io.streams.lines io.streams.string html html.elements
|
io.files io.streams.lines io.streams.string html html.elements
|
||||||
source-files debugger combinators math quotations generic
|
source-files debugger combinators math quotations generic
|
||||||
strings splitting ;
|
strings splitting accessors http.server.static http.server
|
||||||
|
assocs ;
|
||||||
|
|
||||||
IN: http.server.templating
|
IN: http.server.templating
|
||||||
|
|
||||||
|
|
@ -82,10 +83,10 @@ DEFER: <% delimiter
|
||||||
templating-vocab use+
|
templating-vocab use+
|
||||||
! so that reload works properly
|
! so that reload works properly
|
||||||
dup source-file file set
|
dup source-file file set
|
||||||
dup ?resource-path file-contents
|
?resource-path file-contents
|
||||||
[ eval-template ] [ html-error. drop ] recover
|
[ eval-template ] [ html-error. drop ] recover
|
||||||
] with-file-vocabs
|
] with-file-vocabs
|
||||||
] assert-depth drop ;
|
] curry assert-depth ;
|
||||||
|
|
||||||
: run-relative-template-file ( filename -- )
|
: run-relative-template-file ( filename -- )
|
||||||
file get source-file-path parent-directory
|
file get source-file-path parent-directory
|
||||||
|
|
@ -93,3 +94,13 @@ DEFER: <% delimiter
|
||||||
|
|
||||||
: template-convert ( infile outfile -- )
|
: template-convert ( infile outfile -- )
|
||||||
[ run-template-file ] with-file-writer ;
|
[ 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