From df2d921698590a4f29be3539bb27ba5476fbce0a Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Fri, 2 Dec 2005 16:30:23 +0000 Subject: [PATCH] Allow turning off logs and use it in the help-desk svn: r1495 --- collects/help/private/config.ss | 2 +- collects/web-server/configuration.ss | 119 +++++++++++++-------------- collects/web-server/dispatch-log.ss | 25 ++++-- 3 files changed, 76 insertions(+), 70 deletions(-) diff --git a/collects/help/private/config.ss b/collects/help/private/config.ss index 0552886212..68e8ce4dd0 100644 --- a/collects/help/private/config.ss +++ b/collects/help/private/config.ss @@ -36,7 +36,7 @@ (paths (configuration-root "conf") (host-root ,host-root) - (log-file-path "log") + (log-file-path #f) (file-root ,file-root) (servlet-root ,servlet-root) (password-authentication "passwords"))))]) diff --git a/collects/web-server/configuration.ss b/collects/web-server/configuration.ss index 4828c67198..a2dd9030d2 100644 --- a/collects/web-server/configuration.ss +++ b/collects/web-server/configuration.ss @@ -9,40 +9,38 @@ "response.ss") (require (lib "unitsig.ss") (lib "contract.ss")) - + (provide complete-configuration build-developer-configuration build-developer-configuration/vhosts ;; added 2/3/05 by Jacob default-configuration-table-path - update-configuration - ) - + update-configuration) + (provide/contract [load-configuration (path? . -> . unit/sig?)] [load-developer-configuration (path? . -> . unit/sig?)]) - - + (define default-configuration-table-path (build-path (collection-path "web-server") "configuration-table")) - + ; get-configuration : path -> configuration-table (define (get-configuration table-file-name) (parse-configuration-table (call-with-input-file table-file-name read))) - + ; load-configuration : path -> configuration (define (load-configuration table-file-name) (complete-configuration (directory-part table-file-name) (get-configuration table-file-name))) - + ; load-developer-configuration : path -> configuration (define (load-developer-configuration table-file-name) (complete-developer-configuration (directory-part table-file-name) (get-configuration table-file-name))) - + ; build-developer-configuration : tst -> configuration-table (define (build-developer-configuration s-expr) (complete-developer-configuration (directory-part default-configuration-table-path) (parse-configuration-table s-expr))) - + ;; added 2/3/05 by Jacob -- Help Desk needs to support virtual hosts ; build-developer-configuration/vhosts : tst -> configuration-table (define (build-developer-configuration/vhosts s-expr) @@ -76,7 +74,7 @@ (apply-default-functions-to-host-table base (cdr x)))) (configuration-table-virtual-hosts table))]) (gen-virtual-hosts expanded-virtual-host-table default-host)))) - + ; : str configuration-table -> configuration (define (complete-developer-configuration base table) (build-configuration @@ -84,7 +82,7 @@ (gen-virtual-hosts null (apply-default-functions-to-host-table base (configuration-table-default-host table))))) - + ; : configuration-table host-table -> configuration (define (build-configuration table the-virtual-hosts) (unit/sig web-config^ @@ -98,11 +96,11 @@ (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 to-be-copied-module-specs '(mzscheme ;; allow people (SamTH) to use MrEd primitives from servlets. @@ -110,8 +108,8 @@ ;; web-server-text to have a dependency on mred ;(lib "mred.ss" "mred") (lib "servlet.ss" "web-server"))) - - + + ; 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 @@ -120,7 +118,7 @@ ; ; 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 @@ -130,7 +128,7 @@ ((current-module-name-resolver) spec #f #f)))]) (map get-name to-be-copied-module-specs))) ; end stolen - + (define (the-make-servlet-namespace) (let ([server-namespace (current-namespace)] [new-namespace (make-namespace)]) @@ -138,7 +136,7 @@ (for-each (lambda (name) (namespace-attach-module server-namespace name)) to-be-copied-module-names) new-namespace))) - + ; : (listof (cons sym TST)) -> configuration ; more here - this is ugly. It also does not catch "unbound identifiers" since I use symbols. ; I considered several other solutions: @@ -147,20 +145,20 @@ ; - write three different functional updaters and re-compound the unit 1--3 times (define (update-configuration configuration flags) (compound-unit/sig - (import) - (link - [config : web-config^ (configuration)] - [new-config : web-config/local^ - ((unit/sig web-config/local^ - (import (raw : web-config/local^)) - (define port (extract-flag 'port flags raw:port)) - (define listen-ip (extract-flag 'ip-address flags raw:listen-ip)) - (define instances (extract-flag 'instances flags raw:instances)) - (define make-servlet-namespace (extract-flag 'namespace flags raw:make-servlet-namespace))) - (config : web-config/local^))]) - (export (open (config : web-config/pervasive^)) - (open (new-config : web-config/local^))))) - + (import) + (link + [config : web-config^ (configuration)] + [new-config : web-config/local^ + ((unit/sig web-config/local^ + (import (raw : web-config/local^)) + (define port (extract-flag 'port flags raw:port)) + (define listen-ip (extract-flag 'ip-address flags raw:listen-ip)) + (define instances (extract-flag 'instances flags raw:instances)) + (define make-servlet-namespace (extract-flag 'namespace flags raw:make-servlet-namespace))) + (config : web-config/local^))]) + (export (open (config : web-config/pervasive^)) + (open (new-config : web-config/local^))))) + ; 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 @@ -170,8 +168,7 @@ (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. @@ -182,12 +179,12 @@ '() ; 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) @@ -196,28 +193,28 @@ (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) @@ -227,17 +224,17 @@ (define (gen-collect-garbage-responder file) (lambda () (error-response 200 "Garbage collectedd" 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) @@ -259,17 +256,22 @@ (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 ([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-passwords 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-passwords paths)))))) + ; gen-virtual-hosts : (listof (list regexp host)) host -> ; str -> host-configuration (define (gen-virtual-hosts expanded-virtual-host-table default-host) @@ -278,7 +280,4 @@ (and (regexp-match (car x) host-name-possibly-followed-by-a-collon-and-a-port-number) (cadr x))) expanded-virtual-host-table) - default-host))) - - - ) + default-host)))) \ No newline at end of file diff --git a/collects/web-server/dispatch-log.ss b/collects/web-server/dispatch-log.ss index 917081f101..fd3e63083c 100644 --- a/collects/web-server/dispatch-log.ss +++ b/collects/web-server/dispatch-log.ss @@ -10,15 +10,22 @@ (define interface-version 'v1) (define (gen-dispatcher log-format log-path) - (let ([log-message (gen-log-message log-format log-path)]) - (lambda (conn req) - (let ([host (get-host (request-uri req) (request-headers req))]) - (log-message (request-host-ip req) - (request-client-ip req) - (request-method req) - (request-uri req) - host) - (next-dispatcher))))) + (if log-path + (case log-format + [(parenthesized-default) + (let ([log-message (gen-log-message log-format log-path)]) + (lambda (conn req) + (let ([host (get-host (request-uri req) (request-headers req))]) + (log-message (request-host-ip req) + (request-client-ip req) + (request-method req) + (request-uri req) + host) + (next-dispatcher))))] + [else + (lambda (conn req) (next-dispatcher))]) + (lambda (conn req) + (next-dispatcher)))) ; gen-log-message : sym str -> str str sym url str -> str ; XXX: check apache log configuration formats