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

Eli

Browse Source 
svn: r4847
This commit is contained in:
Jay McCarthy 2006-11-14 05:13:47 +00:00
parent c5157e1b44
commit eff8a409a9
4 changed files with 68 additions and 75 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/help/private/config.ss
View File

@ -42,7 +42,7 @@
(servlet-root ,servlet-root)
(mime-types "../../web-server/default-web-root/mime.types")
(password-authentication "passwords"))))])
(build-developer-configuration/vhosts
(build-developer-configuration
`((port ,internal-port)
(max-waiting 40)
(initial-connection-timeout 30)

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

@ -1,5 +1,6 @@
(module configuration mzscheme
(require (lib "unitsig.ss")
(lib "kw.ss")
(lib "list.ss")
(lib "contract.ss"))
(require "private/configuration.ss"
@ -15,28 +16,29 @@
; 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-configuration-sexpr : sexp -> configuration
(define (load-configuration-sexpr sexpr)
(build-configuration (parse-configuration-table sexpr) empty))
(define/kw (load-configuration-sexpr sexpr
#:other-keys bct-keys)
(define table (parse-configuration-table sexpr))
(apply build-configuration table
(lambda (host)
(configuration-table-default-host table))
bct-keys))
; 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
; 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)))
(define (build-developer-configuration/vhosts s-expr)
(complete-developer-configuration/vhosts (directory-part default-configuration-table-path)
(parse-configuration-table s-expr)))
; : (listof (cons sym TST)) -> configuration
; more here - this is ugly. It also does not catch "unbound identifiers" since I use symbols.
@ -65,8 +67,6 @@
[get-configuration (path-string? . -> . configuration-table?)]
; XXX contract
[build-developer-configuration (list? . -> . configuration?)]
; XXX contract
[build-developer-configuration/vhosts (list? . -> . configuration?)]
[default-configuration-table-path path?]
[update-configuration (configuration? (listof (cons/c symbol? any/c)) . -> . configuration?)]
[load-configuration-sexpr (list? . -> . configuration?)]

83
collects/web-server/private/configuration.ss
View File

@ -1,5 +1,6 @@
(module configuration mzscheme
(require (lib "unitsig.ss")
(lib "kw.ss")
(lib "contract.ss"))
(require "configuration-structures.ss"
"configuration-table-structs.ss"
@ -7,20 +8,6 @@
"cache-table.ss"
"../sig.ss"
"../response-structs.ss")
; : 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)
@ -45,7 +32,10 @@
(configuration-table-default-host table)))))
; : configuration-table host-table -> configuration
(define (build-configuration table the-virtual-hosts)
(define/kw (build-configuration table the-virtual-hosts
#:key
[make-servlet-namespace default-make-servlet-namespace])
(define the-make-servlet-namespace make-servlet-namespace)
(unit/sig web-config^
(import)
(define port (configuration-table-port table))
@ -60,44 +50,48 @@
; 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
(define default-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 "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)])
(define/kw (make-make-servlet-namespace
#:key
[to-be-copied-module-specs default-to-be-copied-module-specs])
; 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
(lambda ()
(define server-namespace (current-namespace))
(define new-namespace (make-namespace))
(parameterize ([current-namespace new-namespace])
(for-each (lambda (name)
(with-handlers ([exn? void])
(namespace-attach-module server-namespace name)))
(namespace-attach-module server-namespace name))
to-be-copied-module-names)
new-namespace)))
(define default-make-servlet-namespace (make-make-servlet-namespace))
; 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
@ -222,13 +216,12 @@
expanded-virtual-host-table)
default-host)))
(provide ; XXX contract
build-configuration
make-make-servlet-namespace)
(provide/contract
[build-configuration (configuration-table? host-table? . -> . configuration?)]
[complete-configuration (path-string? configuration-table? . -> . configuration?)]
[complete-developer-configuration (path-string? configuration-table? . -> . configuration?)])
; XXX contract
(provide
complete-developer-configuration/vhosts)
(provide/contract
[error-response ((natural-number/c string? string?) (listof (cons/c symbol? string?)) . ->* . (response?))]
; XXX contract

36
collects/web-server/private/util.ss
View File

@ -6,38 +6,38 @@
(lib "plt-match.ss")
(lib "uri-codec.ss" "net"))
(require "../request-structs.ss")
;; valid-port? : any/c -> boolean?
(define (valid-port? p)
(and (integer? p) (exact? p) (<= 1 p 65535)))
;; ripped this off from url-unit.ss
(define (url-path->string strs)
(apply string-append
(apply append
(map (lambda (s) (list "/" (maybe-join-params s)))
strs))))
;; needs to unquote things!
(define (maybe-join-params s)
(if (string? s)
s
(let ([s (path/param-path s)])
(if (string? s)
s
(case s
[(same) "."]
[(up) ".."]
[else (error 'maybe-join-params
"bad value from path/param-path: ~e" s)])))))
s
(let ([s (path/param-path s)])
(if (string? s)
s
(case s
[(same) "."]
[(up) ".."]
[else (error 'maybe-join-params
"bad value from path/param-path: ~e" s)])))))
;; decompse-request : request -> uri * symbol * string
(define (decompose-request req)
(let* ([uri (request-uri req)]
[method (request-method req)]
[path (uri-decode (url-path->string (url-path uri)))])
(values uri method path)))
;; network-error: symbol string . values -> void
;; throws a formatted exn:fail:network
(define (network-error src fmt . args)
@ -45,8 +45,8 @@
(string->immutable-string
(format "~a: ~a" src (apply format fmt args)))
(current-continuation-marks))))
;; build-path-unless-absolute : path (or/c string? path?) -> path?
;; build-path-unless-absolute : path-string? path-string? -> path?
(define (build-path-unless-absolute base path)
(if (absolute-path? path)
(build-path path)
@ -160,7 +160,7 @@
; hash-table-empty? : hash-table -> bool
(define (hash-table-empty? table)
(zero? (hash-table-count table)))
(provide/contract
[url-path->string ((listof (or/c string? path/param?)) . -> . string?)]
[extract-flag (symbol? (listof (cons/c symbol? any/c)) any/c . -> . any/c)]
@ -174,4 +174,4 @@
[directory-part (path? . -> . path?)]
[lowercase-symbol! ((or/c string? bytes?) . -> . symbol?)]
[exn->string ((or/c exn? any/c) . -> . string?)]
[build-path-unless-absolute (path? (or/c string? path?) . -> . path?)]))
[build-path-unless-absolute (path-string? path-string? . -> . path?)]))