diff --git a/collects/web-server/configuration.ss b/collects/web-server/configuration.ss index b48ff7c44f..8fc90ee7eb 100644 --- a/collects/web-server/configuration.ss +++ b/collects/web-server/configuration.ss @@ -90,4 +90,4 @@ [default-configuration-table-path path?] [update-configuration (configuration? (listof (cons/c symbol? any/c)) . -> . configuration?)] [load-configuration (path-string? . -> . configuration?)] - [load-developer-configuration (path-string? . -> . configuration?)])) + [load-developer-configuration (path-string? . -> . configuration?)])) \ No newline at end of file diff --git a/collects/web-server/configuration/responders.ss b/collects/web-server/configuration/responders.ss new file mode 100644 index 0000000000..427a3990e1 --- /dev/null +++ b/collects/web-server/configuration/responders.ss @@ -0,0 +1,89 @@ +(module responders mzscheme + (require (lib "contract.ss") + (lib "url.ss" "net")) + (require "../response-structs.ss") + + ; 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)))) + + ; servlet-loading-responder : 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. + (define (servlet-loading-responder url exn) + ((error-display-handler) + (format "Servlet didn't load:\n~a\n" (exn-message exn)) + exn) + (make-response/full 500 "Servlet didn't load" + (current-seconds) + TEXT/HTML-MIME-TYPE + '() ; check + (list "Servlet didn't load.\n"))) + + ; gen-servlet-not-found : str -> url -> response + (define (gen-servlet-not-found file-not-found-file) + (lambda (url) + (error-response 404 "Servlet not found" file-not-found-file))) + + ; gen-servlet-responder : str -> url tst -> response + (define (gen-servlet-responder servlet-error-file) + (lambda (url exn) + ; XXX use separate log file + ((error-display-handler) + (format "Servlet exception:\n~a\n" (exn-message exn)) + exn) + (error-response 500 "Servlet error" servlet-error-file))) + + ; gen-servlets-refreshed : str -> -> response + (define (gen-servlets-refreshed servlet-refresh-file) + (lambda () + (error-response 200 "Servlet cache refreshed" servlet-refresh-file))) + + ; gen-passwords-refreshed : str -> -> response + (define (gen-passwords-refreshed password-refresh-file) + (lambda () + (error-response 200 "Passwords refreshed" password-refresh-file))) + + ; gen-authentication-responder : str -> url (cons sym str) -> response + (define (gen-authentication-responder access-denied-file) + (lambda (uri recommended-header) + (error-response 401 "Authorization Required" access-denied-file + recommended-header))) + + ; gen-protocol-responder : str -> str -> response + (define (gen-protocol-responder protocol-file) + (lambda (error-message) + (error-response 400 "Malformed Request" protocol-file))) + + ; gen-file-not-found-responder : str -> url -> response + (define (gen-file-not-found-responder file-not-found-file) + (lambda (url) + (error-response 404 "File not found" file-not-found-file))) + + ; gen-collect-garbage-responder : str -> -> response + (define (gen-collect-garbage-responder file) + (lambda () + (error-response 200 "Garbage collected" file))) + + ; read-file : str -> str + (define (read-file path) + (call-with-input-file path + (lambda (in) (read-string (file-size path) in)))) + + (provide/contract + [error-response ((natural-number/c string? string?) (listof (cons/c symbol? string?)) . ->* . (response?))] + [servlet-loading-responder (string? any/c . -> . response?)] + [gen-servlet-not-found (path-string? . -> . (url? . -> . response?))] + [gen-servlet-responder (path-string? . -> . (url? any/c . -> . response?))] + [gen-servlets-refreshed (path-string? . -> . (-> response?))] + [gen-passwords-refreshed (path-string? . -> . (-> response?))] + [gen-authentication-responder (path-string? . -> . (url? (cons/c symbol? string?) . -> . response?))] + [gen-protocol-responder (path-string? . -> . (string? . -> . response?))] + [gen-file-not-found-responder (path-string? . -> . (url? . -> . response?))] + [gen-collect-garbage-responder (path-string? . -> . (-> response?))])) \ No newline at end of file diff --git a/collects/web-server/dispatchers/dispatch-files.ss b/collects/web-server/dispatchers/dispatch-files.ss index ffcf90850a..54ab37a8cf 100644 --- a/collects/web-server/dispatchers/dispatch-files.ss +++ b/collects/web-server/dispatchers/dispatch-files.ss @@ -8,7 +8,7 @@ (lib "contract.ss") (lib "uri-codec.ss" "net")) (require "dispatch.ss" - "../private/configuration.ss" + "../configuration/responders.ss" "../private/util.ss" "../private/mime-types.ss" "../request-structs.ss" diff --git a/collects/web-server/dispatchers/dispatch-passwords.ss b/collects/web-server/dispatchers/dispatch-passwords.ss index be1ab10240..6661b9e31f 100644 --- a/collects/web-server/dispatchers/dispatch-passwords.ss +++ b/collects/web-server/dispatchers/dispatch-passwords.ss @@ -3,7 +3,7 @@ (lib "contract.ss")) (require "dispatch.ss" "../private/util.ss" - "../private/configuration.ss" + "../configuration/responders.ss" "../request-structs.ss" "../servlet/basic-auth.ss" "../private/connection-manager.ss" diff --git a/collects/web-server/dispatchers/dispatch-servlets.ss b/collects/web-server/dispatchers/dispatch-servlets.ss index f964c74d3c..0e1002c0be 100644 --- a/collects/web-server/dispatchers/dispatch-servlets.ss +++ b/collects/web-server/dispatchers/dispatch-servlets.ss @@ -13,7 +13,7 @@ "../response-structs.ss" "../servlet/web-cells.ss" "../servlet/web.ss" - "../private/configuration.ss" + "../configuration/responders.ss" "../private/util.ss" "../managers/manager.ss" "../managers/timeouts.ss" diff --git a/collects/web-server/private/configuration-structures.ss b/collects/web-server/private/configuration-structures.ss index e2c95d6089..ef6bef1711 100644 --- a/collects/web-server/private/configuration-structures.ss +++ b/collects/web-server/private/configuration-structures.ss @@ -48,4 +48,4 @@ [passwords-refreshed (-> response?)] [file-not-found (url? . -> . response?)] [protocol (url? . -> . response?)] - [collect-garbage (-> response?)])])) + [collect-garbage (-> response?)])])) \ No newline at end of file diff --git a/collects/web-server/private/configuration.ss b/collects/web-server/private/configuration.ss index 333c96485f..8dcc75d4c3 100644 --- a/collects/web-server/private/configuration.ss +++ b/collects/web-server/private/configuration.ss @@ -2,15 +2,13 @@ (require (lib "unit.ss") (lib "kw.ss") (lib "list.ss") - (lib "etc.ss") - (lib "contract.ss") - (lib "url.ss" "net")) + (lib "contract.ss")) (require "configuration-structures.ss" "configuration-table-structs.ss" "util.ss" "cache-table.ss" - "../web-config-sig.ss" - "../response-structs.ss") + "../configuration/responders.ss" + "../web-config-sig.ss") ; : str configuration-table -> configuration (define (complete-configuration base table) @@ -100,85 +98,7 @@ new-namespace))) (define default-make-servlet-namespace (make-make-servlet-namespace)) - - ; 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)))) - - ; servlet-loading-responder : 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. - (define (servlet-loading-responder url exn) - ((error-display-handler) - (format "Servlet didn't load:\n~a\n" (exn-message exn)) - exn) - (make-response/full 500 "Servlet didn't load" - (current-seconds) - TEXT/HTML-MIME-TYPE - '() ; check - (list "Servlet didn't load.\n"))) - - ; gen-servlet-not-found : str -> url -> response - (define (gen-servlet-not-found file-not-found-file) - (lambda (url) - (error-response 404 "Servlet not found" file-not-found-file))) - - ; gen-servlet-responder : str -> url tst -> response - (define (gen-servlet-responder servlet-error-file) - (lambda (url exn) - ; XXX use separate log file - ((error-display-handler) - (format "Servlet exception:\n~a\n" (exn-message exn)) - exn) - (error-response 500 "Servlet error" servlet-error-file))) - - ; gen-servlets-refreshed : str -> -> response - (define (gen-servlets-refreshed servlet-refresh-file) - (lambda () - (error-response 200 "Servlet cache refreshed" servlet-refresh-file))) - - ; gen-passwords-refreshed : str -> -> response - (define (gen-passwords-refreshed password-refresh-file) - (lambda () - (error-response 200 "Passwords refreshed" password-refresh-file))) - - ; gen-authentication-responder : str -> url (cons sym str) -> response - (define (gen-authentication-responder access-denied-file) - (lambda (uri recommended-header) - (error-response 401 "Authorization Required" access-denied-file - recommended-header))) - - ; gen-protocol-responder : str -> str -> response - (define (gen-protocol-responder protocol-file) - (lambda (error-message) - (error-response 400 "Malformed Request" protocol-file))) - - ; gen-file-not-found-responder : str -> url -> response - (define (gen-file-not-found-responder file-not-found-file) - (lambda (url) - (error-response 404 "File not found" file-not-found-file))) - - ; gen-collect-garbage-responder : str -> -> response - (define (gen-collect-garbage-responder file) - (lambda () - (error-response 200 "Garbage collected" file))) - - (define servlet? - (let ([servlets-regexp (regexp "^/servlets/.*")]) - (lambda (str) - (regexp-match servlets-regexp str)))) - - ; read-file : str -> str - (define (read-file path) - (call-with-input-file path - (lambda (in) (read-string (file-size path) in)))) - + ; apply-default-functions-to-host-table : str host-table -> host ;; Greg P: web-server-root is the directory-part of the path to the configuration-table (I don't think I like this.) (define (apply-default-functions-to-host-table web-server-root host-table) @@ -233,15 +153,4 @@ make-make-servlet-namespace) (provide/contract [complete-configuration (path-string? configuration-table? . -> . configuration?)] - [complete-developer-configuration (path-string? configuration-table? . -> . configuration?)]) - (provide/contract - [error-response ((natural-number/c string? string?) (listof (cons/c symbol? string?)) . ->* . (response?))] - [servlet-loading-responder (string? any/c . -> . response?)] - [gen-servlet-not-found (path-string? . -> . (url? . -> . response?))] - [gen-servlet-responder (path-string? . -> . (url? any/c . -> . response?))] - [gen-servlets-refreshed (path-string? . -> . (-> response?))] - [gen-passwords-refreshed (path-string? . -> . (-> response?))] - [gen-authentication-responder (path-string? . -> . (url? (cons/c symbol? string?) . -> . response?))] - [gen-protocol-responder (path-string? . -> . (string? . -> . response?))] - [gen-file-not-found-responder (path-string? . -> . (url? . -> . response?))] - [gen-collect-garbage-responder (path-string? . -> . (-> response?))])) \ No newline at end of file + [complete-developer-configuration (path-string? configuration-table? . -> . configuration?)])) \ No newline at end of file diff --git a/collects/web-server/private/setup-launch.ss b/collects/web-server/private/setup-launch.ss index 29f91ba2c2..7618cebd06 100644 --- a/collects/web-server/private/setup-launch.ss +++ b/collects/web-server/private/setup-launch.ss @@ -38,4 +38,4 @@ (get-configuration default-configuration-table-path) [configuration-table-port port]) (build-path dest "configuration-table")))) - '())) + '())) \ No newline at end of file diff --git a/collects/web-server/prototype-web-server/dispatch-servlets2.ss b/collects/web-server/prototype-web-server/dispatch-servlets2.ss index 89c7bfeeb2..bd2a2d804f 100644 --- a/collects/web-server/prototype-web-server/dispatch-servlets2.ss +++ b/collects/web-server/prototype-web-server/dispatch-servlets2.ss @@ -13,6 +13,7 @@ "../private/util.ss" "../private/response.ss" "../private/configuration.ss" + "../configuration/responders.ss" "private/utils.ss") (provide/contract diff --git a/collects/web-server/prototype-web-server/run.ss b/collects/web-server/prototype-web-server/run.ss index 29d633a22a..2f5937629f 100644 --- a/collects/web-server/prototype-web-server/run.ss +++ b/collects/web-server/prototype-web-server/run.ss @@ -1,6 +1,6 @@ (module run mzscheme (require (lib "web-server.ss" "web-server") - (lib "configuration.ss" "web-server" "private") + (lib "responders.ss" "web-server" "configuration") (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"))