From 253a4b660d4a66dd2ab94b1922586386437c8796 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 12 Nov 2007 23:18:56 -0500 Subject: [PATCH] http.server cleanups --- .../basic-authentication.factor | 23 +++++++++--------- extra/http/server/responders/file/file.factor | 9 +++---- .../http/server/responders/responders.factor | 24 ++++++++++--------- extra/http/server/server.factor | 2 +- 4 files changed, 30 insertions(+), 28 deletions(-) diff --git a/extra/http/basic-authentication/basic-authentication.factor b/extra/http/basic-authentication/basic-authentication.factor index 040cb215fa..e15ba9db16 100644 --- a/extra/http/basic-authentication/basic-authentication.factor +++ b/extra/http/basic-authentication/basic-authentication.factor @@ -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 + + "Username or Password is invalid" write + ; + : 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 - "Username or Password is invalid" write - ] if ; - - - + over "Authorization" header-param authorization-ok? + [ nip call ] [ drop authentication-error ] if ; diff --git a/extra/http/server/responders/file/file.factor b/extra/http/server/responders/file/file.factor index 4f83e8fa98..2f743b932d 100644 --- a/extra/http/server/responders/file/file.factor +++ b/extra/http/server/responders/file/file.factor @@ -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? [ diff --git a/extra/http/server/responders/responders.factor b/extra/http/server/responders/responders.factor index aadf513aea..594454979a 100644 --- a/extra/http/server/responders/responders.factor +++ b/extra/http/server/responders/responders.factor @@ -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 -- )

write

; : 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 ; diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index a6903a37f7..63a742589a 100644 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -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