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

http.server cleanups

release
Slava Pestov 2007-11-12 23:18:56 -05:00
parent e1ace82429
commit 253a4b660d
4 changed files with 30 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
extra/http/basic-authentication/basic-authentication.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel base64 http.server crypto.sha2 namespaces assocs USING: kernel base64 http.server crypto.sha2 namespaces assocs
quotations hashtables combinators splitting sequences quotations hashtables combinators splitting sequences
http.server.responders io ; http.server.responders io html.elements ;
IN: http.basic-authentication IN: http.basic-authentication
! 'realms' is a hashtable mapping a realm (a string) to ! 'realms' is a hashtable mapping a realm (a string) to
@ -50,17 +50,16 @@ SYMBOL: realms
2drop f 2drop f
] if ; ] 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 -- ) : with-basic-authentication ( realm quot -- )
#! Check if the user is authenticated in the given realm #! Check if the user is authenticated in the given realm
#! to run the specified quotation. If not, use Basic #! to run the specified quotation. If not, use Basic
#! Authentication to ask for authorization details. #! Authentication to ask for authorization details.
over "Authorization" "header" get at authorization-ok? [ over "Authorization" header-param authorization-ok?
nip call [ nip call ] [ drop authentication-error ] if ;
] [
drop "Basic realm=\"" swap "\"" 3append "WWW-Authenticate" associate
"401 Unauthorized" response nl
"<html><body>Username or Password is invalid</body></html>" write
] if ;

9
extra/http/server/responders/file/file.factor
View File

@ -14,21 +14,22 @@ IN: http.server.responders.file
file-modified unix-time>timestamp timestamp>http-string ; file-modified unix-time>timestamp timestamp>http-string ;
: file-response ( filename mime-type -- ) : file-response ( filename mime-type -- )
"200 OK" response
[ [
"Content-Type" set "Content-Type" set
dup file-length number>string "Content-Length" set dup file-length number>string "Content-Length" set
file-http-date "Last-Modified" set file-http-date "Last-Modified" set
now timestamp>http-string "Date" set now timestamp>http-string "Date" set
] H{ } make-assoc "200 OK" response nl ; ] H{ } make-assoc print-header ;
: last-modified-matches? ( filename -- bool ) : last-modified-matches? ( filename -- bool )
file-http-date dup [ file-http-date dup [
"If-Modified-Since" "header" get at = "If-Modified-Since" header-param =
] when ; ] when ;
: not-modified-response ( -- ) : not-modified-response ( -- )
now timestamp>http-string "Date" associate "304 Not Modified" response
"304 Not Modified" response nl ; now timestamp>http-string "Date" associate print-header ;
: serve-static ( filename mime-type -- ) : serve-static ( filename mime-type -- )
over last-modified-matches? [ over last-modified-matches? [

24
extra/http/server/responders/responders.factor
View File

@ -11,22 +11,22 @@ SYMBOL: vhosts
SYMBOL: responders SYMBOL: responders
: print-header ( alist -- ) : print-header ( alist -- )
[ swap write ": " write print ] assoc-each ; [ swap write ": " write print ] assoc-each nl ;
: response ( header msg -- ) : response ( msg -- ) "HTTP/1.0 " write print ;
"HTTP/1.0 " write print print-header ;
: error-body ( error -- ) : error-body ( error -- )
<html> <body> <h1> write </h1> </body> </html> ; <html> <body> <h1> write </h1> </body> </html> ;
: error-head ( error -- ) : error-head ( error -- )
dup log-error dup log-error
H{ { "Content-Type" "text/html" } } swap response ; dup response
H{ { "Content-Type" "text/html" } } print-header nl ;
: httpd-error ( error -- ) : httpd-error ( error -- )
#! This must be run from handle-request #! This must be run from handle-request
dup error-head dup error-head
"head" "method" get = [ drop ] [ nl error-body ] if ; "head" "method" get = [ drop ] [ error-body ] if ;
: bad-request ( -- ) : bad-request ( -- )
[ [
@ -36,8 +36,8 @@ SYMBOL: responders
] with-scope ; ] with-scope ;
: serving-content ( mime -- ) : serving-content ( mime -- )
"Content-Type" associate "200 Document follows" response
"200 Document follows" response nl ; "Content-Type" associate print-header ;
: serving-html "text/html" serving-content ; : serving-html "text/html" serving-content ;
@ -46,14 +46,14 @@ SYMBOL: responders
: serving-text "text/plain" serving-content ; : serving-text "text/plain" serving-content ;
: (redirect) ( to response -- ) : redirect ( to response -- )
>r "Location" associate r> response nl ; response "Location" associate print-header ;
: permanent-redirect ( to -- ) : permanent-redirect ( to -- )
"301 Moved Permanently" (redirect) ; "301 Moved Permanently" redirect ;
: temporary-redirect ( to -- ) : temporary-redirect ( to -- )
"307 Temporary Redirect" (redirect) ; "307 Temporary Redirect" redirect ;
: directory-no/ ( -- ) : directory-no/ ( -- )
[ [
@ -123,6 +123,8 @@ SYMBOL: max-post-request
: query-param ( key -- value ) "query" get at ; : query-param ( key -- value ) "query" get at ;
: header-param ( key -- value ) "header" get at ;
: add-responder ( responder -- ) : add-responder ( responder -- )
#! Add a responder object to the list. #! Add a responder object to the list.
"responder" over at responders get set-at ; "responder" over at responders get set-at ;

2
extra/http/server/server.factor
View File

@ -32,7 +32,7 @@ IN: http.server
: host ( -- string ) : host ( -- string )
#! The host the current responder was called from. #! 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 ) : (handle-request) ( arg cmd -- method path host )
request-method dup "method" set swap request-method dup "method" set swap