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"))
(provide complete-configuration
get-configuration
build-developer-configuration
build-developer-configuration/vhosts ;; added 2/3/05 by Jacob
default-configuration-table-path

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

@ -11,6 +11,7 @@
default-configuration-table-path)
(lib "configuration-table-structs.ss" "web-server")
(lib "parse-table.ss" "web-server")
(lib "configuration-util.ss" "web-server")
(all-except (lib "util.ss" "web-server") translate-escapes))
;; FIX
@ -213,12 +214,6 @@
(configuration-table-default-host conf)
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
; pre: (>= (length (configuration-table-virtual-hosts conf)) (max to-delete))
(define (delete-hosts conf to-delete)
@ -676,16 +671,7 @@
(define (write-configuration new configuration-path)
(ensure-configuration-servlet configuration-path (configuration-table-default-host new))
(ensure-configuration-paths new)
(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))))))
(write-configuration-table new configuration-path))
; ensure-configuration-servlet : path host-table -> void
(define (ensure-configuration-servlet configuration-path host)
@ -793,38 +779,6 @@
`(servlet-maker ,(path->string configuration-path))
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
; to return the rhs from (def name rhs) not (def (name . args) body)
(define (extract-definition name defs)

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

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

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

@ -26,7 +26,7 @@
[("-p" "--port")
,(lambda (flag port)
(let ([p (string->number port)])
(if (and (number? p) (integer? p) (exact? p) (<= 1 p 65535))
(if (valid-port? p)
(cons 'port p)
(error 'web-server "port expects an argument of type <exact integer in [1, 65535]>; given ~s" 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)
(provide/contract
[valid-port? (any/c . -> . boolean?)]
[decompose-request ((request?) . ->* . (url? symbol? string?))]
[network-error ((symbol? string?) (listof any/c) . ->* . (void))]
[path->list (path? . -> . (cons/c (union path? (symbols 'up 'same))
@ -24,6 +25,10 @@
[exn->string ((union exn? any/c) . -> . string?)]
[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
(define (url-path->string strs)
(apply