(module configuration mzscheme (require (lib "unit.ss") (lib "kw.ss") (lib "list.ss") (lib "contract.ss")) (require "configuration-structures.ss" "configuration-table-structs.ss" "util.ss" "cache-table.ss" "../sig.ss" "../response-structs.ss") ; : str configuration-table -> configuration (define (complete-configuration base table) (build-configuration table (let ([default-host (apply-default-functions-to-host-table base (configuration-table-default-host table))] [expanded-virtual-host-table (map (lambda (x) (list (regexp (string-append (car x) "(:[0-9]*)?")) (apply-default-functions-to-host-table base (cdr x)))) (configuration-table-virtual-hosts table))]) (gen-virtual-hosts expanded-virtual-host-table default-host)))) ; complete-developer-configuration : str configuration-table -> configuration (define (complete-developer-configuration base table) (build-configuration table (gen-virtual-hosts null (apply-default-functions-to-host-table base (configuration-table-default-host table))))) ; : configuration-table host-table -> configuration (define/kw (build-configuration table the-virtual-hosts #:key [make-servlet-namespace default-make-servlet-namespace]) (define the-make-servlet-namespace make-servlet-namespace) (unit (import) (export web-config^) (define port (configuration-table-port table)) (define max-waiting (configuration-table-max-waiting table)) (define listen-ip #f) ; more here - add to configuration table (define initial-connection-timeout (configuration-table-initial-connection-timeout table)) (define virtual-hosts the-virtual-hosts) (define access (make-hash-table)) (define instances (make-hash-table)) (define scripts (box (make-cache-table))) (define make-servlet-namespace the-make-servlet-namespace))) ; begin stolen from commander.ss, which was stolen from private/drscheme/eval.ss ; FIX - abstract this out to a namespace library somewhere (ask Robby and Matthew) (define default-to-be-copied-module-specs '(mzscheme ;; allow people (SamTH) to use MrEd primitives from servlets. ;; GregP: putting mred.ss here is a bad idea because it will cause ;; web-server-text to have a dependency on mred ;; JM: We get around it by only doing it if the module is already attached. (lib "mred.ss" "mred") (lib "servlet.ss" "web-server"))) ; end stolen (define/kw (make-make-servlet-namespace #:key [to-be-copied-module-specs empty]) ; JBC : added error-handler hack; the right answer is only to transfer the 'mred' ; module binding when asked to, e.g. by a field in the configuration file. ; GregP: put this back in if Sam's code breaks ; (for-each (lambda (x) (with-handlers ([exn:fail? (lambda (exn) 'dont-care)]) ; ; dynamic-require will fail when running web-server-text. ; ; maybe a warning message in the exception-handler? ; (dynamic-require x #f))) ; to-be-copied-module-specs) ;; get the names of those modules. (define to-be-copied-module-names (let ([get-name (lambda (spec) (if (symbol? spec) spec ((current-module-name-resolver) spec #f #f)))]) (map get-name (append default-to-be-copied-module-specs to-be-copied-module-specs)))) ;end stolen (lambda () (define server-namespace (current-namespace)) (define new-namespace (make-namespace)) (parameterize ([current-namespace new-namespace]) (for-each (lambda (name) (with-handlers ([exn? void]) (namespace-attach-module server-namespace name))) to-be-copied-module-names) 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) (make-response/full 500 "Servlet didn't load" (current-seconds) TEXT/HTML-MIME-TYPE '() ; check (list "Servlet didn't load.\n" (exn->string exn)))) ; 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) (let ([paths (expand-paths web-server-root (host-table-paths host-table))]) (make-host (host-table-indices host-table) (host-table-log-format host-table) (paths-log paths) (paths-passwords paths) (let ([m (host-table-messages host-table)] [conf (paths-conf paths)]) (make-responders (gen-servlet-responder (build-path-unless-absolute conf (messages-servlet m))) servlet-loading-responder (gen-authentication-responder (build-path-unless-absolute conf (messages-authentication m))) (gen-servlets-refreshed (build-path-unless-absolute conf (messages-servlets-refreshed m))) (gen-passwords-refreshed (build-path-unless-absolute conf (messages-passwords-refreshed m))) (gen-file-not-found-responder (build-path-unless-absolute conf (messages-file-not-found m))) (gen-protocol-responder (build-path-unless-absolute conf (messages-protocol m))) (gen-collect-garbage-responder (build-path-unless-absolute conf (messages-collect-garbage m))))) (host-table-timeouts host-table) paths))) ; expand-paths : str paths -> paths (define (expand-paths web-server-root paths) (let ([build-path-unless-absolute (lambda (b p) (if p (build-path-unless-absolute b p) #f))]) (let ([host-base (build-path-unless-absolute web-server-root (paths-host-base paths))]) (make-paths (build-path-unless-absolute host-base (paths-conf paths)) host-base (build-path-unless-absolute host-base (paths-log paths)) (build-path-unless-absolute host-base (paths-htdocs paths)) (build-path-unless-absolute host-base (paths-servlet paths)) (build-path-unless-absolute host-base (paths-mime-types paths)) (build-path-unless-absolute host-base (paths-passwords paths)))))) ; gen-virtual-hosts : (listof (list regexp host)) host -> ; str -> host-configuration (define (gen-virtual-hosts expanded-virtual-host-table default-host) (lambda (host-name-possibly-followed-by-a-collon-and-a-port-number) (or (ormap (lambda (x) (and (regexp-match (car x) host-name-possibly-followed-by-a-collon-and-a-port-number) (cadr x))) expanded-virtual-host-table) default-host))) (provide ; XXX contract build-configuration apply-default-functions-to-host-table 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?))] ; XXX contract [servlet-loading-responder (string? any/c . -> . response?)] [gen-servlet-not-found (string? . -> . (string? . -> . response?))] [gen-servlet-responder (string? . -> . (string? any/c . -> . response?))] [gen-servlets-refreshed (string? . -> . (-> response?))] [gen-passwords-refreshed (string? . -> . (-> response?))] [gen-authentication-responder (string? . -> . (string? (cons/c symbol? string?) . -> . response?))] [gen-protocol-responder (string? . -> . (string? . -> . response?))] [gen-file-not-found-responder (string? . -> . (string? . -> . response?))] [gen-collect-garbage-responder (string? . -> . (-> response?))]))