289 lines
13 KiB
Scheme
289 lines
13 KiB
Scheme
; configuration language example
|
|
(module configuration mzscheme
|
|
(require "configuration-structures.ss"
|
|
"configuration-table-structs.ss"
|
|
"sig.ss"
|
|
"util.ss"
|
|
"parse-table.ss"
|
|
"private/cache-table.ss"
|
|
"response.ss")
|
|
(require (lib "unitsig.ss")
|
|
(lib "contract.ss"))
|
|
|
|
(provide complete-configuration
|
|
get-configuration
|
|
build-developer-configuration
|
|
build-developer-configuration/vhosts ;; added 2/3/05 by Jacob
|
|
default-configuration-table-path
|
|
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)
|
|
(complete-developer-configuration/vhosts (directory-part default-configuration-table-path)
|
|
(parse-configuration-table s-expr)))
|
|
|
|
; : str configuration-table/vhosts -> configuration
|
|
(define (complete-developer-configuration/vhosts 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))))
|
|
|
|
; : 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))))
|
|
|
|
; : 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 (build-configuration table the-virtual-hosts)
|
|
(unit/sig web-config^
|
|
(import)
|
|
(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 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")))
|
|
|
|
|
|
; 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 to-be-copied-module-specs)))
|
|
; end stolen
|
|
|
|
(define (the-make-servlet-namespace)
|
|
(let ([server-namespace (current-namespace)]
|
|
[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)))
|
|
|
|
; : (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:
|
|
; - write the compound unit multiple times (no abstraction)
|
|
; - use opt-lambda and pass in 'please-use-the-default for unchanged flags
|
|
; - 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^)))))
|
|
|
|
; 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/plain" ;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)
|
|
; more here - 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))))
|