suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

adding web-server-setup script

Browse Source 
svn: r2107
This commit is contained in:
Jay McCarthy 2006-02-03 18:12:09 +00:00
parent fbd6d0f187
commit 0b83c1154f
7 changed files with 204 additions and 145 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

58
collects/web-server/configuration-util.ss Normal file
View File

@ -0,0 +1,58 @@
(module configuration-util mzscheme
(require (lib "file.ss")
(lib "pretty.ss"))
(require "configuration-table-structs.ss")
(provide (all-defined))
; write-configuration-table : configuration-table path -> void
; writes out the new configuration file
(define (write-configuration-table new configuration-path)
(write-to-file
configuration-path
`((port ,(configuration-table-port new))
(max-waiting ,(configuration-table-max-waiting new))
(initial-connection-timeout ,(configuration-table-initial-connection-timeout new))
(default-host-table
,(format-host (configuration-table-default-host new)))
(virtual-host-table
. ,(map (lambda (h) (list (car h) (format-host (cdr h))))
(configuration-table-virtual-hosts new))))))
; format-host : host-table
(define (format-host host)
(let ([t (host-table-timeouts host)]
[p (host-table-paths host)]
[m (host-table-messages host)])
`(host-table
; more here - configure
(default-indices "index.html" "index.htm")
; more here - configure
(log-format parenthesized-default)
(messages
(servlet-message ,(messages-servlet m))
(authentication-message ,(messages-authentication m))
(servlets-refreshed ,(messages-servlets-refreshed m))
(passwords-refreshed ,(messages-passwords-refreshed m))
(file-not-found-message ,(messages-file-not-found m))
(protocol-message ,(messages-protocol m))
(collect-garbage ,(messages-collect-garbage m)))
(timeouts
(default-servlet-timeout ,(timeouts-default-servlet t))
(password-connection-timeout ,(timeouts-password t))
(servlet-connection-timeout ,(timeouts-servlet-connection t))
(file-per-byte-connection-timeout ,(timeouts-file-per-byte t))
(file-base-connection-timeout ,(timeouts-file-base t)))
(paths
(configuration-root ,(paths-conf p))
(host-root ,(paths-host-base p))
(log-file-path ,(paths-log p))
(file-root ,(paths-htdocs p))
(servlet-root ,(paths-servlet p))
(mime-types ,(paths-mime-types p))
(password-authentication ,(paths-passwords p))))))
; write-to-file : str TST -> void
(define (write-to-file file-name x)
(call-with-output-file file-name
(lambda (out) (pretty-print x out))
'truncate)))

1
collects/web-server/configuration.ss
View File

@ -11,6 +11,7 @@
(lib "contract.ss")) (lib "contract.ss"))
(provide complete-configuration (provide complete-configuration
get-configuration
build-developer-configuration build-developer-configuration
build-developer-configuration/vhosts ;; added 2/3/05 by Jacob build-developer-configuration/vhosts ;; added 2/3/05 by Jacob
default-configuration-table-path default-configuration-table-path

238
collects/web-server/configure.ss
View File

@ -11,8 +11,9 @@
default-configuration-table-path) default-configuration-table-path)
(lib "configuration-table-structs.ss" "web-server") (lib "configuration-table-structs.ss" "web-server")
(lib "parse-table.ss" "web-server") (lib "parse-table.ss" "web-server")
(lib "configuration-util.ss" "web-server")
(all-except (lib "util.ss" "web-server") translate-escapes)) (all-except (lib "util.ss" "web-server") translate-escapes))
;; FIX ;; FIX
; - fuss with changing absolute paths into relative ones internally ; - fuss with changing absolute paths into relative ones internally
; - move old config files instead of copying default ones ; - move old config files instead of copying default ones
@ -24,46 +25,46 @@
; - editing an individual path ; - editing an individual path
; - change all configuration paths (in the configure servlet and in the server) to ; - change all configuration paths (in the configure servlet and in the server) to
; use a platform independent representation (i.e. a listof strings) ; use a platform independent representation (i.e. a listof strings)
; servlet-maker : str -> (unit/sig servlet^ -> ()) ; servlet-maker : str -> (unit/sig servlet^ -> ())
(define (servlet-maker default-configuration-path) (define (servlet-maker default-configuration-path)
(unit/sig () (unit/sig ()
(import servlet^) (import servlet^)
(define CONFIGURE-SERVLET-NAME "configure.ss") (define CONFIGURE-SERVLET-NAME "configure.ss")
(define WIDE "70") (define WIDE "70")
(adjust-timeout! (* 12 60 60)) (adjust-timeout! (* 12 60 60))
(error-print-width 800) ; 10-ish lines (error-print-width 800) ; 10-ish lines
; passwords = (listof realm) ; passwords = (listof realm)
; realm = (make-realm str str (listof user-pass)) ; realm = (make-realm str str (listof user-pass))
(define-struct realm (name pattern allowed)) (define-struct realm (name pattern allowed))
; user-pass = (make-user-pass sym str) ; user-pass = (make-user-pass sym str)
(define-struct user-pass (user pass)) (define-struct user-pass (user pass))
(define doc-dir "Defaults/documentation") (define doc-dir "Defaults/documentation")
(define edit-host-button-name "Edit Minor Details") (define edit-host-button-name "Edit Minor Details")
; build-footer : str -> html ; build-footer : str -> html
(define (build-footer base) (define (build-footer base)
(let ([scale (lambda (n) (number->string (round (/ n 4))))]) (let ([scale (lambda (n) (number->string (round (/ n 4))))])
`(p "Powered by " `(p "Powered by "
(a ([href "http://www.plt-scheme.org/"]) (a ([href "http://www.plt-scheme.org/"])
(img ([width ,(scale 211)] [height ,(scale 76)] (img ([width ,(scale 211)] [height ,(scale 76)]
[src ,(string-append base doc-dir "/plt-logo.gif")])))))) [src ,(string-append base doc-dir "/plt-logo.gif")]))))))
(define footer (build-footer "/")) (define footer (build-footer "/"))
; access-error-page : html ; access-error-page : html
(define access-error-page (define access-error-page
`(html (head (title "Web Server Configuration Access Error")) `(html (head (title "Web Server Configuration Access Error"))
(body ([bgcolor "white"]) (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.") (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))) ,footer)))
; permission-error-page : path -> html ; permission-error-page : path -> html
(define (permission-error-page configuration-path) (define (permission-error-page configuration-path)
`(html (head (title "Web Server Configuration Permissions Error")) `(html (head (title "Web Server Configuration Permissions Error"))
@ -71,27 +72,27 @@
(p "You must have read and write access to " (p "You must have read and write access to "
(code ,(path->string configuration-path)) (code ,(path->string configuration-path))
" in order to configure the server.")))) " in order to configure the server."))))
; check-ip-address : request -> request ; check-ip-address : request -> request
(define (check-ip-address request) (define (check-ip-address request)
(unless (string=? "127.0.0.1" (request-host-ip request)) (unless (string=? "127.0.0.1" (request-host-ip request))
(send/finish access-error-page)) (send/finish access-error-page))
request) request)
(check-ip-address initial-request) (check-ip-address initial-request)
(define web-base (directory-part default-configuration-path)) (define web-base (directory-part default-configuration-path))
; more here - abstract with static pages? ; more here - abstract with static pages?
(define web-server-icon (define web-server-icon
`(img ([src ,(string-append "/" doc-dir "/web-server.gif")] `(img ([src ,(string-append "/" doc-dir "/web-server.gif")]
;[width "123"] [height "115"] ;[width "123"] [height "115"]
[width "61"] [height "57"]))) [width "61"] [height "57"])))
; interact : (str -> response) -> bindings ; interact : (str -> response) -> bindings
(define (interact page) (define (interact page)
(request-bindings (check-ip-address (send/suspend page)))) (request-bindings (check-ip-address (send/suspend page))))
; choose-configuration-file : -> doesn't ; choose-configuration-file : -> doesn't
(define (choose-configuration-file) (define (choose-configuration-file)
(let ([configuration-path (ask-for-configuration-path)]) (let ([configuration-path (ask-for-configuration-path)])
@ -109,7 +110,7 @@
(ensure-directory-shallow base)) (ensure-directory-shallow base))
(copy-file default-configuration-path configuration-path)) (copy-file default-configuration-path configuration-path))
(loop)))))) (loop))))))
; copy-configuration-file : path -> html ; copy-configuration-file : path -> html
(define (copy-configuration-file configuration-path) (define (copy-configuration-file configuration-path)
(build-suspender (build-suspender
@ -120,14 +121,14 @@
"does not exist. Would you like to copy the default configuration to this " "does not exist. Would you like to copy the default configuration to this "
"location?") "location?")
(center (input ([type "submit"] [name "ok"] [value "Copy"])))))) (center (input ([type "submit"] [name "ok"] [value "Copy"]))))))
; ask-for-configuration-path : -> path ; ask-for-configuration-path : -> path
(define (ask-for-configuration-path) (define (ask-for-configuration-path)
(build-path (build-path
(extract-binding/single (extract-binding/single
'path 'path
(request-bindings (send/suspend configuration-path-page))))) (request-bindings (send/suspend configuration-path-page)))))
; configuration-path-page : str -> html ; configuration-path-page : str -> html
(define configuration-path-page (define configuration-path-page
(build-suspender (build-suspender
@ -140,10 +141,10 @@
(blockquote (code ,(path->string default-configuration-path)))) (blockquote (code ,(path->string default-configuration-path))))
(table (tr (th "Configuration path") (table (tr (th "Configuration path")
(td (input ([type "text"] [name "path"] [size ,WIDE] (td (input ([type "text"] [name "path"] [size ,WIDE]
[value ,(path->string default-configuration-path)])))) [value ,(path->string default-configuration-path)]))))
(tr (td ([colspan "2"] [align "center"]) (tr (td ([colspan "2"] [align "center"])
(input ([type "submit"] [name "choose-path"] [value "Select"])))))))) (input ([type "submit"] [name "choose-path"] [value "Select"]))))))))
; configure-top-level : path -> doesn't ; configure-top-level : path -> doesn't
(define (configure-top-level configuration-path) (define (configure-top-level configuration-path)
(with-handlers ([exn:fail:filesystem:exists? send-exn]) (with-handlers ([exn:fail:filesystem:exists? send-exn])
@ -172,7 +173,7 @@
[else form-configuration])]) [else form-configuration])])
(write-configuration new-configuration configuration-path) (write-configuration new-configuration configuration-path)
(loop new-configuration)))))) (loop new-configuration))))))
; switch-to-current-port : configuration-table -> (U #f configuration-table) ; 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 ; doesn't work - the browser doesn't send the port and it wouldn't be reliable anyway
; perhaps the server could include it? ; perhaps the server could include it?
@ -185,11 +186,11 @@
(configuration-table-initial-connection-timeout old) (configuration-table-initial-connection-timeout old)
(configuration-table-default-host old) (configuration-table-default-host old)
(configuration-table-virtual-hosts old))))) (configuration-table-virtual-hosts old)))))
; send-exn : tst -> doesn't ; send-exn : tst -> doesn't
(define (send-exn exn) (define (send-exn exn)
(send/back (exception-error-page exn))) (send/back (exception-error-page exn)))
; reverse-assoc : a (listof (cons b a)) -> (U #f (cons b a)) ; reverse-assoc : a (listof (cons b a)) -> (U #f (cons b a))
(define (reverse-assoc x lst) (define (reverse-assoc x lst)
(cond (cond
@ -197,13 +198,13 @@
[else (if (equal? x (cdar lst)) [else (if (equal? x (cdar lst))
(car lst) (car lst)
(reverse-assoc x (cdr lst)))])) (reverse-assoc x (cdr lst)))]))
; add-virtual-host : configuration-table (listof str) -> configuration-table ; add-virtual-host : configuration-table (listof str) -> configuration-table
(define (add-virtual-host conf existing-prefixes) (define (add-virtual-host conf existing-prefixes)
(update-hosts conf (cons (cons "my-host.my-domain.org" (update-hosts conf (cons (cons "my-host.my-domain.org"
(configuration-table-default-host conf)) (configuration-table-default-host conf))
(configuration-table-virtual-hosts conf)))) (configuration-table-virtual-hosts conf))))
; update-hosts : configuration-table (listof (cons str host-table)) ; update-hosts : configuration-table (listof (cons str host-table))
(define (update-hosts conf new-hosts) (define (update-hosts conf new-hosts)
(make-configuration-table (make-configuration-table
@ -212,13 +213,7 @@
(configuration-table-initial-connection-timeout conf) (configuration-table-initial-connection-timeout conf)
(configuration-table-default-host conf) (configuration-table-default-host conf)
new-hosts)) new-hosts))
; write-to-file : str TST -> void
(define (write-to-file file-name x)
(call-with-output-file file-name
(lambda (out) (pretty-print x out))
'truncate))
; delete-hosts : configuration-table (listof str) -> configuration-table ; delete-hosts : configuration-table (listof str) -> configuration-table
; pre: (>= (length (configuration-table-virtual-hosts conf)) (max to-delete)) ; pre: (>= (length (configuration-table-virtual-hosts conf)) (max to-delete))
(define (delete-hosts conf to-delete) (define (delete-hosts conf to-delete)
@ -228,7 +223,7 @@
(update-hosts (update-hosts
conf conf
(drop (configuration-table-virtual-hosts conf) to-delete)))) (drop (configuration-table-virtual-hosts conf) to-delete))))
; drop : (listof a) (listof str) -> (listof a) ; drop : (listof a) (listof str) -> (listof a)
; pre: (apply < to-delete) ; pre: (apply < to-delete)
; to delete the entries in to-filter indexed by to-delete ; to delete the entries in to-filter indexed by to-delete
@ -239,7 +234,7 @@
[else (if (= i (car to-delete)) [else (if (= i (car to-delete))
(loop (cdr to-filter) (cdr to-delete) (add1 i)) (loop (cdr to-filter) (cdr to-delete) (add1 i))
(cons (car to-filter) (loop (cdr to-filter) 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 ; configure-hosts : configuration-table (U #f nat) -> configuration-table
; n is either the virtual host number or #f for the default virtual host ; n is either the virtual host number or #f for the default virtual host
(define (configure-hosts old n) (define (configure-hosts old n)
@ -261,7 +256,7 @@
(configuration-table-initial-connection-timeout old) (configuration-table-initial-connection-timeout old)
(configure-host (configuration-table-default-host old)) (configure-host (configuration-table-default-host old))
(configuration-table-virtual-hosts old)))) (configuration-table-virtual-hosts old))))
; configure-host : host-table -> host-table ; configure-host : host-table -> host-table
(define (configure-host old) (define (configure-host old)
(let* ([bindings (interact (request-new-host-table old))] (let* ([bindings (interact (request-new-host-table old))]
@ -277,10 +272,10 @@
(write-to-file password-path ''())) (write-to-file password-path ''()))
(configure-passwords password-path))) (configure-passwords password-path)))
new)) new))
(define restart-message (define restart-message
`((h3 (font ([color "red"]) "Restart the Web server to use the new settings.")))) `((h3 (font ([color "red"]) "Restart the Web server to use the new settings."))))
; request-new-configuration-table : configuration-table configuration-table -> str -> html ; request-new-configuration-table : configuration-table configuration-table -> str -> html
(define (request-new-configuration-table old orig) (define (request-new-configuration-table old orig)
(build-suspender (build-suspender
@ -308,8 +303,8 @@
(th nbsp)) (th nbsp))
(tr (td ,"Default Host") (tr (td ,"Default Host")
(td ,(make-field-size "text" 'default-host-root (td ,(make-field-size "text" 'default-host-root
(table->host-root (configuration-table-default-host old)) (table->host-root (configuration-table-default-host old))
WIDE)) WIDE))
(td ([align "center"]) (td ([align "center"])
(input ([type "submit"] [name "default"] [value ,edit-host-button-name]))) (input ([type "submit"] [name "default"] [value ,edit-host-button-name])))
(td nbsp)) (td nbsp))
@ -334,11 +329,11 @@
(tr (td (input ([type "submit"] [name "configure"] [value "Update Configuration"]))))) (tr (td (input ([type "submit"] [name "configure"] [value "Update Configuration"])))))
(hr) (hr)
,footer))) ,footer)))
; table->host-root : host-table -> str ; table->host-root : host-table -> str
(define (table->host-root t) (define (table->host-root t)
(path->string (build-path-unless-absolute web-base (paths-host-base (host-table-paths 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 ; gen-make-tr : nat -> xexpr sym str [xexpr ...] -> xexpr
(define (gen-make-tr size-n) (define (gen-make-tr size-n)
(let ([size-str (number->string size-n)]) (let ([size-str (number->string size-n)])
@ -346,38 +341,38 @@
`(tr (td (a ([href ,(format "/~a/terms/~a.html" doc-dir tag)]) ,label)) `(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)) (td ,(make-field-size "text" tag (format "~a" default-text) size-str))
. ,extra-tds)))) . ,extra-tds))))
(define make-tr-num (gen-make-tr 20)) (define make-tr-num (gen-make-tr 20))
(define make-tr-str (gen-make-tr 70)) (define make-tr-str (gen-make-tr 70))
; make-field : str sym str -> xexpr ; make-field : str sym str -> xexpr
(define (make-field type label value) (define (make-field type label value)
(make-field-size type label value "30")) (make-field-size type label value "30"))
; make-field-size : str sym str str -> xexpr ; make-field-size : str sym str str -> xexpr
(define (make-field-size type label value size) (define (make-field-size type label value size)
`(input ([type ,type] [name ,(symbol->string label)] [value ,value] [size ,size]))) `(input ([type ,type] [name ,(symbol->string label)] [value ,value] [size ,size])))
; update-configuration : configuration-table bindings -> configuration-table ; update-configuration : configuration-table bindings -> configuration-table
(define (update-configuration old bindings) (define (update-configuration old bindings)
(let ([ubp (un-build-path web-base)]) ;; web-base returned by directory-part is a path (let ([ubp (un-build-path web-base)]) ;; web-base returned by directory-part is a path
(make-configuration-table (make-configuration-table
(string->nat (extract-binding/single 'port bindings)) (string->nat (extract-binding/single 'port bindings))
(string->nat (extract-binding/single 'waiting bindings)) (string->nat (extract-binding/single 'waiting bindings))
(string->num (extract-binding/single 'time-initial bindings)) (string->num (extract-binding/single 'time-initial bindings))
(update-host-root (configuration-table-default-host old) (update-host-root (configuration-table-default-host old)
(ubp (build-path (extract-binding/single 'default-host-root bindings)))) (ubp (build-path (extract-binding/single 'default-host-root bindings))))
(map (lambda (h root pattern) (map (lambda (h root pattern)
(cons pattern (update-host-root (cdr h) (ubp (build-path root))))) (cons pattern (update-host-root (cdr h) (ubp (build-path root)))))
(configuration-table-virtual-hosts old) (configuration-table-virtual-hosts old)
(extract-bindings 'host-roots bindings) (extract-bindings 'host-roots bindings)
(extract-bindings 'host-regexps bindings))))) (extract-bindings 'host-regexps bindings)))))
; update-host-root : host-table str -> host-table ; update-host-root : host-table str -> host-table
(define (update-host-root host new-root) (define (update-host-root host new-root)
(host-table<-paths host (paths<-host-base (host-table-paths host) new-root))) (host-table<-paths host (paths<-host-base (host-table-paths host) new-root)))
; host-table<-paths : host-table paths -> host-table ; host-table<-paths : host-table paths -> host-table
; more here - create these silly functions automatically from def-struct macro ; more here - create these silly functions automatically from def-struct macro
(define (host-table<-paths host paths) (define (host-table<-paths host paths)
@ -387,7 +382,7 @@
(host-table-messages host) (host-table-messages host)
(host-table-timeouts host) (host-table-timeouts host)
paths)) paths))
; paths<-host-base : paths str -> paths ; paths<-host-base : paths str -> paths
; more here - create these silly functions automatically from def-struct macro ; more here - create these silly functions automatically from def-struct macro
(define (paths<-host-base paths host-base) (define (paths<-host-base paths host-base)
@ -397,18 +392,18 @@
(paths-htdocs paths) (paths-htdocs paths)
(paths-servlet paths) (paths-servlet paths)
(paths-passwords paths))) (paths-passwords paths)))
; string->num : str -> nat ; string->num : str -> nat
(define (string->num str) (define (string->num str)
(or (string->number str) (error 'string->nat "~s is not a number" str))) (or (string->number str) (error 'string->nat "~s is not a number" str)))
; string->nat : str -> nat ; string->nat : str -> nat
(define (string->nat str) (define (string->nat str)
(let ([n (string->number str)]) (let ([n (string->number str)])
(if (and n (integer? n) (exact? n) (>= n 0)) (if (and n (integer? n) (exact? n) (>= n 0))
n n
(error 'string->nat "~s is not exactly a natural number" str)))) (error 'string->nat "~s is not exactly a natural number" str))))
; request-new-host-table : host-table -> str -> response ; request-new-host-table : host-table -> str -> response
(define (request-new-host-table old) (define (request-new-host-table old)
(let* ([timeouts (host-table-timeouts old)] (let* ([timeouts (host-table-timeouts old)]
@ -459,7 +454,7 @@
(hr) (hr)
(input ([type "submit"] [value "Save Configuration"])) (input ([type "submit"] [value "Save Configuration"]))
,footer)))) ,footer))))
; update-host-table : host-table (listof (cons sym str)) -> host-table ; update-host-table : host-table (listof (cons sym str)) -> host-table
(define (update-host-table old bindings) (define (update-host-table old bindings)
(let* ([eb (lambda (tag) (build-path (extract-binding/single tag bindings)))] (let* ([eb (lambda (tag) (build-path (extract-binding/single tag bindings)))]
@ -484,7 +479,7 @@
(paths-conf old-paths) (paths-conf old-paths)
((un-build-path web-base) (build-path (paths-host-base 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-password))))))) (map eb-host-root '(path-log path-htdocs path-servlet path-password)))))))
; un-build-path : path -> path -> string ; un-build-path : path -> path -> string
; (GregP) Theory: this should return a string not a path so that the result can be ; (GregP) Theory: this should return a string not a path so that the result can be
; written to the configuration file. ; written to the configuration file.
@ -497,7 +492,7 @@
=> (lambda (x) (path->string (apply build-path x)))] => (lambda (x) (path->string (apply build-path x)))]
[else [else
(path->string path)]))))) (path->string path)])))))
; suffix : (listof a) (listof a) -> (U #f (listof a)) ; suffix : (listof a) (listof a) -> (U #f (listof a))
; to return the extra elements in b after removing all elements from a in order ; to return the extra elements in b after removing all elements from a in order
(define (suffix a b) (define (suffix a b)
@ -507,9 +502,9 @@
[(null? b) #f] [(null? b) #f]
[else (and (equal? (car a) (car b)) [else (and (equal? (car a) (car b))
(suffix (cdr a) (cdr b)))])])) (suffix (cdr a) (cdr b)))])]))
; Password Configuration ; Password Configuration
; configure-passwords : path -> void ; configure-passwords : path -> void
(define (configure-passwords password-path) (define (configure-passwords password-path)
(edit-passwords (edit-passwords
@ -517,7 +512,7 @@
(if (file-exists? password-path) (if (file-exists? password-path)
(call-with-input-file password-path read-passwords) (call-with-input-file password-path read-passwords)
null))) null)))
; edit-passwords : path passwords -> passwords ; edit-passwords : path passwords -> passwords
(define (edit-passwords which-one passwords) (define (edit-passwords which-one passwords)
(let* ([bindings (interact (password-updates which-one passwords))] (let* ([bindings (interact (password-updates which-one passwords))]
@ -541,7 +536,7 @@
(again (cons (make-realm "new realm" "" null) (again (cons (make-realm "new realm" "" null)
(drop passwords to-deactivate)))] (drop passwords to-deactivate)))]
[else (drop passwords to-deactivate)]))) [else (drop passwords to-deactivate)])))
; password-updates : path passwords -> request ; password-updates : path passwords -> request
(define (password-updates which-one passwords) (define (password-updates which-one passwords)
(let ([which-one (path->string which-one)]) (let ([which-one (path->string which-one)])
@ -563,7 +558,7 @@
,(make-field "submit" 'add "Add Realm") ,(make-field "submit" 'add "Add Realm")
,(make-field "submit" 'edit-button "Edit") ,(make-field "submit" 'edit-button "Edit")
,footer)))) ,footer))))
; edit-realm : realm -> realm ; edit-realm : realm -> realm
(define (edit-realm realm) (define (edit-realm realm)
(let* ([bindings (interact (realm-updates realm))] (let* ([bindings (interact (realm-updates realm))]
@ -582,7 +577,7 @@
[(assq 'update bindings) [(assq 'update bindings)
(make-realm new-name new-pattern new-allowed)] (make-realm new-name new-pattern new-allowed)]
[else (error 'edit-realm "Didn't find either 'add-user or 'update in ~s" bindings)]))) [else (error 'edit-realm "Didn't find either 'add-user or 'update in ~s" bindings)])))
; realm-updates : realm -> request ; realm-updates : realm -> request
(define (realm-updates realm) (define (realm-updates realm)
(build-suspender (build-suspender
@ -603,7 +598,7 @@
(input ([type "submit"] [name "add-user"] [value "Add User"])) (input ([type "submit"] [name "add-user"] [value "Add User"]))
(input ([type "submit"] [name "update"] [value "Update Realm"])) (input ([type "submit"] [name "update"] [value "Update Realm"]))
,footer))) ,footer)))
; read-passwords : iport -> passwords ; read-passwords : iport -> passwords
; only works if the file starts with (quote ...) ; only works if the file starts with (quote ...)
(define (read-passwords in) (define (read-passwords in)
@ -618,7 +613,7 @@
(map (lambda (x) (make-user-pass (car x) (cadr x))) (map (lambda (x) (make-user-pass (car x) (cadr x)))
(cddr raw-realm)))) (cddr raw-realm))))
(cadr raw)))) (cadr raw))))
; format-passwords : passwords -> s-expr ; format-passwords : passwords -> s-expr
(define (format-passwords passwords) (define (format-passwords passwords)
(list 'quote (list 'quote
@ -629,9 +624,9 @@
(list (user-pass-user x) (user-pass-pass x))) (list (user-pass-user x) (user-pass-pass x)))
(realm-allowed r)))) (realm-allowed r))))
passwords))) passwords)))
; Little Helpers ; Little Helpers
; initialization-error-page : response ; initialization-error-page : response
(define initialization-error-page (define initialization-error-page
`(html (head (title "Web Server Configuration Program Invocation Error")) `(html (head (title "Web Server Configuration Program Invocation Error"))
@ -640,7 +635,7 @@
(a ([href ,(url->string (request-uri initial-request))]) "configuration program,") (a ([href ,(url->string (request-uri initial-request))]) "configuration program,")
" not through another URL.") " not through another URL.")
,footer))) ,footer)))
; done-page : html ; done-page : html
(define done-page (define done-page
; more-here - consider adding more useful information ; more-here - consider adding more useful information
@ -649,7 +644,7 @@
(h2 "Configuration Saved.") (h2 "Configuration Saved.")
(p "Click your browser's back button to continue configuring the server.") (p "Click your browser's back button to continue configuring the server.")
,footer))) ,footer)))
; exception-error-page : TST -> html ; exception-error-page : TST -> html
(define (exception-error-page exn) (define (exception-error-page exn)
`(html (head (title "Error")) `(html (head (title "Error"))
@ -657,41 +652,32 @@
(p "Servlet exception: " (p "Servlet exception: "
(pre ,(exn->string exn))) (pre ,(exn->string exn)))
,footer))) ,footer)))
(define must-select-host-page (define must-select-host-page
`(html (head (title "Web Server Configuration Error")) `(html (head (title "Web Server Configuration Error"))
(body ([bgcolor "white"]) (body ([bgcolor "white"])
(p "Please select which host to edit before clicking the Edit button.") (p "Please select which host to edit before clicking the Edit button.")
,footer))) ,footer)))
; io ; io
; read-configuration : path -> configuration-table ; read-configuration : path -> configuration-table
(define (read-configuration configuration-path) (define (read-configuration configuration-path)
(parse-configuration-table (call-with-input-file configuration-path read))) (parse-configuration-table (call-with-input-file configuration-path read)))
; write-configuration : configuration-table path -> void ; write-configuration : configuration-table path -> void
; writes out the new configuration file and ; writes out the new configuration file and
; also copies the configure.ss servlet to the default-host's servlet directory ; also copies the configure.ss servlet to the default-host's servlet directory
(define (write-configuration new configuration-path) (define (write-configuration new configuration-path)
(ensure-configuration-servlet configuration-path (configuration-table-default-host new)) (ensure-configuration-servlet configuration-path (configuration-table-default-host new))
(ensure-configuration-paths new) (ensure-configuration-paths new)
(write-to-file (write-configuration-table new configuration-path))
configuration-path
`((port ,(configuration-table-port new))
(max-waiting ,(configuration-table-max-waiting new))
(initial-connection-timeout ,(configuration-table-initial-connection-timeout new))
(default-host-table
,(format-host (configuration-table-default-host new)))
(virtual-host-table
. ,(map (lambda (h) (list (car h) (format-host (cdr h))))
(configuration-table-virtual-hosts new))))))
; ensure-configuration-servlet : path host-table -> void ; ensure-configuration-servlet : path host-table -> void
(define (ensure-configuration-servlet configuration-path host) (define (ensure-configuration-servlet configuration-path host)
(let* ([paths (host-table-paths host)] (let* ([paths (host-table-paths host)]
[root (build-path-unless-absolute web-base [root (build-path-unless-absolute web-base
(paths-host-base paths))] (paths-host-base paths))]
[servlets-path [servlets-path
(build-path (build-path-unless-absolute root (paths-servlet paths)) "servlets")]) (build-path (build-path-unless-absolute root (paths-servlet paths)) "servlets")])
(ensure-config-servlet configuration-path servlets-path) (ensure-config-servlet configuration-path servlets-path)
@ -699,14 +685,14 @@
(ensure* (collection-path "web-server" "default-web-root" "htdocs") (ensure* (collection-path "web-server" "default-web-root" "htdocs")
(build-path-unless-absolute root (paths-htdocs paths)) (build-path-unless-absolute root (paths-htdocs paths))
defaults)))) defaults))))
; ensure-configuration-paths : configuration-table -> void ; ensure-configuration-paths : configuration-table -> void
; to ensure that all the referenced config files exist for an entire configuration ; to ensure that all the referenced config files exist for an entire configuration
(define (ensure-configuration-paths configuration) (define (ensure-configuration-paths configuration)
(ensure-host-configuration (configuration-table-default-host configuration)) (ensure-host-configuration (configuration-table-default-host configuration))
(for-each (lambda (x) (ensure-host-configuration (cdr x))) (for-each (lambda (x) (ensure-host-configuration (cdr x)))
(configuration-table-virtual-hosts configuration))) (configuration-table-virtual-hosts configuration)))
; ensure-host-configuration : host-table -> void ; ensure-host-configuration : host-table -> void
; to ensure that all the referenced config files exist for a virtual host ; to ensure that all the referenced config files exist for a virtual host
(define (ensure-host-configuration host) (define (ensure-host-configuration host)
@ -735,7 +721,7 @@
(copy-conf "not-found.html" (messages-file-not-found messages)) (copy-conf "not-found.html" (messages-file-not-found messages))
(copy-conf "servlet-error.html" (messages-servlet messages)) (copy-conf "servlet-error.html" (messages-servlet messages))
(copy-conf "collect-garbage.html" (messages-collect-garbage messages))))) (copy-conf "collect-garbage.html" (messages-collect-garbage messages)))))
; ensure-file : path path path -> void ; ensure-file : path path path -> void
; to copy (build-path from name) to (build-path to name), creating directories as ; to copy (build-path from name) to (build-path to name), creating directories as
; needed if the latter does not already exist. ; needed if the latter does not already exist.
@ -745,14 +731,14 @@
(let ([to-path (build-path to name)]) (let ([to-path (build-path to name)])
(unless (file-exists? to-path) (unless (file-exists? to-path)
(copy-file (build-path from name) to-path))))) (copy-file (build-path from name) to-path)))))
; copy-file* : str str -> void ; copy-file* : str str -> void
(define (copy-file* from-path to-path) (define (copy-file* from-path to-path)
(unless (file-exists? to-path) (unless (file-exists? to-path)
(let-values ([(to-path-base to-path-name must-be-dir?) (split-path to-path)]) (let-values ([(to-path-base to-path-name must-be-dir?) (split-path to-path)])
(ensure-directory-shallow to-path-base)) (ensure-directory-shallow to-path-base))
(copy-file from-path to-path))) (copy-file from-path to-path)))
; ensure* : path path path -> void ; ensure* : path path path -> void
;; GregP: Don't know what the heck this does (thanks Paul) ;; GregP: Don't know what the heck this does (thanks Paul)
;; but the first two arguments are now paths. ;; but the first two arguments are now paths.
@ -768,13 +754,13 @@
(directory-list p))))] (directory-list p))))]
[(file-exists? p) [(file-exists? p)
(ensure-file from to name)]))) (ensure-file from to name)])))
; ensure-directory-shallow : path -> void ; ensure-directory-shallow : path -> void
(define (ensure-directory-shallow to) (define (ensure-directory-shallow to)
(unless (directory-exists? to) (unless (directory-exists? to)
; race condition - someone else could make the directory ; race condition - someone else could make the directory
(make-directory* to))) (make-directory* to)))
; ensure-config-servlet : str path -> void ; ensure-config-servlet : str path -> void
; to create, if necessary, a stub configuration servlet that includes the main configuration servlet ; to create, if necessary, a stub configuration servlet that includes the main configuration servlet
; at the desired location in a new web tree ; at the desired location in a new web tree
@ -792,39 +778,7 @@
(pretty-print (pretty-print
`(servlet-maker ,(path->string configuration-path)) `(servlet-maker ,(path->string configuration-path))
out)))))) out))))))
; format-host : host-table
(define (format-host host)
(let ([t (host-table-timeouts host)]
[p (host-table-paths host)]
[m (host-table-messages host)])
`(host-table
; more here - configure
(default-indices "index.html" "index.htm")
; more here - configure
(log-format parenthesized-default)
(messages
(servlet-message ,(messages-servlet m))
(authentication-message ,(messages-authentication m))
(servlets-refreshed ,(messages-servlets-refreshed m))
(passwords-refreshed ,(messages-passwords-refreshed m))
(file-not-found-message ,(messages-file-not-found m))
(protocol-message ,(messages-protocol m))
(collect-garbage ,(messages-collect-garbage m)))
(timeouts
(default-servlet-timeout ,(timeouts-default-servlet t))
(password-connection-timeout ,(timeouts-password t))
(servlet-connection-timeout ,(timeouts-servlet-connection t))
(file-per-byte-connection-timeout ,(timeouts-file-per-byte t))
(file-base-connection-timeout ,(timeouts-file-base t)))
(paths
(configuration-root ,(paths-conf p))
(host-root ,(paths-host-base p))
(log-file-path ,(paths-log p))
(file-root ,(paths-htdocs p))
(servlet-root ,(paths-servlet p))
(password-authentication ,(paths-passwords p))))))
; extract-definition : sym (listof s-expr) -> s-expr ; extract-definition : sym (listof s-expr) -> s-expr
; to return the rhs from (def name rhs) not (def (name . args) body) ; to return the rhs from (def name rhs) not (def (name . args) body)
(define (extract-definition name defs) (define (extract-definition name defs)
@ -835,12 +789,12 @@
(caddr def))) (caddr def)))
defs) defs)
(error 'extract-definition "definition for ~a not found" name))) (error 'extract-definition "definition for ~a not found" name)))
; passwords = str (i.e. path to a file) ; passwords = str (i.e. path to a file)
(define build-path-maybe-expression->file-name caddr) (define build-path-maybe-expression->file-name caddr)
; main ; main
(choose-configuration-file))) (choose-configuration-file)))
(define servlet (servlet-maker default-configuration-table-path))) (define servlet (servlet-maker default-configuration-table-path)))

