pr 8028 and 8029
svn: r3347
This commit is contained in:
parent
7015529bf5
commit
fa67303a75
27
collects/web-server/bindings.ss
Normal file
27
collects/web-server/bindings.ss
Normal file
|
@ -0,0 +1,27 @@
|
|||
(module bindings mzscheme
|
||||
(require (lib "list.ss"))
|
||||
(provide extract-binding/single
|
||||
extract-bindings
|
||||
exists-binding?)
|
||||
|
||||
; extract-binding/single : sym (listof (cons str str)) -> str
|
||||
(define (extract-binding/single name bindings)
|
||||
(define lst (extract-bindings name bindings))
|
||||
(cond
|
||||
[(empty? lst)
|
||||
(error 'extract-binding/single "~e not found in ~e" name bindings)]
|
||||
[(empty? (rest lst))
|
||||
(first lst)]
|
||||
[else
|
||||
(error 'extract-binding/single "~e occurs multiple times in ~e" name bindings)]))
|
||||
|
||||
; extract-bindings : sym (listof (cons str str)) -> (listof str)
|
||||
(define (extract-bindings name bindings)
|
||||
(map cdr (filter (lambda (x) (equal? name (car x))) bindings)))
|
||||
|
||||
; exists-binding? : sym (listof (cons sym str)) -> bool
|
||||
; for checkboxes
|
||||
(define (exists-binding? name bindings)
|
||||
(if (assq name bindings)
|
||||
#t
|
||||
#f)))
|
|
@ -21,6 +21,17 @@
|
|||
[load-configuration (path? . -> . unit/sig?)]
|
||||
[load-developer-configuration (path? . -> . unit/sig?)])
|
||||
|
||||
(provide error-response
|
||||
servlet-loading-responder
|
||||
gen-servlet-not-found
|
||||
gen-servlet-responder
|
||||
gen-servlets-refreshed
|
||||
gen-passwords-refreshed
|
||||
gen-authentication-responder
|
||||
gen-protocol-responder
|
||||
gen-file-not-found-responder
|
||||
gen-collect-garbage-responder)
|
||||
|
||||
(define default-configuration-table-path
|
||||
(build-path (collection-path "web-server") "configuration-table"))
|
||||
|
||||
|
|
|
@ -32,7 +32,7 @@
|
|||
|
||||
;; kill-connection!: connection -> void
|
||||
;; kill this connection
|
||||
(define (kill-connection! conn-demned)
|
||||
(define (kill-connection! conn-demned)
|
||||
(cancel-timer! (connection-timer conn-demned))
|
||||
(with-handlers ([exn:fail:network? void])
|
||||
(close-output-port (connection-o-port conn-demned)))
|
||||
|
|
|
@ -1,46 +1,54 @@
|
|||
(module dispatch-files mzscheme
|
||||
(require (lib "url.ss" "net")
|
||||
(lib "xml.ss" "xml")
|
||||
(lib "kw.ss")
|
||||
(lib "list.ss"))
|
||||
(require "dispatch.ss"
|
||||
"../configuration.ss"
|
||||
"../util.ss"
|
||||
"../mime-types.ss"
|
||||
"../response.ss")
|
||||
(provide interface-version
|
||||
gen-dispatcher)
|
||||
make)
|
||||
|
||||
(define interface-version 'v1)
|
||||
(define (gen-dispatcher htdocs-path mime-types-path indices file-not-found-responder)
|
||||
(let ([get-mime-type (make-get-mime-type mime-types-path)])
|
||||
(define/kw (make #:key
|
||||
[htdocs-path "htdocs"]
|
||||
[mime-types-path "mime.types"]
|
||||
[indices (list "index.html" "index.htm")]
|
||||
[file-not-found-responder
|
||||
(gen-file-not-found-responder "not-found.html")])
|
||||
(define get-mime-type (make-get-mime-type mime-types-path))
|
||||
(lambda (conn req)
|
||||
(let-values ([(uri method path) (decompose-request req)])
|
||||
;; ************************************************************
|
||||
;; ************************************************************
|
||||
;; SERVING FILES
|
||||
|
||||
;; serve-file : connection symbol uri host -> void
|
||||
;; to find the file, including searching for implicit index files, and serve it out
|
||||
(let ([path (url-path->path htdocs-path
|
||||
(translate-escapes (url-path->string (url-path uri))))])
|
||||
(cond
|
||||
[(file-exists? path)
|
||||
(output-file conn path method (get-mime-type path))]
|
||||
[(directory-exists? path)
|
||||
(let loop ([dir-defaults indices])
|
||||
(cond
|
||||
[(pair? dir-defaults)
|
||||
(let ([full-name (build-path path (first dir-defaults))])
|
||||
(if (file-exists? full-name)
|
||||
(cond
|
||||
[(looks-like-directory? (url-path->string (url-path uri)))
|
||||
(output-file conn full-name method (get-mime-type full-name))]
|
||||
[else
|
||||
(output-slash-message conn method (url-path->string (url-path uri)))])
|
||||
(loop (rest dir-defaults))))]
|
||||
[else
|
||||
(output-response/method conn (file-not-found-responder uri) method)]))]
|
||||
[else
|
||||
(output-response/method conn (file-not-found-responder uri) method)]))))))
|
||||
(define-values (uri method _path) (decompose-request req))
|
||||
;; ************************************************************
|
||||
;; ************************************************************
|
||||
;; SERVING FILES
|
||||
|
||||
;; serve-file : connection symbol uri host -> void
|
||||
;; to find the file, including searching for implicit index files, and serve it out
|
||||
(define path
|
||||
(url-path->path htdocs-path
|
||||
(translate-escapes (url-path->string (url-path uri)))))
|
||||
(cond
|
||||
[(file-exists? path)
|
||||
(output-file conn path method (get-mime-type path))]
|
||||
[(directory-exists? path)
|
||||
(let loop ([dir-defaults indices])
|
||||
(cond
|
||||
[(pair? dir-defaults)
|
||||
(let ([full-name (build-path path (first dir-defaults))])
|
||||
(if (file-exists? full-name)
|
||||
(cond
|
||||
[(looks-like-directory? (url-path->string (url-path uri)))
|
||||
(output-file conn full-name method (get-mime-type full-name))]
|
||||
[else
|
||||
(output-slash-message conn method (url-path->string (url-path uri)))])
|
||||
(loop (rest dir-defaults))))]
|
||||
[else
|
||||
(output-response/method conn (file-not-found-responder uri) method)]))]
|
||||
[else
|
||||
(output-response/method conn (file-not-found-responder uri) method)])))
|
||||
|
||||
;; looks-like-directory : str -> bool
|
||||
;; to determine if is url style path looks like it refers to a directory
|
||||
|
|
|
@ -2,10 +2,10 @@
|
|||
(require "dispatch.ss"
|
||||
"../servlet-helpers.ss")
|
||||
(provide interface-version
|
||||
gen-dispatcher)
|
||||
make)
|
||||
|
||||
(define interface-version 'v1)
|
||||
(define (gen-dispatcher lookup-dispatcher)
|
||||
(define (make lookup-dispatcher)
|
||||
(lambda (conn req)
|
||||
(let* ([host (get-host (request-uri req) (request-headers/raw req))])
|
||||
((lookup-dispatcher host) conn req)))))
|
|
@ -1,15 +1,18 @@
|
|||
(module dispatch-log mzscheme
|
||||
(require (lib "url.ss" "net")
|
||||
(lib "date.ss")
|
||||
(lib "kw.ss")
|
||||
(lib "async-channel.ss")
|
||||
(lib "plt-match.ss"))
|
||||
(require "dispatch.ss"
|
||||
"../servlet-helpers.ss")
|
||||
(provide interface-version
|
||||
gen-dispatcher)
|
||||
make)
|
||||
|
||||
(define interface-version 'v1)
|
||||
(define (gen-dispatcher log-format log-path)
|
||||
(define/kw (make #:key
|
||||
[log-format 'parenthesized-default]
|
||||
[log-path #f])
|
||||
(if log-path
|
||||
(case log-format
|
||||
[(parenthesized-default)
|
||||
|
@ -34,31 +37,31 @@
|
|||
; to produce a string that is displayed into the log file
|
||||
; This is a kill-safe wait-less abstraction
|
||||
(define (gen-log-message log-format log-path)
|
||||
(let* ([log-ch (make-async-channel)]
|
||||
[log-thread
|
||||
(thread/suspend-to-kill
|
||||
(lambda ()
|
||||
(let loop ([log-p #f])
|
||||
(with-handlers ([exn? (lambda (e) (loop #f))])
|
||||
(if (not (and log-p (file-exists? log-path)))
|
||||
(begin
|
||||
(unless (eq? log-p #f)
|
||||
(close-output-port log-p))
|
||||
(let ([new-log-p (open-output-file log-path 'append)])
|
||||
(file-stream-buffer-mode new-log-p 'line)
|
||||
(loop new-log-p)))
|
||||
(sync
|
||||
(handle-evt
|
||||
log-ch
|
||||
(match-lambda
|
||||
[(list host-ip client-ip method uri host)
|
||||
(display
|
||||
(format "~s~n"
|
||||
(list 'from client-ip 'to host-ip 'for (url->string uri) 'at
|
||||
(date->string (seconds->date (current-seconds)) #t)))
|
||||
log-p)
|
||||
(loop log-p)]))))))))])
|
||||
(lambda args
|
||||
(thread-resume log-thread)
|
||||
(async-channel-put log-ch args)
|
||||
(void)))))
|
||||
(define log-ch (make-async-channel))
|
||||
(define log-thread
|
||||
(thread/suspend-to-kill
|
||||
(lambda ()
|
||||
(let loop ([log-p #f])
|
||||
(with-handlers ([exn? (lambda (e) (loop #f))])
|
||||
(if (not (and log-p (file-exists? log-path)))
|
||||
(begin
|
||||
(unless (eq? log-p #f)
|
||||
(close-output-port log-p))
|
||||
(let ([new-log-p (open-output-file log-path 'append)])
|
||||
(file-stream-buffer-mode new-log-p 'line)
|
||||
(loop new-log-p)))
|
||||
(sync
|
||||
(handle-evt
|
||||
log-ch
|
||||
(match-lambda
|
||||
[(list host-ip client-ip method uri host)
|
||||
(display
|
||||
(format "~s~n"
|
||||
(list 'from client-ip 'to host-ip 'for (url->string uri) 'at
|
||||
(date->string (seconds->date (current-seconds)) #t)))
|
||||
log-p)
|
||||
(loop log-p)])))))))))
|
||||
(lambda args
|
||||
(thread-resume log-thread (current-custodian))
|
||||
(async-channel-put log-ch args)
|
||||
(void))))
|
|
@ -1,42 +1,47 @@
|
|||
(module dispatch-passwords mzscheme
|
||||
(require (lib "kw.ss"))
|
||||
(require "dispatch.ss"
|
||||
(all-except "../util.ss" translate-escapes)
|
||||
"../configuration.ss"
|
||||
"../servlet-helpers.ss"
|
||||
"../connection-manager.ss"
|
||||
"../response.ss")
|
||||
|
||||
"../response.ss")
|
||||
(provide interface-version
|
||||
gen-dispatcher)
|
||||
make)
|
||||
|
||||
(define interface-version 'v1)
|
||||
(define (gen-dispatcher password-file password-connection-timeout authentication-responder passwords-refresh-responder)
|
||||
(let* ([password-cache (box #f)]
|
||||
[reset-password-cache!
|
||||
(lambda ()
|
||||
; more here - a malformed password file will kill the connection
|
||||
(set-box! password-cache (read-passwords password-file)))]
|
||||
[read-password-cache
|
||||
(lambda ()
|
||||
(unbox password-cache))])
|
||||
(reset-password-cache!)
|
||||
(lambda (conn req)
|
||||
(let-values ([(uri method path) (decompose-request req)])
|
||||
(cond
|
||||
[(access-denied? method path (request-headers/raw req) (read-password-cache))
|
||||
=> (lambda (realm)
|
||||
(adjust-connection-timeout! conn password-connection-timeout)
|
||||
(request-authentication conn method uri
|
||||
authentication-responder
|
||||
realm))]
|
||||
[(string=? "/conf/refresh-passwords" path)
|
||||
;; more here - send a nice error page
|
||||
(reset-password-cache!)
|
||||
(output-response/method
|
||||
conn
|
||||
(passwords-refresh-responder)
|
||||
method)]
|
||||
[else
|
||||
(next-dispatcher)])))))
|
||||
(define/kw (make #:key
|
||||
[password-file "passwords"]
|
||||
[password-connection-timeout 300]
|
||||
[authentication-responder
|
||||
(gen-authentication-responder "forbidden.html")]
|
||||
[passwords-refresh-responder
|
||||
(gen-passwords-refreshed "passwords-refresh.html")])
|
||||
(define password-cache (box #f))
|
||||
(define (reset-password-cache!)
|
||||
; more here - a malformed password file will kill the connection
|
||||
(set-box! password-cache (read-passwords password-file)))
|
||||
(define (read-password-cache)
|
||||
(unbox password-cache))
|
||||
(reset-password-cache!)
|
||||
(lambda (conn req)
|
||||
(define-values (uri method path) (decompose-request req))
|
||||
(cond
|
||||
[(access-denied? method path (request-headers/raw req) (read-password-cache))
|
||||
=> (lambda (realm)
|
||||
(adjust-connection-timeout! conn password-connection-timeout)
|
||||
(request-authentication conn method uri
|
||||
authentication-responder
|
||||
realm))]
|
||||
[(string=? "/conf/refresh-passwords" path)
|
||||
;; more here - send a nice error page
|
||||
(reset-password-cache!)
|
||||
(output-response/method
|
||||
conn
|
||||
(passwords-refresh-responder)
|
||||
method)]
|
||||
[else
|
||||
(next-dispatcher)])))
|
||||
|
||||
;; ****************************************
|
||||
;; ****************************************
|
||||
|
@ -49,10 +54,10 @@
|
|||
;; denied?: str sym str -> (or/c str #f)
|
||||
;; the return string is the prompt for authentication
|
||||
(define (access-denied? method uri-str headers denied?)
|
||||
(let ([user-pass (extract-user-pass headers)])
|
||||
(if user-pass
|
||||
(denied? uri-str (lowercase-symbol! (car user-pass)) (cdr user-pass))
|
||||
(denied? uri-str fake-user ""))))
|
||||
(define user-pass (extract-user-pass headers))
|
||||
(if user-pass
|
||||
(denied? uri-str (lowercase-symbol! (car user-pass)) (cdr user-pass))
|
||||
(denied? uri-str fake-user "")))
|
||||
|
||||
(define-struct (exn:password-file exn) ())
|
||||
|
||||
|
|
|
@ -3,10 +3,10 @@
|
|||
"../util.ss"
|
||||
"../response.ss")
|
||||
(provide interface-version
|
||||
gen-dispatcher)
|
||||
make)
|
||||
|
||||
(define interface-version 'v1)
|
||||
(define ((gen-dispatcher the-path procedure) conn req)
|
||||
(define ((make the-path procedure) conn req)
|
||||
(let-values ([(uri method path) (decompose-request req)])
|
||||
(if (string=? the-path path)
|
||||
(output-response/method
|
||||
|
|
|
@ -2,10 +2,10 @@
|
|||
(require (lib "list.ss"))
|
||||
(require "dispatch.ss")
|
||||
(provide interface-version
|
||||
gen-dispatcher)
|
||||
make)
|
||||
|
||||
(define interface-version 'v1)
|
||||
(define ((gen-dispatcher . dispatchers) conn req)
|
||||
(define ((make . dispatchers) conn req)
|
||||
(let loop ([dispatchers dispatchers])
|
||||
(let ([c (first dispatchers)])
|
||||
(with-handlers ([exn:dispatcher?
|
||||
|
|
|
@ -1,5 +1,6 @@
|
|||
(module dispatch-servlets mzscheme
|
||||
(require (lib "url.ss" "net")
|
||||
(lib "kw.ss")
|
||||
(lib "plt-match.ss")
|
||||
(lib "unitsig.ss"))
|
||||
(require "dispatch.ss"
|
||||
|
@ -8,6 +9,7 @@
|
|||
"../response.ss"
|
||||
"../servlet.ss"
|
||||
"../sig.ss"
|
||||
"../configuration.ss"
|
||||
(all-except "../util.ss" translate-escapes)
|
||||
"../managers/manager.ss"
|
||||
"../managers/timeouts.ss"
|
||||
|
@ -15,14 +17,22 @@
|
|||
"../private/servlet.ss"
|
||||
"../private/cache-table.ss")
|
||||
(provide interface-version
|
||||
gen-dispatcher)
|
||||
make)
|
||||
|
||||
(define interface-version 'v1)
|
||||
(define (gen-dispatcher config:instances config:scripts config:make-servlet-namespace
|
||||
servlet-root
|
||||
responders-servlets-refreshed responders-servlet-loading responders-servlet
|
||||
responders-file-not-found
|
||||
timeouts-servlet-connection timeouts-default-servlet)
|
||||
(define/kw (make config:instances config:scripts config:make-servlet-namespace
|
||||
#:key
|
||||
[servlet-root "servlets"]
|
||||
[responders-servlets-refreshed
|
||||
(gen-servlets-refreshed "servlet-refresh.html")]
|
||||
[responders-servlet-loading
|
||||
servlet-loading-responder]
|
||||
[responders-servlet
|
||||
(gen-servlet-responder "servlet-error.html")]
|
||||
[responders-file-not-found
|
||||
(gen-file-not-found-responder "not-found.html")]
|
||||
[timeouts-servlet-connection (* 60 60 24)]
|
||||
[timeouts-default-servlet 30])
|
||||
;; ************************************************************
|
||||
;; ************************************************************
|
||||
;; SERVING SERVLETS
|
||||
|
@ -47,7 +57,7 @@
|
|||
(invoke-servlet-continuation conn req instance-id k-id salt)])]
|
||||
[else
|
||||
(servlet-content-producer/path conn req uri)])]))
|
||||
|
||||
|
||||
;; servlet-content-producer/path: connection request url -> void
|
||||
;; This is not a continuation url so the loading behavior is determined
|
||||
;; by the url path. Build the servlet path and then load the servlet
|
||||
|
@ -279,9 +289,9 @@
|
|||
(make-servlet (current-custodian)
|
||||
(current-namespace)
|
||||
(create-timeout-manager
|
||||
default-servlet-instance-expiration-handler
|
||||
timeouts-servlet-connection
|
||||
timeouts-default-servlet)
|
||||
default-servlet-instance-expiration-handler
|
||||
timeouts-servlet-connection
|
||||
timeouts-default-servlet)
|
||||
(v0.servlet->v1.lambda s))]
|
||||
; FIX - reason about exceptions from dynamic require (catch and report if not already)
|
||||
;; module servlet
|
||||
|
@ -295,9 +305,9 @@
|
|||
(make-servlet (current-custodian)
|
||||
(current-namespace)
|
||||
(create-timeout-manager
|
||||
default-servlet-instance-expiration-handler
|
||||
timeouts-servlet-connection
|
||||
timeouts-default-servlet)
|
||||
default-servlet-instance-expiration-handler
|
||||
timeouts-servlet-connection
|
||||
timeouts-default-servlet)
|
||||
(v1.module->v1.lambda timeout start)))]
|
||||
[(v2-transitional) ; XXX: Undocumented
|
||||
(let ([start (dynamic-require module-name 'start)]
|
||||
|
@ -308,9 +318,9 @@
|
|||
(define instance-expiration-handler
|
||||
(dynamic-require module-name 'instance-expiration-handler))
|
||||
(create-timeout-manager
|
||||
instance-expiration-handler
|
||||
timeouts-servlet-connection
|
||||
timeout))])
|
||||
instance-expiration-handler
|
||||
timeouts-servlet-connection
|
||||
timeout))])
|
||||
(dynamic-require module-name 'manager))])
|
||||
(make-servlet (current-custodian)
|
||||
(current-namespace)
|
||||
|
@ -323,9 +333,9 @@
|
|||
(make-servlet (current-custodian)
|
||||
(current-namespace)
|
||||
(create-timeout-manager
|
||||
default-servlet-instance-expiration-handler
|
||||
timeouts-servlet-connection
|
||||
timeouts-default-servlet)
|
||||
default-servlet-instance-expiration-handler
|
||||
timeouts-servlet-connection
|
||||
timeouts-default-servlet)
|
||||
(v0.response->v1.lambda s a-path))]
|
||||
[else
|
||||
(error 'load-servlet/path "Loading ~e produced ~n~e~n instead of a servlet." a-path s)])))
|
||||
|
|
|
@ -1,82 +1,85 @@
|
|||
(module parse-table mzscheme
|
||||
(require (lib "match.ss")
|
||||
"configuration-table-structs.ss")
|
||||
(require (lib "list.ss"))
|
||||
(require "configuration-table-structs.ss"
|
||||
"bindings.ss")
|
||||
(provide parse-configuration-table)
|
||||
|
||||
|
||||
(define (get-binding key bindings default)
|
||||
(first (get-binding* key bindings (list default))))
|
||||
|
||||
(define (get-binding* key bindings default)
|
||||
(with-handlers ([exn? (lambda _ default)])
|
||||
(extract-binding/single key bindings)))
|
||||
|
||||
; parse-configuration-table : tst -> configuration-table
|
||||
(define parse-configuration-table
|
||||
(match-lambda
|
||||
[`((port ,port)
|
||||
(max-waiting ,max-waiting)
|
||||
(initial-connection-timeout ,initial-connection-timeout)
|
||||
(default-host-table
|
||||
,default-host-table)
|
||||
(virtual-host-table . ,virtual-host-table))
|
||||
(if (and (nat? port) (nat? max-waiting) (number? initial-connection-timeout)
|
||||
; more here - list? isn't really picky enough
|
||||
(list? virtual-host-table))
|
||||
(make-configuration-table
|
||||
port max-waiting initial-connection-timeout
|
||||
(parse-host default-host-table)
|
||||
(map (lambda (h)
|
||||
(if (and (pair? h) (pair? (cdr h)) (null? (cddr h)))
|
||||
(cons (car h) (parse-host (cadr h)))
|
||||
(error 'parse-configuration-table "invalid virtual-host entry ~s" h)))
|
||||
virtual-host-table))
|
||||
(error 'parse-configuration-table "invalid configuration values ~s"
|
||||
(list port max-waiting initial-connection-timeout default-host-table virtual-host-table)))]
|
||||
[x (error 'parse-configuration-table "malformed configuration ~s" x)]))
|
||||
(define (parse-configuration-table t)
|
||||
(define port (get-binding 'port t 80))
|
||||
(define max-waiting (get-binding 'max-waiting t 40))
|
||||
(define initial-connection-timeout (get-binding 'initial-connection-timeout t 30))
|
||||
(define default-host-table (get-binding* 'default-host-table t `()))
|
||||
(define virtual-host-table (get-binding* 'virtual-host-table t `()))
|
||||
(if (and (nat? port) (nat? max-waiting) (number? initial-connection-timeout)
|
||||
; more here - list? isn't really picky enough
|
||||
(list? virtual-host-table))
|
||||
(make-configuration-table
|
||||
port max-waiting initial-connection-timeout
|
||||
(parse-host default-host-table)
|
||||
(map (lambda (h)
|
||||
(if (and (pair? h) (pair? (cdr h)) (null? (cddr h)))
|
||||
(cons (car h) (parse-host (cadr h)))
|
||||
(error 'parse-configuration-table "invalid virtual-host entry ~s" h)))
|
||||
virtual-host-table))
|
||||
(error 'parse-configuration-table "invalid configuration values ~s"
|
||||
(list port max-waiting initial-connection-timeout default-host-table virtual-host-table))))
|
||||
|
||||
; parse-host : tst -> host-table
|
||||
(define parse-host
|
||||
(match-lambda
|
||||
[`(host-table
|
||||
(default-indices . ,default-indices)
|
||||
(log-format ,log-format)
|
||||
(messages
|
||||
(servlet-message ,servlet-message)
|
||||
(authentication-message ,authentication-message)
|
||||
(servlets-refreshed ,servlets-refreshed)
|
||||
(passwords-refreshed ,passwords-refreshed)
|
||||
(file-not-found-message ,file-not-found-message)
|
||||
(protocol-message ,protocol-message)
|
||||
(collect-garbage ,collect-garbage))
|
||||
(timeouts
|
||||
(default-servlet-timeout ,default-servlet-timeout)
|
||||
(password-connection-timeout ,password-connection-timeout)
|
||||
(servlet-connection-timeout ,servlet-connection-timeout)
|
||||
(file-per-byte-connection-timeout ,file-per-byte-connection-timeout)
|
||||
(file-base-connection-timeout ,file-base-connection-timeout))
|
||||
(paths
|
||||
(configuration-root ,configuration-root)
|
||||
(host-root ,host-root)
|
||||
(log-file-path ,log-file-path)
|
||||
(file-root ,file-root)
|
||||
(servlet-root ,servlet-root)
|
||||
(mime-types ,mime-types)
|
||||
(password-authentication ,password-authentication)))
|
||||
(make-host-table
|
||||
default-indices log-format
|
||||
(make-messages servlet-message
|
||||
authentication-message
|
||||
servlets-refreshed
|
||||
passwords-refreshed
|
||||
file-not-found-message
|
||||
protocol-message
|
||||
collect-garbage)
|
||||
(make-timeouts default-servlet-timeout
|
||||
password-connection-timeout
|
||||
servlet-connection-timeout
|
||||
file-per-byte-connection-timeout
|
||||
file-base-connection-timeout)
|
||||
(make-paths configuration-root
|
||||
host-root
|
||||
log-file-path
|
||||
file-root
|
||||
servlet-root
|
||||
mime-types
|
||||
password-authentication))]
|
||||
[x (error 'parse-host "malformed host ~s" x)]))
|
||||
(define (parse-host t)
|
||||
(define host-table (get-binding* 'host-table t `()))
|
||||
(define default-indices (get-binding* 'default-indices host-table `("index.html" "index.htm")))
|
||||
(define log-format (get-binding 'log-format host-table 'parenthesized-default))
|
||||
(define messages (get-binding* 'messages host-table `()))
|
||||
(define servlet-message (get-binding 'servlet-message messages "servlet-error.html"))
|
||||
(define authentication-message (get-binding 'authentication-message messages "forbidden.html"))
|
||||
(define servlets-refreshed (get-binding 'servlets-refreshed messages "servlet-refresh.html"))
|
||||
(define passwords-refreshed (get-binding 'passwords-refreshed messages "passwords-refresh.html"))
|
||||
(define file-not-found-message (get-binding 'file-not-found-message messages "not-found.html"))
|
||||
(define protocol-message (get-binding 'protocol-message messages "protocol-error.html"))
|
||||
(define collect-garbage (get-binding 'collect-garbage messages "collect-garbage.html"))
|
||||
(define timeouts (get-binding* 'timeouts host-table `()))
|
||||
(define default-servlet-timeout (get-binding 'default-servlet-timeout timeouts 30))
|
||||
(define password-connection-timeout (get-binding 'password-connection-timeout timeouts 300))
|
||||
(define servlet-connection-timeout (get-binding 'servlet-connection-timeout timeouts (* 60 60 24)))
|
||||
(define file-per-byte-connection-timeout (get-binding 'file-per-byte-connection-timeout timeouts 1/20))
|
||||
(define file-base-connection-timeout (get-binding 'file-base-connection-timeout timeouts 30))
|
||||
(define paths (get-binding* 'paths host-table `()))
|
||||
(define configuration-root (get-binding 'configuration-root paths "conf"))
|
||||
(define host-root (get-binding 'host-root paths "default-web-root"))
|
||||
(define log-file-path (get-binding 'log-file-path paths "log"))
|
||||
(define file-root (get-binding 'file-root paths "htdocs"))
|
||||
(define servlet-root (get-binding 'servlet-root paths "."))
|
||||
(define mime-types (get-binding 'mime-types paths "mime.types"))
|
||||
(define password-authentication (get-binding 'password-authentication paths "passwords"))
|
||||
(make-host-table
|
||||
default-indices log-format
|
||||
(make-messages servlet-message
|
||||
authentication-message
|
||||
servlets-refreshed
|
||||
passwords-refreshed
|
||||
file-not-found-message
|
||||
protocol-message
|
||||
collect-garbage)
|
||||
(make-timeouts default-servlet-timeout
|
||||
password-connection-timeout
|
||||
servlet-connection-timeout
|
||||
file-per-byte-connection-timeout
|
||||
file-base-connection-timeout)
|
||||
(make-paths configuration-root
|
||||
host-root
|
||||
log-file-path
|
||||
file-root
|
||||
servlet-root
|
||||
mime-types
|
||||
password-authentication)))
|
||||
|
||||
; nat? : tst -> bool
|
||||
(define (nat? x)
|
||||
|
|
|
@ -7,11 +7,10 @@
|
|||
(lib "url.ss" "net"))
|
||||
(require "util.ss"
|
||||
"response.ss"
|
||||
"request-structs.ss")
|
||||
"request-structs.ss"
|
||||
"bindings.ss")
|
||||
(provide get-host
|
||||
extract-binding/single
|
||||
extract-bindings
|
||||
exists-binding?
|
||||
(all-from "bindings.ss")
|
||||
extract-user-pass
|
||||
build-suspender
|
||||
make-html-response/incremental
|
||||
|
@ -52,27 +51,7 @@
|
|||
[(struct header (_ v))
|
||||
(string->symbol (bytes->string/utf-8 v))])]
|
||||
[else DEFAULT-HOST-NAME]))
|
||||
|
||||
; extract-binding/single : sym (listof (cons str str)) -> str
|
||||
(define (extract-binding/single name bindings)
|
||||
(let ([lst (extract-bindings name bindings)])
|
||||
(cond
|
||||
[(null? lst)
|
||||
(error 'extract-binding/single "~e not found in ~e" name bindings)]
|
||||
[(null? (cdr lst)) (car lst)]
|
||||
[else (error 'extract-binding/single "~e occurs multiple times in ~e" name bindings)])))
|
||||
|
||||
; extract-bindings : sym (listof (cons str str)) -> (listof str)
|
||||
(define (extract-bindings name bindings)
|
||||
(map cdr (filter (lambda (x) (equal? name (car x))) bindings)))
|
||||
|
||||
; exists-binding? : sym (listof (cons sym str)) -> bool
|
||||
; for checkboxes
|
||||
(define (exists-binding? name bindings)
|
||||
(if (assq name bindings)
|
||||
#t
|
||||
#f))
|
||||
|
||||
|
||||
; build-suspender : (listof html) (listof html) [(listof (cons sym str))] [(listof (cons sym str))] -> str -> response
|
||||
(define build-suspender
|
||||
(opt-lambda (title content [body-attributes '([bgcolor "white"])] [head-attributes null])
|
||||
|
|
|
@ -6,9 +6,9 @@
|
|||
start-timer reset-timer! increment-timer!
|
||||
cancel-timer!
|
||||
start-timer-manager)
|
||||
|
||||
|
||||
(define timer-ch (make-async-channel))
|
||||
|
||||
|
||||
; start-timer-manager : custodian -> void
|
||||
; The timer manager thread
|
||||
(define (start-timer-manager server-custodian)
|
||||
|
@ -35,42 +35,46 @@
|
|||
(loop (remq timer timers)))))
|
||||
timers))))))
|
||||
(void))
|
||||
|
||||
|
||||
;; Limitation on this add-timer: thunk cannot make timer
|
||||
;; requests directly, because it's executed directly by
|
||||
;; the timer-manager thread
|
||||
;; add-timer : number (-> void) -> timer
|
||||
(define (add-timer msecs thunk)
|
||||
(let* ([now (current-inexact-milliseconds)]
|
||||
[timer
|
||||
(make-timer (alarm-evt (+ now msecs))
|
||||
(+ now msecs)
|
||||
thunk)])
|
||||
(async-channel-put timer-ch
|
||||
(lambda (timers)
|
||||
(cons timer timers)))
|
||||
timer))
|
||||
|
||||
(define now (current-inexact-milliseconds))
|
||||
(define timer
|
||||
(make-timer (alarm-evt (+ now msecs))
|
||||
(+ now msecs)
|
||||
thunk))
|
||||
(async-channel-put
|
||||
timer-ch
|
||||
(lambda (timers)
|
||||
(list* timer timers)))
|
||||
timer)
|
||||
|
||||
; revise-timer! : timer msecs (-> void) -> timer
|
||||
; revise the timer to ring msecs from now
|
||||
(define (revise-timer! timer msecs thunk)
|
||||
(let ([now (current-inexact-milliseconds)])
|
||||
(async-channel-put
|
||||
timer-ch
|
||||
(lambda (timers)
|
||||
(set-timer-evt! timer (alarm-evt (+ now msecs)))
|
||||
(set-timer-expire-seconds! timer (+ now msecs))
|
||||
(set-timer-action! timer thunk)
|
||||
timers))))
|
||||
|
||||
(define now (current-inexact-milliseconds))
|
||||
(async-channel-put
|
||||
timer-ch
|
||||
(lambda (timers)
|
||||
(set-timer-evt! timer (alarm-evt (+ now msecs)))
|
||||
(set-timer-expire-seconds! timer (+ now msecs))
|
||||
(set-timer-action! timer thunk)
|
||||
timers)))
|
||||
|
||||
(define (cancel-timer! timer)
|
||||
(revise-timer! timer 0 void))
|
||||
|
||||
(async-channel-put
|
||||
timer-ch
|
||||
(lambda (timers)
|
||||
(remq timer timers))))
|
||||
|
||||
; start-timer : num (-> void) -> timer
|
||||
; to make a timer that calls to-do after sec from make-timer's application
|
||||
(define (start-timer secs to-do)
|
||||
(add-timer (* 1000 secs) to-do))
|
||||
|
||||
|
||||
; reset-timer : timer num -> void
|
||||
; to cause timer to expire after sec from the adjust-msec-to-live's application
|
||||
(define (reset-timer! timer secs)
|
||||
|
|
|
@ -17,7 +17,9 @@
|
|||
(require (lib "tcp-sig.ss" "net")
|
||||
(lib "unitsig.ss")
|
||||
(lib "string.ss")
|
||||
(lib "list.ss")
|
||||
(lib "url.ss" "net"))
|
||||
|
||||
(provide web-server@)
|
||||
|
||||
;; ****************************************
|
||||
|
@ -123,41 +125,42 @@
|
|||
(define initial-connection-timeout config:initial-connection-timeout)
|
||||
|
||||
;; dispatch : connection request -> void
|
||||
(define dispatch-cache (make-cache-table))
|
||||
(define dispatch
|
||||
(let ([cache (make-cache-table)])
|
||||
(host:gen-dispatcher
|
||||
(lambda (host)
|
||||
(cache-table-lookup!
|
||||
cache host
|
||||
(lambda ()
|
||||
(host:make
|
||||
(lambda (host)
|
||||
(cache-table-lookup!
|
||||
dispatch-cache host
|
||||
(lambda ()
|
||||
(parameterize ([current-custodian (current-server-custodian)])
|
||||
(host-info->dispatcher
|
||||
(config:virtual-hosts (symbol->string host)))))))))
|
||||
|
||||
;; host-info->dispatcher : host-info -> conn request -> void
|
||||
(define (host-info->dispatcher host-info)
|
||||
(sequencer:gen-dispatcher
|
||||
(log:gen-dispatcher (host-log-format host-info)
|
||||
(host-log-path host-info))
|
||||
(passwords:gen-dispatcher (host-passwords host-info)
|
||||
(timeouts-password (host-timeouts host-info))
|
||||
(responders-authentication (host-responders host-info))
|
||||
(responders-passwords-refreshed (host-responders host-info)))
|
||||
(path-procedure:gen-dispatcher "/conf/collect-garbage"
|
||||
(lambda ()
|
||||
(collect-garbage)
|
||||
((responders-collect-garbage (host-responders host-info)))))
|
||||
(servlets:gen-dispatcher config:instances config:scripts config:make-servlet-namespace
|
||||
(paths-servlet (host-paths host-info))
|
||||
(responders-servlets-refreshed (host-responders host-info))
|
||||
(responders-servlet-loading (host-responders host-info))
|
||||
(responders-servlet (host-responders host-info))
|
||||
(responders-file-not-found (host-responders host-info))
|
||||
(timeouts-servlet-connection (host-timeouts host-info))
|
||||
(timeouts-default-servlet (host-timeouts host-info)))
|
||||
(files:gen-dispatcher (paths-htdocs (host-paths host-info))
|
||||
(paths-mime-types (host-paths host-info))
|
||||
(host-indices host-info)
|
||||
(responders-file-not-found (host-responders host-info)))))))
|
||||
(sequencer:make
|
||||
(log:make #:log-format (host-log-format host-info)
|
||||
#:log-path (host-log-path host-info))
|
||||
(passwords:make #:password-file (host-passwords host-info)
|
||||
#:password-connection-timeout (timeouts-password (host-timeouts host-info))
|
||||
#:authentication-responder (responders-authentication (host-responders host-info))
|
||||
#:passwords-refresh-responder (responders-passwords-refreshed (host-responders host-info)))
|
||||
(path-procedure:make "/conf/collect-garbage"
|
||||
(lambda ()
|
||||
(collect-garbage)
|
||||
((responders-collect-garbage (host-responders host-info)))))
|
||||
(servlets:make config:instances config:scripts config:make-servlet-namespace
|
||||
#:servlet-root (paths-servlet (host-paths host-info))
|
||||
#:responders-servlets-refreshed (responders-servlets-refreshed (host-responders host-info))
|
||||
#:responders-servlet-loading (responders-servlet-loading (host-responders host-info))
|
||||
#:responders-servlet (responders-servlet (host-responders host-info))
|
||||
#:responders-file-not-found (responders-file-not-found (host-responders host-info))
|
||||
#:timeouts-servlet-connection (timeouts-servlet-connection (host-timeouts host-info))
|
||||
#:timeouts-default-servlet (timeouts-default-servlet (host-timeouts host-info)))
|
||||
(files:make #:htdocs-path (paths-htdocs (host-paths host-info))
|
||||
#:mime-types-path (paths-mime-types (host-paths host-info))
|
||||
#:indices (host-indices host-info)
|
||||
#:file-not-found-responder (responders-file-not-found (host-responders host-info)))))))
|
||||
|
||||
(define web-server@
|
||||
(compound-unit/sig
|
||||
|
|
Loading…
Reference in New Issue
Block a user