809 lines
40 KiB
Scheme
809 lines
40 KiB
Scheme
(module configure mzscheme
|
|
(require (lib "unitsig.ss")
|
|
(lib "servlet-sig.ss" "web-server")
|
|
(lib "url.ss" "net")
|
|
(lib "etc.ss")
|
|
(lib "list.ss")
|
|
(lib "pretty.ss")
|
|
(lib "file.ss")
|
|
(lib "contract.ss")
|
|
(only (lib "configuration.ss" "web-server")
|
|
default-configuration-table-path)
|
|
(lib "configuration-table-structs.ss" "web-server" "private")
|
|
(lib "parse-table.ss" "web-server" "private")
|
|
(lib "configuration-util.ss" "web-server" "private")
|
|
(lib "util.ss" "web-server" "private"))
|
|
(provide/contract
|
|
[servlet unit/sig?]
|
|
; XXX contract
|
|
[servlet-maker (string? . -> . unit/sig?)])
|
|
|
|
;; FIX
|
|
; - fuss with changing absolute paths into relative ones internally
|
|
; - move old config files instead of copying default ones
|
|
; - ask: - move exisiting (don't move defaults)
|
|
; - copy defaults to new location
|
|
; - use files existing in the new location (ask only when they exist)
|
|
; - do this when either
|
|
; - changing the root dir (and at least one other file depends on it?)
|
|
; - editing an individual path
|
|
; - change all configuration paths (in the configure servlet and in the server) to
|
|
; use a platform independent representation (i.e. a listof strings)
|
|
|
|
; servlet-maker : str -> (unit/sig servlet^ -> ())
|
|
(define (servlet-maker default-configuration-path)
|
|
(unit/sig ()
|
|
(import servlet^)
|
|
|
|
(define CONFIGURE-SERVLET-NAME "configure.ss")
|
|
(define WIDE "70")
|
|
|
|
(adjust-timeout! (* 12 60 60))
|
|
(error-print-width 800) ; 10-ish lines
|
|
|
|
; passwords = (listof realm)
|
|
; realm = (make-realm str str (listof user-pass))
|
|
(define-struct realm (name pattern allowed))
|
|
|
|
; user-pass = (make-user-pass sym str)
|
|
(define-struct user-pass (user pass))
|
|
|
|
(define doc-dir "Defaults/documentation")
|
|
|
|
(define edit-host-button-name "Edit Minor Details")
|
|
|
|
; build-footer : str -> html
|
|
(define (build-footer base)
|
|
(let ([scale (lambda (n) (number->string (round (/ n 4))))])
|
|
`(p "Powered by "
|
|
(a ([href "http://www.plt-scheme.org/"])
|
|
(img ([width ,(scale 211)] [height ,(scale 76)]
|
|
[src ,(string-append base doc-dir "/plt-logo.gif")]))))))
|
|
|
|
(define footer (build-footer "/"))
|
|
|
|
; access-error-page : html
|
|
(define access-error-page
|
|
`(html (head (title "Web Server Configuration Access Error"))
|
|
(body ([bgcolor "white"])
|
|
(p "You must connect to the configuration tool from the machine the server runs on using 127.0.0.1 for the host part of the URL.")
|
|
,footer)))
|
|
|
|
; permission-error-page : path -> html
|
|
(define (permission-error-page configuration-path)
|
|
`(html (head (title "Web Server Configuration Permissions Error"))
|
|
(body ([bgcolor "white"])
|
|
(p "You must have read and write access to "
|
|
(code ,(path->string configuration-path))
|
|
" in order to configure the server."))))
|
|
|
|
; check-ip-address : request -> request
|
|
(define (check-ip-address request)
|
|
(unless (string=? "127.0.0.1" (request-host-ip request))
|
|
(send/finish access-error-page))
|
|
request)
|
|
|
|
(check-ip-address initial-request)
|
|
|
|
(define web-base (directory-part default-configuration-path))
|
|
|
|
; more here - abstract with static pages?
|
|
(define web-server-icon
|
|
`(img ([src ,(string-append "/" doc-dir "/web-server.gif")]
|
|
;[width "123"] [height "115"]
|
|
[width "61"] [height "57"])))
|
|
|
|
; interact : (str -> response) -> bindings
|
|
(define (interact page)
|
|
(request-bindings (check-ip-address (send/suspend page))))
|
|
|
|
; choose-configuration-file : -> doesn't
|
|
(define (choose-configuration-file)
|
|
(let ([configuration-path (ask-for-configuration-path)])
|
|
(let loop ()
|
|
(if (file-exists? configuration-path)
|
|
(let ([perms (file-or-directory-permissions configuration-path)])
|
|
; race condition - changing the permissions after the check
|
|
; will result in an exception later (which serves them right)
|
|
(if (and (memq 'write perms) (memq 'read perms))
|
|
(configure-top-level configuration-path)
|
|
(send/finish (permission-error-page configuration-path))))
|
|
(begin (send/suspend (copy-configuration-file configuration-path))
|
|
(with-handlers ([exn:fail:filesystem:exists? send-exn])
|
|
(let-values ([(base name must-be-dir) (split-path configuration-path)])
|
|
(ensure-directory-shallow base))
|
|
(copy-file default-configuration-path configuration-path))
|
|
(loop))))))
|
|
|
|
; copy-configuration-file : path -> html
|
|
(define (copy-configuration-file configuration-path)
|
|
(build-suspender
|
|
'("Copy Configuration File")
|
|
`((h1 "Copy Configuration File")
|
|
(p "The configuration file "
|
|
(blockquote (code ,(path->string configuration-path)))
|
|
"does not exist. Would you like to copy the default configuration to this "
|
|
"location?")
|
|
(center (input ([type "submit"] [name "ok"] [value "Copy"]))))))
|
|
|
|
; ask-for-configuration-path : -> path
|
|
(define (ask-for-configuration-path)
|
|
(build-path
|
|
(extract-binding/single
|
|
'path
|
|
(request-bindings (send/suspend configuration-path-page)))))
|
|
|
|
; configuration-path-page : str -> html
|
|
(define configuration-path-page
|
|
(build-suspender
|
|
'("Choose a Configuration File")
|
|
`((h1 "Choose a Web Server Configuration File")
|
|
,web-server-icon
|
|
(p "Choose a Web server configuration file to edit. "
|
|
(br)
|
|
"This Web server uses the configuration in "
|
|
(blockquote (code ,(path->string default-configuration-path))))
|
|
(table (tr (th "Configuration path")
|
|
(td (input ([type "text"] [name "path"] [size ,WIDE]
|
|
[value ,(path->string default-configuration-path)]))))
|
|
(tr (td ([colspan "2"] [align "center"])
|
|
(input ([type "submit"] [name "choose-path"] [value "Select"]))))))))
|
|
|
|
; configure-top-level : path -> doesn't
|
|
(define (configure-top-level configuration-path)
|
|
(with-handlers ([exn:fail:filesystem:exists? send-exn])
|
|
(let ([original-configuration (read-configuration configuration-path)])
|
|
(let loop ([configuration original-configuration])
|
|
(let* ([update-bindings (interact (request-new-configuration-table configuration original-configuration))]
|
|
[form-configuration
|
|
(delete-hosts (update-configuration configuration update-bindings)
|
|
(foldr (lambda (b acc)
|
|
(if (string=? "Delete" (cdr b))
|
|
(cons (symbol->string (car b)) acc)
|
|
acc))
|
|
null
|
|
update-bindings))]
|
|
[new-configuration
|
|
(cond
|
|
[(assq 'add-host update-bindings)
|
|
(add-virtual-host form-configuration (extract-bindings 'host-prefixes update-bindings))]
|
|
[(reverse-assoc edit-host-button-name update-bindings)
|
|
=>
|
|
(lambda (edit)
|
|
; write the configuration twice when editing a host: once before and once after.
|
|
; The after may never happen if the user doesn't continue
|
|
(write-configuration form-configuration configuration-path)
|
|
(configure-hosts form-configuration (string->number (symbol->string (car edit)))))]
|
|
[else form-configuration])])
|
|
(write-configuration new-configuration configuration-path)
|
|
(loop new-configuration))))))
|
|
|
|
; switch-to-current-port : configuration-table -> (U #f configuration-table)
|
|
; doesn't work - the browser doesn't send the port and it wouldn't be reliable anyway
|
|
; perhaps the server could include it?
|
|
'(define (switch-to-current-port old)
|
|
(let ([current-port (url-port (request-uri initial-request))])
|
|
(and (not (= current-port (configuration-table-port old)))
|
|
(make-configuration-table
|
|
current-port
|
|
(configuration-table-max-waiting old)
|
|
(configuration-table-initial-connection-timeout old)
|
|
(configuration-table-default-host old)
|
|
(configuration-table-virtual-hosts old)))))
|
|
|
|
; send-exn : tst -> doesn't
|
|
(define (send-exn exn)
|
|
(send/back (exception-error-page exn)))
|
|
|
|
; reverse-assoc : a (listof (cons b a)) -> (U #f (cons b a))
|
|
(define (reverse-assoc x lst)
|
|
(cond
|
|
[(null? lst) #f]
|
|
[else (if (equal? x (cdar lst))
|
|
(car lst)
|
|
(reverse-assoc x (cdr lst)))]))
|
|
|
|
; add-virtual-host : configuration-table (listof str) -> configuration-table
|
|
(define (add-virtual-host conf existing-prefixes)
|
|
(update-hosts conf (cons (cons "my-host.my-domain.org"
|
|
(configuration-table-default-host conf))
|
|
(configuration-table-virtual-hosts conf))))
|
|
|
|
; update-hosts : configuration-table (listof (cons str host-table))
|
|
(define (update-hosts conf new-hosts)
|
|
(make-configuration-table
|
|
(configuration-table-port conf)
|
|
(configuration-table-max-waiting conf)
|
|
(configuration-table-initial-connection-timeout conf)
|
|
(configuration-table-default-host conf)
|
|
new-hosts))
|
|
|
|
; delete-hosts : configuration-table (listof str) -> configuration-table
|
|
; pre: (>= (length (configuration-table-virtual-hosts conf)) (max to-delete))
|
|
(define (delete-hosts conf to-delete)
|
|
; the if is not needed, it just avoids some work
|
|
(if (null? to-delete)
|
|
conf
|
|
(update-hosts
|
|
conf
|
|
(drop (configuration-table-virtual-hosts conf) to-delete))))
|
|
|
|
; drop : (listof a) (listof str) -> (listof a)
|
|
; pre: (apply < to-delete)
|
|
; to delete the entries in to-filter indexed by to-delete
|
|
(define (drop to-filter to-delete)
|
|
(let loop ([to-filter to-filter] [to-delete (map string->number to-delete)] [i 0])
|
|
(cond
|
|
[(null? to-delete) to-filter]
|
|
[else (if (= i (car to-delete))
|
|
(loop (cdr to-filter) (cdr to-delete) (add1 i))
|
|
(cons (car to-filter) (loop (cdr to-filter) to-delete (add1 i))))])))
|
|
|
|
; configure-hosts : configuration-table (U #f nat) -> configuration-table
|
|
; n is either the virtual host number or #f for the default virtual host
|
|
(define (configure-hosts old n)
|
|
(if n
|
|
(update-hosts old
|
|
; more here - consider restructuring this map. Perhaps it is fine.
|
|
; Perhaps it should short circuit. Perhaps the number of virtual hosts
|
|
; is small so it doesn't matter. Perhaps that is a sloppy way to think/program.
|
|
; The code is really a functional array update except it's on a list.
|
|
(map (lambda (host this-n)
|
|
(if (= n this-n)
|
|
(cons (car host) (configure-host (cdr host)))
|
|
host))
|
|
(configuration-table-virtual-hosts old)
|
|
(build-list (length (configuration-table-virtual-hosts old)) (lambda (x) x))))
|
|
(make-configuration-table
|
|
(configuration-table-port old)
|
|
(configuration-table-max-waiting old)
|
|
(configuration-table-initial-connection-timeout old)
|
|
(configure-host (configuration-table-default-host old))
|
|
(configuration-table-virtual-hosts old))))
|
|
|
|
; configure-host : host-table -> host-table
|
|
(define (configure-host old)
|
|
(let* ([bindings (interact (request-new-host-table old))]
|
|
[new (update-host-table old bindings)])
|
|
(when (assq 'edit-passwords bindings)
|
|
(let* ([paths (host-table-paths new)]
|
|
[password-path
|
|
;; build-path-unless-absolute is defined in configuration.ss
|
|
(build-path-unless-absolute
|
|
(build-path-unless-absolute web-base (paths-host-base paths))
|
|
(paths-passwords paths))])
|
|
(unless (file-exists? password-path)
|
|
(write-to-file password-path ''()))
|
|
(configure-passwords password-path)))
|
|
new))
|
|
|
|
(define restart-message
|
|
`((h3 (font ([color "red"]) "Restart the Web server to use the new settings."))))
|
|
|
|
; request-new-configuration-table : configuration-table configuration-table -> str -> html
|
|
(define (request-new-configuration-table old orig)
|
|
(build-suspender
|
|
'("PLT Web Server Configuration")
|
|
`((h1 "PLT Web Server Configuration Management")
|
|
,web-server-icon
|
|
"copyright 2001 by Paul Graunke and PLT"
|
|
(hr)
|
|
(h2 "Basic Configuration")
|
|
(table
|
|
,(make-tr-num "Port" 'port (configuration-table-port old))
|
|
,(make-tr-num "Maximum Waiting Connections"
|
|
'waiting (configuration-table-max-waiting old))
|
|
,(make-tr-num "Initial Connection Timeout (seconds)" 'time-initial
|
|
(configuration-table-initial-connection-timeout old)))
|
|
(hr)
|
|
(h2 "Host Name Configuration")
|
|
(p "The Web server accepts requests on behalf of multiple " (em "hosts")
|
|
" each corresponding to a domain name."
|
|
" The table below maps domain names to host specific configurations.")
|
|
(table ([width "50%"])
|
|
(tr (th ([align "left"]) "Name") ;(th "Host configuration path")
|
|
(th "Host Directory")
|
|
(th nbsp)
|
|
(th nbsp))
|
|
(tr (td ,"Default Host")
|
|
(td ,(make-field-size "text" 'default-host-root
|
|
(table->host-root (configuration-table-default-host old))
|
|
WIDE))
|
|
(td ([align "center"])
|
|
(input ([type "submit"] [name "default"] [value ,edit-host-button-name])))
|
|
(td nbsp))
|
|
,@(map (lambda (host n)
|
|
`(tr (td ,(make-field "text" 'host-regexps (car host)))
|
|
(td ,(make-field-size "text" 'host-roots (table->host-root (cdr host)) WIDE))
|
|
(td ([align "center"])
|
|
(input ([type "submit"] [name ,n] [value ,edit-host-button-name])))
|
|
(td ([align "center"])
|
|
(input ([type "submit"] [name ,n] [value "Delete"])))))
|
|
(configuration-table-virtual-hosts old)
|
|
(build-list (length (configuration-table-virtual-hosts old)) number->string))
|
|
(tr (td (input ([type "submit"] [name "add-host"] [value "Add Host"])))
|
|
(td nbsp); (input ([type "submit"] [name "configure"] [value "Delete"]))
|
|
;(td (input ([type "submit"] [name "edit-host-details"] [value "Edit"])))
|
|
(td nbsp)))
|
|
(hr)
|
|
(table ([width "90%"])
|
|
,@(if (equal? old orig) ; This only tests eq? because structures are more opaque now.
|
|
null
|
|
`((tr (td ,@restart-message))))
|
|
(tr (td (input ([type "submit"] [name "configure"] [value "Update Configuration"])))))
|
|
(hr)
|
|
,footer)))
|
|
|
|
; table->host-root : host-table -> str
|
|
(define (table->host-root t)
|
|
(path->string (build-path-unless-absolute web-base (paths-host-base (host-table-paths t)))))
|
|
|
|
; gen-make-tr : nat -> xexpr sym str [xexpr ...] -> xexpr
|
|
(define (gen-make-tr size-n)
|
|
(let ([size-str (number->string size-n)])
|
|
(lambda (label tag default-text . extra-tds)
|
|
`(tr (td (a ([href ,(format "/~a/terms/~a.html" doc-dir tag)]) ,label))
|
|
(td ,(make-field-size "text" tag (format "~a" default-text) size-str))
|
|
. ,extra-tds))))
|
|
|
|
(define make-tr-num (gen-make-tr 20))
|
|
|
|
(define make-tr-str (gen-make-tr 70))
|
|
|
|
; make-field : str sym str -> xexpr
|
|
(define (make-field type label value)
|
|
(make-field-size type label value "30"))
|
|
|
|
; make-field-size : str sym str str -> xexpr
|
|
(define (make-field-size type label value size)
|
|
`(input ([type ,type] [name ,(symbol->string label)] [value ,value] [size ,size])))
|
|
|
|
; update-configuration : configuration-table bindings -> configuration-table
|
|
(define (update-configuration old bindings)
|
|
(let ([ubp (un-build-path web-base)]) ;; web-base returned by directory-part is a path
|
|
(make-configuration-table
|
|
(string->nat (extract-binding/single 'port bindings))
|
|
(string->nat (extract-binding/single 'waiting bindings))
|
|
(string->num (extract-binding/single 'time-initial bindings))
|
|
(update-host-root (configuration-table-default-host old)
|
|
(ubp (build-path (extract-binding/single 'default-host-root bindings))))
|
|
(map (lambda (h root pattern)
|
|
(cons pattern (update-host-root (cdr h) (ubp (build-path root)))))
|
|
(configuration-table-virtual-hosts old)
|
|
(extract-bindings 'host-roots bindings)
|
|
(extract-bindings 'host-regexps bindings)))))
|
|
|
|
; update-host-root : host-table str -> host-table
|
|
(define (update-host-root host new-root)
|
|
(host-table<-paths host (paths<-host-base (host-table-paths host) new-root)))
|
|
|
|
; host-table<-paths : host-table paths -> host-table
|
|
; more here - create these silly functions automatically from def-struct macro
|
|
(define (host-table<-paths host paths)
|
|
(make-host-table
|
|
(host-table-indices host)
|
|
(host-table-log-format host)
|
|
(host-table-messages host)
|
|
(host-table-timeouts host)
|
|
paths))
|
|
|
|
; paths<-host-base : paths str -> paths
|
|
; more here - create these silly functions automatically from def-struct macro
|
|
(define (paths<-host-base paths host-base)
|
|
(make-paths (paths-conf paths)
|
|
host-base
|
|
(paths-log paths)
|
|
(paths-htdocs paths)
|
|
(paths-servlet paths)
|
|
(paths-mime-types paths)
|
|
(paths-passwords paths)))
|
|
|
|
; string->num : str -> nat
|
|
(define (string->num str)
|
|
(or (string->number str) (error 'string->nat "~s is not a number" str)))
|
|
|
|
; string->nat : str -> nat
|
|
(define (string->nat str)
|
|
(let ([n (string->number str)])
|
|
(if (and n (integer? n) (exact? n) (>= n 0))
|
|
n
|
|
(error 'string->nat "~s is not exactly a natural number" str))))
|
|
|
|
; request-new-host-table : host-table -> str -> response
|
|
(define (request-new-host-table old)
|
|
(let* ([timeouts (host-table-timeouts old)]
|
|
[paths (host-table-paths old)]
|
|
[m (host-table-messages old)]
|
|
[host-root (build-path-unless-absolute web-base (paths-host-base paths))]
|
|
[conf (build-path-unless-absolute host-root (paths-conf paths))])
|
|
(build-suspender
|
|
'("Configure Host")
|
|
`((h1 "PLT Web Server Host configuration")
|
|
(input ([type "submit"] [value "Save Configuration"]))
|
|
(hr)
|
|
(table
|
|
(tr (th ([colspan "2"]) "Paths"))
|
|
,(make-tr-str "Log file"
|
|
'path-log (build-path-unless-absolute host-root (paths-log paths)))
|
|
,(make-tr-str "Web document root"
|
|
'path-htdocs (build-path-unless-absolute host-root (paths-htdocs paths)))
|
|
,(make-tr-str "Servlet root"
|
|
'path-servlet (build-path-unless-absolute host-root (paths-servlet paths)))
|
|
,(make-tr-str "MIME Types"
|
|
'path-mime-types (build-path-unless-absolute host-root (paths-mime-types paths)))
|
|
,(make-tr-str "Password File"
|
|
'path-password (build-path-unless-absolute host-root (paths-passwords paths)))
|
|
(tr (td ([colspan "2"])
|
|
,(make-field "submit" 'edit-passwords "Edit Passwords")))
|
|
(tr (td ([colspan "2"]) (hr)))
|
|
(tr (th ([colspan "2"]) "Message Paths"))
|
|
,(make-tr-str "Servlet error" 'path-servlet-message
|
|
(build-path-unless-absolute conf (messages-servlet m)))
|
|
,(make-tr-str "Access Denied" 'path-access-message
|
|
(build-path-unless-absolute conf (messages-authentication m)))
|
|
,(make-tr-str "Servlet cache refreshed" 'servlet-refresh-message
|
|
(build-path-unless-absolute conf (messages-servlets-refreshed m)))
|
|
,(make-tr-str "Password cache refreshed" 'password-refresh-message
|
|
(build-path-unless-absolute conf (messages-passwords-refreshed m)))
|
|
,(make-tr-str "File not found" 'path-not-found-message
|
|
(build-path-unless-absolute conf (messages-file-not-found m)))
|
|
,(make-tr-str "Protocol error" 'path-protocol-message
|
|
(build-path-unless-absolute conf (messages-protocol m)))
|
|
,(make-tr-str "Collect garbage" 'path-collect-garbage-message
|
|
(build-path-unless-absolute conf (messages-collect-garbage m)))
|
|
(tr (td ([colspan "2"]) (hr)))
|
|
(tr (th ([colspan "2"]) "Timeout Seconds"))
|
|
,(make-tr-num "Default Servlet" 'time-default-servlet (timeouts-default-servlet timeouts))
|
|
,(make-tr-num "Password" 'time-password (timeouts-password timeouts))
|
|
,(make-tr-num "Servlet Connection" 'time-servlet-connection (timeouts-servlet-connection timeouts))
|
|
,(make-tr-num "per Byte When Transfering Files" 'time-file-per-byte (timeouts-file-per-byte timeouts))
|
|
,(make-tr-num "Base When Transfering Files" 'time-file-base (timeouts-file-base timeouts)))
|
|
(hr)
|
|
(input ([type "submit"] [value "Save Configuration"]))
|
|
,footer))))
|
|
|
|
; update-host-table : host-table (listof (cons sym str)) -> host-table
|
|
(define (update-host-table old bindings)
|
|
(let* ([eb (lambda (tag) (build-path (extract-binding/single tag bindings)))]
|
|
[paths (host-table-paths old)]
|
|
[host-root (paths-host-base paths)]
|
|
[expanded-host-root (build-path-unless-absolute web-base host-root)]
|
|
[conf (build-path-unless-absolute expanded-host-root (paths-conf paths))]
|
|
[ubp (un-build-path expanded-host-root)]
|
|
[eb-host-root (lambda (tag) (ubp (eb tag)))]
|
|
[ubp-conf (un-build-path conf)]
|
|
[eb-conf (lambda (tag) (ubp-conf (eb tag)))])
|
|
(make-host-table
|
|
(host-table-indices old)
|
|
(host-table-log-format old)
|
|
(apply make-messages
|
|
(map eb-conf '(path-servlet-message path-access-message servlet-refresh-message password-refresh-message path-not-found-message path-protocol-message path-collect-garbage-message)))
|
|
(apply make-timeouts
|
|
(map (lambda (tag) (string->number (extract-binding/single tag bindings)))
|
|
'(time-default-servlet time-password time-servlet-connection time-file-per-byte time-file-base)))
|
|
(let ([old-paths (host-table-paths old)])
|
|
(apply make-paths
|
|
(paths-conf old-paths)
|
|
((un-build-path web-base)
|
|
(build-path (paths-host-base old-paths)))
|
|
(map eb-host-root '(path-log path-htdocs path-servlet path-mime-types path-password)))))))
|
|
|
|
; un-build-path : path -> path -> string
|
|
; (GregP) Theory: this should return a string not a path so that the result can be
|
|
; written to the configuration file.
|
|
(define (un-build-path possible-base)
|
|
(let ([base-list (path->list possible-base)])
|
|
(lambda (path)
|
|
(let ([path-list (path->list path)])
|
|
(cond
|
|
[(suffix base-list path-list)
|
|
=> (lambda (x) (path->string (apply build-path x)))]
|
|
[else
|
|
(path->string path)])))))
|
|
|
|
; suffix : (listof a) (listof a) -> (U #f (listof a))
|
|
; to return the extra elements in b after removing all elements from a in order
|
|
(define (suffix a b)
|
|
(cond
|
|
[(null? a) (if (null? b) #f b)]
|
|
[else (cond
|
|
[(null? b) #f]
|
|
[else (and (equal? (car a) (car b))
|
|
(suffix (cdr a) (cdr b)))])]))
|
|
|
|
; Password Configuration
|
|
|
|
; configure-passwords : path -> void
|
|
(define (configure-passwords password-path)
|
|
(edit-passwords
|
|
password-path
|
|
(if (file-exists? password-path)
|
|
(call-with-input-file password-path read-passwords)
|
|
null)))
|
|
|
|
; edit-passwords : path passwords -> passwords
|
|
(define (edit-passwords which-one passwords)
|
|
(let* ([bindings (interact (password-updates which-one passwords))]
|
|
[to-deactivate (extract-bindings 'deactivate bindings)]
|
|
[again
|
|
(lambda (new-passwords)
|
|
(write-to-file which-one (format-passwords new-passwords))
|
|
(edit-passwords which-one new-passwords))])
|
|
(cond
|
|
[(assq 'edit bindings)
|
|
=> (lambda (edit)
|
|
(again (drop (map (let ([to-edit (string->number (cdr edit))])
|
|
(lambda (r n)
|
|
(if (= to-edit n)
|
|
(edit-realm r)
|
|
r)))
|
|
passwords
|
|
(build-list (length passwords) (lambda (x) x)))
|
|
to-deactivate)))]
|
|
[(assq 'add bindings)
|
|
(again (cons (make-realm "new realm" "" null)
|
|
(drop passwords to-deactivate)))]
|
|
[else (drop passwords to-deactivate)])))
|
|
|
|
; password-updates : path passwords -> request
|
|
(define (password-updates which-one passwords)
|
|
(let ([which-one (path->string which-one)])
|
|
(build-suspender
|
|
`("Updating Passwords for " ,which-one)
|
|
`((h1 "Updating Passwords for ")
|
|
(h3 ,which-one)
|
|
(h2 "You may wish to " (font ([color "red"]) "backup") " this password file.")
|
|
(p "Each authentication " (em "realm") " password protects URLs that match a pattern. "
|
|
"Choose a realm to edit below:")
|
|
(table
|
|
(tr (th "Realm Name") (th "Delete") (th "Edit"))
|
|
. ,(map (lambda (realm n)
|
|
`(tr (td ,(realm-name realm))
|
|
(td ,(make-field "checkbox" 'deactivate n))
|
|
(td ,(make-field "radio" 'edit n))))
|
|
passwords
|
|
(build-list (length passwords) number->string)))
|
|
,(make-field "submit" 'add "Add Realm")
|
|
,(make-field "submit" 'edit-button "Edit")
|
|
,footer))))
|
|
|
|
; edit-realm : realm -> realm
|
|
(define (edit-realm realm)
|
|
(let* ([bindings (interact (realm-updates realm))]
|
|
[new-name (extract-binding/single 'realm-name bindings)]
|
|
[new-pattern (extract-binding/single 'realm-pattern bindings)]
|
|
[new-allowed
|
|
(drop (map (lambda (u p) (make-user-pass (string->symbol u) p))
|
|
(extract-bindings 'user bindings)
|
|
(extract-bindings 'pass bindings))
|
|
(extract-bindings 'deactivate bindings))])
|
|
; more here - check something? Everything is a string or symbol, though.
|
|
(cond
|
|
[(assq 'add-user bindings)
|
|
(edit-realm (make-realm new-name new-pattern
|
|
(cons (make-user-pass 'ptg "Scheme-is-cool!") new-allowed)))]
|
|
[(assq 'update bindings)
|
|
(make-realm new-name new-pattern new-allowed)]
|
|
[else (error 'edit-realm "Didn't find either 'add-user or 'update in ~s" bindings)])))
|
|
|
|
; realm-updates : realm -> request
|
|
(define (realm-updates realm)
|
|
(build-suspender
|
|
`("Update Authentication Realm " ,(realm-name realm))
|
|
`((h1 "Update Authentication Realm")
|
|
(table
|
|
,(make-tr-str "Realm Name" 'realm-name (realm-name realm))
|
|
,(make-tr-str "Protected URL Path Pattern" 'realm-pattern (realm-pattern realm)))
|
|
(hr)
|
|
(table
|
|
(tr (th "User Name") (th "Password") (th "Delete"))
|
|
. ,(map (lambda (x n)
|
|
`(tr (td ,(make-field "text" 'user (symbol->string (user-pass-user x))))
|
|
(td ,(make-field "text" 'pass (user-pass-pass x)))
|
|
(td ,(make-field "checkbox" 'deactivate n))))
|
|
(realm-allowed realm)
|
|
(build-list (length (realm-allowed realm)) number->string)))
|
|
(input ([type "submit"] [name "add-user"] [value "Add User"]))
|
|
(input ([type "submit"] [name "update"] [value "Update Realm"]))
|
|
,footer)))
|
|
|
|
; read-passwords : iport -> passwords
|
|
; only works if the file starts with (quote ...)
|
|
(define (read-passwords in)
|
|
(let ([raw (read in)])
|
|
(unless (and (pair? raw) (eq? 'quote (car raw))
|
|
(null? (cddr raw)))
|
|
(error 'read-passwords "The password file must be quoted to use the configuration tool."))
|
|
(map (lambda (raw-realm)
|
|
; more here - error checking
|
|
(make-realm (car raw-realm)
|
|
(cadr raw-realm)
|
|
(map (lambda (x) (make-user-pass (car x) (cadr x)))
|
|
(cddr raw-realm))))
|
|
(cadr raw))))
|
|
|
|
; format-passwords : passwords -> s-expr
|
|
(define (format-passwords passwords)
|
|
(list 'quote
|
|
(map (lambda (r)
|
|
(list* (realm-name r)
|
|
(realm-pattern r)
|
|
(map (lambda (x)
|
|
(list (user-pass-user x) (user-pass-pass x)))
|
|
(realm-allowed r))))
|
|
passwords)))
|
|
|
|
; Little Helpers
|
|
|
|
; initialization-error-page : response
|
|
(define initialization-error-page
|
|
`(html (head (title "Web Server Configuration Program Invocation Error"))
|
|
(body ([bgcolor "white"])
|
|
(p "Please direct your browser directly to the "
|
|
(a ([href ,(url->string (request-uri initial-request))]) "configuration program,")
|
|
" not through another URL.")
|
|
,footer)))
|
|
|
|
; done-page : html
|
|
(define done-page
|
|
; more-here - consider adding more useful information
|
|
`(html (head (title "done"))
|
|
(body ([bgcolor "white"])
|
|
(h2 "Configuration Saved.")
|
|
(p "Click your browser's back button to continue configuring the server.")
|
|
,footer)))
|
|
|
|
; exception-error-page : TST -> html
|
|
(define (exception-error-page exn)
|
|
`(html (head (title "Error"))
|
|
(body ([bgcolor "white"])
|
|
(p "Servlet exception: "
|
|
(pre ,(exn->string exn)))
|
|
,footer)))
|
|
|
|
(define must-select-host-page
|
|
`(html (head (title "Web Server Configuration Error"))
|
|
(body ([bgcolor "white"])
|
|
(p "Please select which host to edit before clicking the Edit button.")
|
|
,footer)))
|
|
|
|
; io
|
|
|
|
; read-configuration : path -> configuration-table
|
|
(define (read-configuration configuration-path)
|
|
(parse-configuration-table (call-with-input-file configuration-path read)))
|
|
|
|
; write-configuration : configuration-table path -> void
|
|
; writes out the new configuration file and
|
|
; also copies the configure.ss servlet to the default-host's servlet directory
|
|
(define (write-configuration new configuration-path)
|
|
(ensure-configuration-servlet configuration-path (configuration-table-default-host new))
|
|
(ensure-configuration-paths new)
|
|
(write-configuration-table new configuration-path))
|
|
|
|
; ensure-configuration-servlet : path host-table -> void
|
|
(define (ensure-configuration-servlet configuration-path host)
|
|
(let* ([paths (host-table-paths host)]
|
|
[root (build-path-unless-absolute web-base
|
|
(paths-host-base paths))]
|
|
[servlets-path
|
|
(build-path (build-path-unless-absolute root (paths-servlet paths)) "servlets")])
|
|
(ensure-config-servlet configuration-path servlets-path)
|
|
(let ([defaults (build-path "Defaults")])
|
|
(ensure* (collection-path "web-server" "default-web-root" "htdocs")
|
|
(build-path-unless-absolute root (paths-htdocs paths))
|
|
defaults))))
|
|
|
|
; ensure-configuration-paths : configuration-table -> void
|
|
; to ensure that all the referenced config files exist for an entire configuration
|
|
(define (ensure-configuration-paths configuration)
|
|
(ensure-host-configuration (configuration-table-default-host configuration))
|
|
(for-each (lambda (x) (ensure-host-configuration (cdr x)))
|
|
(configuration-table-virtual-hosts configuration)))
|
|
|
|
; ensure-host-configuration : host-table -> void
|
|
; to ensure that all the referenced config files exist for a virtual host
|
|
(define (ensure-host-configuration host)
|
|
(let* ([paths (host-table-paths host)]
|
|
[host-base (build-path-unless-absolute web-base (paths-host-base paths))]
|
|
[conf (build-path-unless-absolute host-base (paths-conf paths))]
|
|
[log (build-path-unless-absolute host-base (paths-log paths))])
|
|
; skip passwords since a missing file is an okay default
|
|
(ensure-directory-shallow conf)
|
|
(ensure-directory-shallow host-base)
|
|
;(ensure-file log ...) ; empty log file is okay
|
|
(ensure-directory-shallow (build-path-unless-absolute host-base (paths-htdocs paths)))
|
|
(ensure-directory-shallow (build-path-unless-absolute host-base (paths-servlet paths)))
|
|
(let* ([messages (host-table-messages host)]
|
|
; more here maybe - check default config file instead? maybe not
|
|
[from-conf (collection-path "web-server" "default-web-root" "conf")]
|
|
[copy-conf
|
|
(lambda (from to)
|
|
(let ([to-path (build-path-unless-absolute conf to)])
|
|
; more here - check existance of from path?
|
|
(copy-file* (build-path from-conf from) to-path)))])
|
|
(copy-conf "passwords-refresh.html" (messages-passwords-refreshed messages))
|
|
(copy-conf "servlet-refresh.html" (messages-servlets-refreshed messages))
|
|
(copy-conf "forbidden.html" (messages-authentication messages))
|
|
(copy-conf "protocol-error.html" (messages-protocol messages))
|
|
(copy-conf "not-found.html" (messages-file-not-found messages))
|
|
(copy-conf "servlet-error.html" (messages-servlet messages))
|
|
(copy-conf "collect-garbage.html" (messages-collect-garbage messages)))))
|
|
|
|
; ensure-file : path path path -> void
|
|
; to copy (build-path from name) to (build-path to name), creating directories as
|
|
; needed if the latter does not already exist.
|
|
(define (ensure-file from to name)
|
|
(let ([to (simplify-path to)])
|
|
(ensure-directory-shallow to)
|
|
(let ([to-path (build-path to name)])
|
|
(unless (file-exists? to-path)
|
|
(copy-file (build-path from name) to-path)))))
|
|
|
|
; copy-file* : str str -> void
|
|
(define (copy-file* from-path to-path)
|
|
(unless (file-exists? to-path)
|
|
(let-values ([(to-path-base to-path-name must-be-dir?) (split-path to-path)])
|
|
(ensure-directory-shallow to-path-base))
|
|
(copy-file from-path to-path)))
|
|
|
|
; ensure* : path path path -> void
|
|
;; GregP: Don't know what the heck this does (thanks Paul)
|
|
;; but the first two arguments are now paths.
|
|
(define (ensure* from to name)
|
|
(ensure-directory-shallow to)
|
|
(let ([p (build-path from name)])
|
|
(cond
|
|
[(directory-exists? p)
|
|
(unless (member (path->string name) '("CVS" ".svn")) ; yuck
|
|
(let ([dest (build-path to name)])
|
|
(ensure-directory-shallow dest)
|
|
(for-each (lambda (x) (ensure* p dest x))
|
|
(directory-list p))))]
|
|
[(file-exists? p)
|
|
(ensure-file from to name)])))
|
|
|
|
; ensure-directory-shallow : path -> void
|
|
(define (ensure-directory-shallow to)
|
|
(unless (directory-exists? to)
|
|
; race condition - someone else could make the directory
|
|
(make-directory* to)))
|
|
|
|
; ensure-config-servlet : str path -> void
|
|
; to create, if necessary, a stub configuration servlet that includes the main configuration servlet
|
|
; at the desired location in a new web tree
|
|
(define (ensure-config-servlet configuration-path servlets-path)
|
|
(ensure-directory-shallow servlets-path)
|
|
(let ([file-path (build-path servlets-path CONFIGURE-SERVLET-NAME)])
|
|
(unless (file-exists? file-path) ; more here - check that it's a well formed servlet?
|
|
(call-with-output-file
|
|
file-path
|
|
(lambda (out)
|
|
(pretty-print
|
|
`(require (lib ,CONFIGURE-SERVLET-NAME "web-server"))
|
|
out)
|
|
(newline out)
|
|
(pretty-print
|
|
`(servlet-maker ,(path->string configuration-path))
|
|
out))))))
|
|
|
|
; extract-definition : sym (listof s-expr) -> s-expr
|
|
; to return the rhs from (def name rhs) not (def (name . args) body)
|
|
(define (extract-definition name defs)
|
|
(or (ormap (lambda (def)
|
|
(and (pair? def) (eq? 'define (car def))
|
|
(pair? (cdr def)) (eq? name (cadr def))
|
|
(pair? (cddr def))
|
|
(caddr def)))
|
|
defs)
|
|
(error 'extract-definition "definition for ~a not found" name)))
|
|
|
|
; passwords = str (i.e. path to a file)
|
|
|
|
(define build-path-maybe-expression->file-name caddr)
|
|
|
|
; main
|
|
(choose-configuration-file)))
|
|
|
|
(define servlet (servlet-maker default-configuration-table-path)))
|