4
collects/web-server/info.ss
View File

@ -1,7 +1,7 @@
(module info (lib "infotab.ss" "setup") (module info (lib "infotab.ss" "setup")
(define name "Web Server") (define name "Web Server")
(define mzscheme-launcher-libraries (list "text-launch.ss" "monitor-launch.ss")) (define mzscheme-launcher-libraries (list "text-launch.ss" "monitor-launch.ss" "setup-launch.ss" ))
(define mzscheme-launcher-names (list "web-server-text" "web-server-monitor")) (define mzscheme-launcher-names (list "web-server-text" "web-server-monitor" "web-server-setup"))
(define mred-launcher-libraries (list "gui-launch.ss")) (define mred-launcher-libraries (list "gui-launch.ss"))
(define mred-launcher-names (list "web-server"))) (define mred-launcher-names (list "web-server")))

2
collects/web-server/launch.ss
View File

@ -26,7 +26,7 @@
[("-p" "--port") [("-p" "--port")
,(lambda (flag port) ,(lambda (flag port)
(let ([p (string->number port)]) (let ([p (string->number port)])
(if (and (number? p) (integer? p) (exact? p) (<= 1 p 65535)) (if (valid-port? p)
(cons 'port p) (cons 'port p)
(error 'web-server "port expects an argument of type <exact integer in [1, 65535]>; given ~s" port)))) (error 'web-server "port expects an argument of type <exact integer in [1, 65535]>; given ~s" port))))
("Use an alternate network port." "port")] ("Use an alternate network port." "port")]

41
collects/web-server/setup-launch.ss Normal file
View File

@ -0,0 +1,41 @@
(module setup-launch mzscheme
(require (lib "cmdline.ss")
(lib "file.ss")
(lib "struct.ss"))
(require "configuration.ss"
"configuration-table-structs.ss"
"util.ss"
"configuration-util.ss")
(parse-command-line
"web-server-setup"
(current-command-line-arguments)
`((once-each
[("-p" "--port")
,(lambda (flag port)
(let ([p (string->number port)])
(if (valid-port? p)
(cons 'port p)
(error 'web-server-setup "port expects an argument of type <exact integer in [1, 65535]>; given ~s" port))))
("Use an alternate network port." "port")]
[("-d" "--destination")
,(lambda (flag destination)
(let ([p (normalize-path (string->path destination))])
(cons 'destination p)))
("Use an destination directory other than the current directory" "directory")]))
(lambda (flags)
(let ([port (extract-flag 'port flags 8080)]
[dest (extract-flag 'destination flags (current-directory))])
;; Create dest
(make-directory* dest)
;; Copy default-web-root into dest/default-web-root
(copy-directory/files (build-path (collection-path "web-server") "default-web-root")
(build-path dest "default-web-root"))
;; Read default configuration-table, changing the port
;; Write configuration-table into dest/configuration-table
(write-configuration-table
(copy-struct configuration-table
(get-configuration default-configuration-table-path)
[configuration-table-port port])
(build-path dest "configuration-table"))))
'()))

5
collects/web-server/util.ss
View File

@ -14,6 +14,7 @@
url-path->string) url-path->string)
(provide/contract (provide/contract
[valid-port? (any/c . -> . boolean?)]
[decompose-request ((request?) . ->* . (url? symbol? string?))] [decompose-request ((request?) . ->* . (url? symbol? string?))]
[network-error ((symbol? string?) (listof any/c) . ->* . (void))] [network-error ((symbol? string?) (listof any/c) . ->* . (void))]
[path->list (path? . -> . (cons/c (union path? (symbols 'up 'same)) [path->list (path? . -> . (cons/c (union path? (symbols 'up 'same))
@ -24,6 +25,10 @@
[exn->string ((union exn? any/c) . -> . string?)] [exn->string ((union exn? any/c) . -> . string?)]
[build-path-unless-absolute (path? (union string? path?) . -> . path?)]) [build-path-unless-absolute (path? (union string? path?) . -> . path?)])
;; valid-port? : any/c -> boolean?
(define (valid-port? p)
(and (number? p) (integer? p) (exact? p) (<= 1 p 65535)))
;; ripped this off from url-unit.ss ;; ripped this off from url-unit.ss
(define (url-path->string strs) (define (url-path->string strs)
(apply (apply