141 lines
6.2 KiB
Racket
141 lines
6.2 KiB
Racket
#lang racket/base
|
|
(require mzlib/unit
|
|
racket/contract)
|
|
(require web-server/private/util
|
|
web-server/private/cache-table
|
|
web-server/configuration/configuration-table-structs
|
|
web-server/configuration/configuration-table
|
|
web-server/configuration/namespace
|
|
web-server/configuration/responders
|
|
web-server/web-config-sig)
|
|
(provide/contract
|
|
[configuration-table->web-config@
|
|
(->* (path-string?)
|
|
(#:port (or/c false/c number?)
|
|
#:listen-ip (or/c false/c string?)
|
|
#:make-servlet-namespace make-servlet-namespace/c)
|
|
(unit/c (import) (export web-config^)))]
|
|
[configuration-table-sexpr->web-config@
|
|
(->* (configuration-table-sexpr?)
|
|
(#:web-server-root path-string?
|
|
#:port (or/c false/c number?)
|
|
#:listen-ip (or/c false/c string?)
|
|
#:make-servlet-namespace make-servlet-namespace/c)
|
|
(unit/c (import) (export web-config^)))])
|
|
|
|
; configuration-table->web-config@ : path -> configuration
|
|
(define (configuration-table->web-config@
|
|
table-file-name
|
|
#:port [port #f]
|
|
#:listen-ip [listen-ip #f]
|
|
#:make-servlet-namespace [make-servlet-namespace (make-make-servlet-namespace)])
|
|
(configuration-table-sexpr->web-config@
|
|
(call-with-input-file table-file-name read)
|
|
#:web-server-root (directory-part table-file-name)
|
|
#:port port
|
|
#:listen-ip listen-ip
|
|
#:make-servlet-namespace make-servlet-namespace))
|
|
|
|
; configuration-table-sexpr->web-config@ : string? sexp -> configuration
|
|
(define (configuration-table-sexpr->web-config@
|
|
sexpr
|
|
#:web-server-root [web-server-root (directory-part default-configuration-table-path)]
|
|
#:port [port #f]
|
|
#:listen-ip [listen-ip #f]
|
|
#:make-servlet-namespace [make-servlet-namespace (make-make-servlet-namespace)])
|
|
(complete-configuration
|
|
web-server-root
|
|
(sexpr->configuration-table sexpr)
|
|
#:port port
|
|
#:listen-ip listen-ip
|
|
#:make-servlet-namespace make-servlet-namespace))
|
|
|
|
; : str configuration-table -> configuration
|
|
(define (complete-configuration
|
|
base table
|
|
#:port [port #f]
|
|
#:listen-ip [listen-ip #f]
|
|
#:make-servlet-namespace [make-servlet-namespace (make-make-servlet-namespace)])
|
|
(define default-host
|
|
(apply-default-functions-to-host-table
|
|
base (configuration-table-default-host table)))
|
|
(define 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)))
|
|
(build-configuration
|
|
table
|
|
(gen-virtual-hosts expanded-virtual-host-table default-host)
|
|
#:port port
|
|
#:listen-ip listen-ip
|
|
#:make-servlet-namespace make-servlet-namespace))
|
|
|
|
; : configuration-table host-table -> configuration
|
|
(define (build-configuration
|
|
table the-virtual-hosts
|
|
#:port [port #f]
|
|
#:listen-ip [listen-ip #f]
|
|
#:make-servlet-namespace [make-servlet-namespace (make-make-servlet-namespace)])
|
|
(define the-port (or port (configuration-table-port table)))
|
|
(define the-listen-ip (or listen-ip #f))
|
|
(define the-make-servlet-namespace make-servlet-namespace)
|
|
(unit
|
|
(import)
|
|
(export web-config^)
|
|
(define port the-port)
|
|
(define max-waiting (configuration-table-max-waiting table))
|
|
(define listen-ip the-listen-ip)
|
|
(define initial-connection-timeout (configuration-table-initial-connection-timeout table))
|
|
(define virtual-hosts the-virtual-hosts)
|
|
(define make-servlet-namespace the-make-servlet-namespace)))
|
|
|
|
; 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
|
|
servlet-error-responder
|
|
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))]
|
|
[htdocs-base (build-path-unless-absolute host-base (paths-htdocs paths))])
|
|
(make-paths (build-path-unless-absolute host-base (paths-conf paths))
|
|
host-base
|
|
(build-path-unless-absolute host-base (paths-log paths))
|
|
htdocs-base
|
|
(build-path-unless-absolute htdocs-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)))
|