From 9b494f9d1b3e94bb1742f1b72cc76e14e25494a3 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 28 May 2007 18:11:26 +0000 Subject: [PATCH] Removing hardcoded configuration svn: r6359 --- .../hardcoded-configuration.ss | 136 ------------------ .../prototype-web-server/private/utils.ss | 4 +- .../web-server/prototype-web-server/run.ss | 65 +++++++-- 3 files changed, 54 insertions(+), 151 deletions(-) delete mode 100644 collects/web-server/prototype-web-server/hardcoded-configuration.ss diff --git a/collects/web-server/prototype-web-server/hardcoded-configuration.ss b/collects/web-server/prototype-web-server/hardcoded-configuration.ss deleted file mode 100644 index be1ea251d4..0000000000 --- a/collects/web-server/prototype-web-server/hardcoded-configuration.ss +++ /dev/null @@ -1,136 +0,0 @@ -(module hardcoded-configuration mzscheme - (require (lib "configuration-structures.ss" "web-server" "private") - (lib "util.ss" "web-server" "private") - (lib "response.ss" "web-server") - (lib "dirs.ss" "setup")) - - (provide hardcoded-host) - - ;; ************************************************************ - ;; HARDCODED HOST - - ; error-response : nat str str [(cons sym str) ...] -> response - ; more here - cache files with a refresh option. - ; The server should still start without the files there, so the - ; configuration tool still runs. (Alternatively, find an work around.) - (define (error-response code short text-file . extra-headers) - (make-response/full code short - (current-seconds) TEXT/HTML-MIME-TYPE - extra-headers - (list (read-file text-file)))) - - ; read-file : str -> str - (define (read-file path) - (call-with-input-file path - (lambda (in) (read-string (file-size path) in)))) - - ;; error files: - (define server-root-path (build-path "~" "Development" "plt" "default-web-root")) - (define default-host-path (build-path server-root-path "conf")) - - (define servlet-error-file (build-path default-host-path "servlet-error.html")) - (define access-denied-file (build-path default-host-path "forbidden.html")) - (define servlet-refresh-file (build-path default-host-path "servlet-refresh.html")) - (define password-refresh-file (build-path default-host-path "passwords-refresh.html")) - (define file-not-found-file (build-path default-host-path "not-found.html")) - (define protocol-file (build-path default-host-path "protocol-error.html")) - (define collect-garbage-file (build-path default-host-path "collect-garbage.html")) - - (define hardcoded-host - ; host = (make-host (listof str) (str str sym url str -> str) - ; passwords resopnders timeouts paths) - (make-host - - ;; indices - (list "index.html" "index.htm") - - ;; log-format - 'none - - ;; log-message - "log" - - ;; passwords - "passwords" - - (make-responders - - ;; servlet: url tst -> response - (lambda (url exn) - ; more here - use separate log file - ;(printf "Servlet exception:\n~s\n" (exn-message exn)) - ((error-display-handler) - (format "Servlet exception:\n~a\n" (exn-message exn)) - exn) - (error-response 500 "Servlet error" servlet-error-file)) - - ;; servlet-loading: url tst -> response - ; more here - parameterize error based on a configurable file, perhaps? - ; This is slightly tricky since the (interesting) content comes from the exception. - (lambda (url exn) - ((error-display-handler) - (format "Servlet loading exception:\n~a\n" (exn-message exn)) - exn) - (make-response/full 500 "Servlet didn't load" - (current-seconds) - #"text/plain" ;TEXT/HTML-MIME-TYPE - '() ; check - (list "Servlet didn't load.\n" - (exn->string exn)))) - - ;; authentication: url (cons sym str) -> response - (lambda (uri recommended-header) - (error-response 401 "Authorization Required" access-denied-file - recommended-header)) - - ;; servlets-refreshed: -> response - (lambda () - (error-response 200 "Servlet cache refreshed" servlet-refresh-file)) - - ;; passwords-refreshed: -> response - (lambda () - (error-response 200 "Passwords refreshed" password-refresh-file)) - - ;; file-not-found: url->response - (lambda (url) - (error-response 404 "File not found" file-not-found-file)) - - ;; protocol: string -> response - (lambda (error-message) - (error-response 400 "Malformed Request" protocol-file)) - - ;; collect-garbage: -> response - (lambda () - (error-response 200 "Collected Garbage" collect-garbage-file)) - - ) - - ; timeouts = (make-timeouts nat^5) - (make-timeouts - ; default-servlet-timeout - 60 - ;password-connection-timeout - 300 - ; servlet-connection-timeout - 86400 - ; file-per-byte-connection-timeout - 1/20 - ; file-base-connection-timeout - 30) - - ; paths = (make-paths str^6) - (make-paths - ; configuration-root - (build-path server-root-path "conf") - ; host-root - (build-path server-root-path "default-web-root") - ; log-file-path - "log" - ; file-root - (build-path server-root-path "htdocs") - ; servlet-root - (build-path (find-collects-dir) "web-server" "prototype-web-server") - ; mime-types - (build-path server-root-path "mime.types") - ; password-authentication - (build-path server-root-path "passwords"))))) \ No newline at end of file diff --git a/collects/web-server/prototype-web-server/private/utils.ss b/collects/web-server/prototype-web-server/private/utils.ss index 77635cb835..39dad04b5d 100644 --- a/collects/web-server/prototype-web-server/private/utils.ss +++ b/collects/web-server/prototype-web-server/private/utils.ss @@ -76,12 +76,12 @@ ;; The second value is the prefix of the url-path used to find the servlet. ;; The third value is the remaining suffix of the url-path. (define (url->servlet-path servlet-dir uri) - (printf "~S~n" `(url->servlet-path ,servlet-dir ,uri)) + #;(printf "~S~n" `(url->servlet-path ,servlet-dir ,uri)) #;(printf " current-directory = ~s~n" (current-directory)) (let loop ([base-path servlet-dir] [servlet-path '()] [path-list (simplify-url-path uri)]) - (printf "~S~n" `(loop ,base-path ,servlet-path ,path-list)) + #;(printf "~S~n" `(loop ,base-path ,servlet-path ,path-list)) (if (null? path-list) (values #f #f #f) diff --git a/collects/web-server/prototype-web-server/run.ss b/collects/web-server/prototype-web-server/run.ss index cee128c75e..e009e63d2a 100644 --- a/collects/web-server/prototype-web-server/run.ss +++ b/collects/web-server/prototype-web-server/run.ss @@ -3,33 +3,72 @@ (lib "tcp-sig.ss" "net")) (require (lib "dispatch-server-sig.ss" "web-server" "private") (lib "dispatch-server-unit.ss" "web-server" "private") + (lib "response.ss" "web-server") + (lib "util.ss" "web-server" "private") (prefix http: (lib "request.ss" "web-server" "private")) - (lib "configuration-structures.ss" "web-server" "private") (prefix files: (lib "dispatch-files.ss" "web-server" "dispatchers")) (prefix filter: (lib "dispatch-filter.ss" "web-server" "dispatchers")) - (prefix sequencer: (lib "dispatch-sequencer.ss" "web-server" "dispatchers"))) - (require "hardcoded-configuration.ss" + (prefix sequencer: (lib "dispatch-sequencer.ss" "web-server" "dispatchers")) (prefix servlets2: "dispatch-servlets2.ss")) + ; error-response : nat str str [(cons sym str) ...] -> response + (define (error-response code short text-file . extra-headers) + (make-response/full code short + (current-seconds) TEXT/HTML-MIME-TYPE + extra-headers + (list (read-file text-file)))) + + ; read-file : str -> str + (define (read-file path) + (call-with-input-file path + (lambda (in) (read-string (file-size path) in)))) + (define port 8080) (define listen-ip #f) (define max-waiting 40) (define initial-connection-timeout 60) - (define host-info hardcoded-host) (define read-request http:read-request) + + (define server-root-path (build-path "~" "Development" "plt" "default-web-root")) + (define default-host-path (build-path server-root-path "conf")) + (define htdocs-path (build-path server-root-path "htdocs")) + (define file-not-found-file (build-path default-host-path "not-found.html")) + (define servlet-error-file (build-path default-host-path "servlet-error.html")) + + (define responders-file-not-found + (lambda (url) + (error-response 404 "File not found" file-not-found-file))) + (define responders-servlet + (lambda (url exn) + ((error-display-handler) + (format "Servlet exception:\n~a\n" (exn-message exn)) + exn) + (error-response 500 "Servlet error" servlet-error-file))) + (define responders-servlet-loading + (lambda (url exn) + ((error-display-handler) + (format "Servlet loading exception:\n~a\n" (exn-message exn)) + exn) + (make-response/full 500 "Servlet didn't load" + (current-seconds) + #"text/plain" + '() + (list "Servlet didn't load.\n" + (exn->string exn))))) + (define dispatch (sequencer:make (filter:make #rx"\\.ss$" - (servlets2:make #:htdocs-path (paths-htdocs (host-paths host-info)) - #:timeouts-servlet-connection (timeouts-servlet-connection (host-timeouts host-info)) - #:responders-servlet-loading (responders-servlet-loading (host-responders host-info)) - #:responders-servlet (responders-servlet (host-responders host-info)) - #:responders-file-not-found (responders-file-not-found (host-responders host-info)))) - (files:make #:htdocs-path (paths-htdocs (host-paths host-info)) - #:mime-types-path (paths-mime-types (host-paths host-info)) - #:indices (host-indices host-info) - #:file-not-found-responder (responders-file-not-found (host-responders host-info))))) + (servlets2:make #:htdocs-path htdocs-path + #:timeouts-servlet-connection 86400 + #:responders-servlet-loading responders-servlet-loading + #:responders-servlet responders-servlet + #:responders-file-not-found responders-file-not-found)) + (files:make #:htdocs-path htdocs-path + #:mime-types-path (build-path server-root-path "mime.types") + #:indices (list "index.html" "index.htm") + #:file-not-found-responder responders-file-not-found))) (define-values/invoke-unit dispatch-server@