http.server cleanups
Slava Pestov
parent
e1ace82429
commit
253a4b660d
|
|
@ -2,7 +2,7 @@
|
|||
! 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 ;
|
||||
http.server.responders io html.elements ;
|
||||
IN: http.basic-authentication
|
||||
|
||||
! 'realms' is a hashtable mapping a realm (a string) to
|
||||
|
|
@ -49,18 +49,17 @@ SYMBOL: realms
|
|||
] [
|
||||
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" get at authorization-ok? [
|
||||
nip call
|
||||
] [
|
||||
drop "Basic realm=\"" swap "\"" 3append "WWW-Authenticate" associate
|
||||
"401 Unauthorized" response nl
|
||||
"<html><body>Username or Password is invalid</body></html>" write
|
||||
] if ;
|
||||
|
||||
|
||||
|
||||
over "Authorization" header-param authorization-ok?
|
||||
[ nip call ] [ drop authentication-error ] if ;
|
||||
|
|
|
|||
|
|
@ -14,21 +14,22 @@ IN: http.server.responders.file
|
|||
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 "200 OK" response nl ;
|
||||
] H{ } make-assoc print-header ;
|
||||
|
||||
: last-modified-matches? ( filename -- bool )
|
||||
file-http-date dup [
|
||||
"If-Modified-Since" "header" get at =
|
||||
"If-Modified-Since" header-param =
|
||||
] when ;
|
||||
|
||||
: not-modified-response ( -- )
|
||||
now timestamp>http-string "Date" associate
|
||||
"304 Not Modified" response nl ;
|
||||
"304 Not Modified" response
|
||||
now timestamp>http-string "Date" associate print-header ;
|
||||
|
||||
: serve-static ( filename mime-type -- )
|
||||
over last-modified-matches? [
|
||||
|
|
|
|||
|
|
@ -11,22 +11,22 @@ SYMBOL: vhosts
|
|||
SYMBOL: responders
|
||||
|
||||
: print-header ( alist -- )
|
||||
[ swap write ": " write print ] assoc-each ;
|
||||
[ swap write ": " write print ] assoc-each nl ;
|
||||
|
||||
: response ( header msg -- )
|
||||
"HTTP/1.0 " write print print-header ;
|
||||
: response ( msg -- ) "HTTP/1.0 " write print ;
|
||||
|
||||
: error-body ( error -- )
|
||||
<html> <body> <h1> write </h1> </body> </html> ;
|
||||
|
||||
: error-head ( error -- )
|
||||
dup log-error
|
||||
H{ { "Content-Type" "text/html" } } swap response ;
|
||||
dup response
|
||||
H{ { "Content-Type" "text/html" } } print-header nl ;
|
||||
|
||||
: httpd-error ( error -- )
|
||||
#! This must be run from handle-request
|
||||
dup error-head
|
||||
"head" "method" get = [ drop ] [ nl error-body ] if ;
|
||||
"head" "method" get = [ drop ] [ error-body ] if ;
|
||||
|
||||
: bad-request ( -- )
|
||||
[
|
||||
|
|
@ -36,8 +36,8 @@ SYMBOL: responders
|
|||
] with-scope ;
|
||||
|
||||
: serving-content ( mime -- )
|
||||
"Content-Type" associate
|
||||
"200 Document follows" response nl ;
|
||||
"200 Document follows" response
|
||||
"Content-Type" associate print-header ;
|
||||
|
||||
: serving-html "text/html" serving-content ;
|
||||
|
||||
|
|
@ -46,14 +46,14 @@ SYMBOL: responders
|
|||
|
||||
: serving-text "text/plain" serving-content ;
|
||||
|
||||
: (redirect) ( to response -- )
|
||||
>r "Location" associate r> response nl ;
|
||||
: redirect ( to response -- )
|
||||
response "Location" associate print-header ;
|
||||
|
||||
: permanent-redirect ( to -- )
|
||||
"301 Moved Permanently" (redirect) ;
|
||||
"301 Moved Permanently" redirect ;
|
||||
|
||||
: temporary-redirect ( to -- )
|
||||
"307 Temporary Redirect" (redirect) ;
|
||||
"307 Temporary Redirect" redirect ;
|
||||
|
||||
: directory-no/ ( -- )
|
||||
[
|
||||
|
|
@ -123,6 +123,8 @@ SYMBOL: max-post-request
|
|||
|
||||
: query-param ( key -- value ) "query" get at ;
|
||||
|
||||
: header-param ( key -- value ) "header" get at ;
|
||||
|
||||
: add-responder ( responder -- )
|
||||
#! Add a responder object to the list.
|
||||
"responder" over at responders get set-at ;
|
||||
|
|
|
|||
|
|
@ -32,7 +32,7 @@ IN: http.server
|
|||
|
||||
: host ( -- string )
|
||||
#! The host the current responder was called from.
|
||||
"Host" "header" get at ":" split1 drop ;
|
||||
"Host" header-param ":" split1 drop ;
|
||||
|
||||
: (handle-request) ( arg cmd -- method path host )
|
||||
request-method dup "method" set swap
|
||||
|
|
|
|||
Loading…
Reference in New Issue