Allow turning off logs and use it in the help-desk
svn: r1495
This commit is contained in:
Jay McCarthy
parent
78eca519ee
commit
df2d921698
|
|
@ -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"))))])
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user