Removing monolithic host-info
svn: r1362
This commit is contained in:
Jay McCarthy
parent
042125174e
commit
a3c0f24fc9
|
|
@ -6,10 +6,10 @@
|
|||
|
||||
; configuration is now a unit. See sig.ss
|
||||
|
||||
; host = (make-host (listof str) (str str sym url str -> str)
|
||||
; host = (make-host (listof str) sym string
|
||||
; passwords resopnders timeouts paths)
|
||||
(provide-define-struct
|
||||
host (indices log-message passwords responders timeouts paths))
|
||||
host (indices log-format log-path passwords responders timeouts paths))
|
||||
|
||||
; passwords = (listof (list* relm:str protected-dir-regexp:str
|
||||
; (listof (list user:sym password:str))))
|
||||
|
|
|
|||
|
|
@ -8,9 +8,7 @@
|
|||
"cache-table.ss"
|
||||
"response.ss")
|
||||
(require (lib "unitsig.ss")
|
||||
(lib "contract.ss")
|
||||
(lib "url.ss" "net")
|
||||
(lib "date.ss"))
|
||||
(lib "contract.ss"))
|
||||
|
||||
(provide complete-configuration
|
||||
build-developer-configuration
|
||||
|
|
@ -57,11 +55,11 @@
|
|||
table
|
||||
(let ([default-host
|
||||
(apply-default-functions-to-host-table
|
||||
base (configuration-table-default-host table) ignore-log)]
|
||||
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) ignore-log)))
|
||||
(apply-default-functions-to-host-table base (cdr x))))
|
||||
(configuration-table-virtual-hosts table))])
|
||||
(gen-virtual-hosts expanded-virtual-host-table default-host))))
|
||||
|
||||
|
|
@ -71,11 +69,11 @@
|
|||
table
|
||||
(let ([default-host
|
||||
(apply-default-functions-to-host-table
|
||||
base (configuration-table-default-host table) gen-log-message)]
|
||||
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) gen-log-message)))
|
||||
(apply-default-functions-to-host-table base (cdr x))))
|
||||
(configuration-table-virtual-hosts table))])
|
||||
(gen-virtual-hosts expanded-virtual-host-table default-host))))
|
||||
|
||||
|
|
@ -85,7 +83,7 @@
|
|||
table
|
||||
(gen-virtual-hosts null (apply-default-functions-to-host-table
|
||||
base
|
||||
(configuration-table-default-host table) ignore-log))))
|
||||
(configuration-table-default-host table)))))
|
||||
|
||||
; : configuration-table host-table -> configuration
|
||||
(define (build-configuration table the-virtual-hosts)
|
||||
|
|
@ -235,55 +233,18 @@
|
|||
(lambda (str)
|
||||
(regexp-match servlets-regexp str))))
|
||||
|
||||
; access-denied? : str sym str -> (U #f str)
|
||||
; (define (access-denied? client-ip user-name password) ???)
|
||||
; The configuration needs a simple way to combine ip and username authentication with
|
||||
; boolean-and, boolean-or, and perhaps others operations.
|
||||
; Using quote in the old password system enabled abstraction, which
|
||||
; I never used.
|
||||
; ...
|
||||
|
||||
; gen-log-message : sym str -> str str sym url str -> str
|
||||
; more here - check apache log configuration formats
|
||||
; other server's include the original request line,
|
||||
; including the major and minor HTTP version numbers
|
||||
; to produce a string that is displayed into the log file
|
||||
(define (gen-log-message log-format log-path)
|
||||
(let ([outsem (make-semaphore 1)]
|
||||
[log-p #f])
|
||||
(lambda (host-ip client-ip method uri host)
|
||||
(call-with-semaphore
|
||||
outsem
|
||||
(lambda ()
|
||||
(with-handlers ([exn? (lambda (e) (set! log-p #f))])
|
||||
(unless (and log-p (file-exists? log-path))
|
||||
(unless (eq? log-p #f)
|
||||
(close-output-port log-p))
|
||||
(set! log-p (open-output-file log-path 'append))
|
||||
(file-stream-buffer-mode log-p 'line))
|
||||
; do the display all at once by formating first
|
||||
(when log-p
|
||||
(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))))))))
|
||||
|
||||
; ignore-log : sym str -> str str sym url str -> str
|
||||
(define (ignore-log log-format log-path) void)
|
||||
|
||||
; read-file : str -> str
|
||||
(define (read-file path)
|
||||
(call-with-input-file path
|
||||
(lambda (in) (read-string (file-size path) in))))
|
||||
|
||||
; apply-default-functions-to-host-table : str host-table (sym str -> str str sym url str -> str) -> host
|
||||
; apply-default-functions-to-host-table : str host-table -> host
|
||||
;; Greg P: web-server-root is the directory-part of the path to the configuration-table (I don't think I like this.)
|
||||
(define (apply-default-functions-to-host-table web-server-root host-table gen-log-message-maybe)
|
||||
(define (apply-default-functions-to-host-table web-server-root host-table)
|
||||
(let ([paths (expand-paths web-server-root (host-table-paths host-table))])
|
||||
(make-host
|
||||
(host-table-indices host-table)
|
||||
(gen-log-message-maybe (host-table-log-format host-table) (paths-log paths))
|
||||
(host-table-log-format host-table) (paths-log paths)
|
||||
(paths-passwords paths)
|
||||
(let ([m (host-table-messages host-table)]
|
||||
[conf (paths-conf paths)])
|
||||
|
|
|
|||
|
|
@ -1,54 +1,44 @@
|
|||
(module dispatch-files mzscheme
|
||||
(require (lib "url.ss" "net")
|
||||
(lib "xml.ss" "xml"))
|
||||
(lib "xml.ss" "xml")
|
||||
(lib "list.ss"))
|
||||
(require "dispatch.ss"
|
||||
"util.ss"
|
||||
"configuration-structures.ss"
|
||||
"response.ss")
|
||||
(provide interface-version
|
||||
gen-dispatcher)
|
||||
|
||||
(define interface-version 'v1)
|
||||
(define (gen-dispatcher host-info)
|
||||
(define (gen-dispatcher htdocs-path indices file-not-found-responder)
|
||||
(lambda (conn req)
|
||||
(let-values ([(uri method path) (decompose-request req)])
|
||||
(serve-file conn method uri host-info))))
|
||||
|
||||
;; ************************************************************
|
||||
;; ************************************************************
|
||||
;; SERVING FILES
|
||||
|
||||
;; serve-file : connection symbol uri host -> void
|
||||
;; to find the file, including searching for implicit index files, and serve it out
|
||||
(define (serve-file conn method uri host-info)
|
||||
(let ([path (url-path->path (paths-htdocs (host-paths host-info))
|
||||
(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 (host-indices host-info)])
|
||||
(cond
|
||||
[(pair? dir-defaults)
|
||||
(let ([full-name (build-path path (car 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 (cdr dir-defaults))))]
|
||||
[else
|
||||
(output-response/method
|
||||
conn
|
||||
((responders-file-not-found
|
||||
(host-responders host-info)) uri)
|
||||
method)]))]
|
||||
[else
|
||||
(output-response/method
|
||||
conn ((responders-file-not-found (host-responders host-info))
|
||||
uri)
|
||||
method)])))
|
||||
;; ************************************************************
|
||||
;; ************************************************************
|
||||
;; 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)])))))
|
||||
|
||||
;; looks-like-directory : str -> bool
|
||||
;; to determine if is url style path looks like it refers to a directory
|
||||
|
|
|
|||
11
collects/web-server/dispatch-host.ss
Normal file
11
collects/web-server/dispatch-host.ss
Normal file
|
|
@ -0,0 +1,11 @@
|
|||
(module dispatch-host mzscheme
|
||||
(require "dispatch.ss"
|
||||
"servlet-helpers.ss")
|
||||
(provide interface-version
|
||||
gen-dispatcher)
|
||||
|
||||
(define interface-version 'v1)
|
||||
(define (gen-dispatcher lookup-dispatcher)
|
||||
(lambda (conn req)
|
||||
(let* ([host (get-host (request-uri req) (request-headers req))])
|
||||
((lookup-dispatcher host) conn req)))))
|
||||
57
collects/web-server/dispatch-log.ss
Normal file
57
collects/web-server/dispatch-log.ss
Normal file
|
|
@ -0,0 +1,57 @@
|
|||
(module dispatch-log mzscheme
|
||||
(require (lib "url.ss" "net")
|
||||
(lib "date.ss")
|
||||
(lib "async-channel.ss")
|
||||
(lib "plt-match.ss"))
|
||||
(require "dispatch.ss"
|
||||
"servlet-helpers.ss")
|
||||
(provide interface-version
|
||||
gen-dispatcher)
|
||||
|
||||
(define interface-version 'v1)
|
||||
(define (gen-dispatcher log-format log-path)
|
||||
(let ([log-message (gen-log-message log-format log-path)])
|
||||
(lambda (conn req)
|
||||
(let ([host (get-host (request-uri req) (request-headers req))])
|
||||
(log-message (request-host-ip req)
|
||||
(request-client-ip req)
|
||||
(request-method req)
|
||||
(request-uri req)
|
||||
host)
|
||||
(next-dispatcher)))))
|
||||
|
||||
; gen-log-message : sym str -> str str sym url str -> str
|
||||
; XXX: check apache log configuration formats
|
||||
; other server's include the original request line,
|
||||
; including the major and minor HTTP version numbers
|
||||
; 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)))))
|
||||
|
|
@ -3,31 +3,40 @@
|
|||
"util.ss"
|
||||
"servlet-helpers.ss"
|
||||
"connection-manager.ss"
|
||||
"response.ss"
|
||||
"configuration-structures.ss")
|
||||
"response.ss")
|
||||
|
||||
(provide interface-version
|
||||
gen-dispatcher)
|
||||
|
||||
(define interface-version 'v1)
|
||||
(define (gen-dispatcher host-info config:access)
|
||||
(lambda (conn req)
|
||||
(let-values ([(uri method path) (decompose-request req)])
|
||||
(cond
|
||||
[(access-denied? method path (request-headers req) host-info config:access)
|
||||
=> (lambda (realm)
|
||||
(adjust-connection-timeout! conn (timeouts-password (host-timeouts host-info)))
|
||||
(request-authentication conn method uri host-info realm))]
|
||||
[(string=? "/conf/refresh-passwords" path)
|
||||
;; more here - send a nice error page
|
||||
(hash-table-put! config:access host-info
|
||||
(read-passwords host-info))
|
||||
(output-response/method
|
||||
conn
|
||||
((responders-passwords-refreshed (host-responders host-info)))
|
||||
method)]
|
||||
[else
|
||||
(next-dispatcher)]))))
|
||||
(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 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)])))))
|
||||
|
||||
;; ****************************************
|
||||
;; ****************************************
|
||||
|
|
@ -36,26 +45,14 @@
|
|||
;; pass-entry = (make-pass-entry str regexp (list sym str))
|
||||
(define-struct pass-entry (domain pattern users))
|
||||
|
||||
;; access-denied? : Method string x-table host Access-table -> (+ false str)
|
||||
;; access-denied? : Method string x-table denied? -> (+ false str)
|
||||
;; denied?: str sym str -> (U str #f)
|
||||
;; the return string is the prompt for authentication
|
||||
(define (access-denied? method uri-str headers host-info access-table)
|
||||
;; denied?: str sym str -> (U str #f)
|
||||
;; a function to authenticate the user
|
||||
(let ([denied?
|
||||
|
||||
;; GregP lookup the authenticator function, if you can't find it, then try to load the
|
||||
;; passwords file for this host.
|
||||
(hash-table-get
|
||||
access-table host-info
|
||||
(lambda ()
|
||||
; more here - a malformed password file will kill the connection
|
||||
(let ([f (read-passwords host-info)])
|
||||
(hash-table-put! access-table host-info f)
|
||||
f)))])
|
||||
(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 (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-struct (exn:password-file exn) ())
|
||||
|
||||
|
|
@ -64,33 +61,32 @@
|
|||
;; password. If not, the produced function returns a string, prompting for the password.
|
||||
;; If the password file does not exist, all accesses are allowed. If the file is malformed, an
|
||||
;; exn:password-file is raised.
|
||||
(define (read-passwords host-info)
|
||||
(let ([password-path (host-passwords host-info)])
|
||||
(with-handlers ([void (lambda (exn)
|
||||
(raise (make-exn:password-file (string->immutable-string
|
||||
(format "could not load password file ~a" password-path))
|
||||
(current-continuation-marks))))])
|
||||
(if (and (file-exists? password-path) (memq 'read (file-or-directory-permissions password-path)))
|
||||
(let ([passwords
|
||||
(let ([raw (load password-path)])
|
||||
(unless (password-list? raw)
|
||||
(raise "malformed passwords"))
|
||||
(map (lambda (x) (make-pass-entry (car x) (regexp (cadr x)) (cddr x)))
|
||||
raw))])
|
||||
|
||||
;; string symbol bytes -> (union #f string)
|
||||
(lambda (request-path user-name password)
|
||||
(ormap (lambda (x)
|
||||
(and (regexp-match (pass-entry-pattern x) request-path)
|
||||
(let ([name-pass (assq user-name (pass-entry-users x))])
|
||||
(if (and name-pass
|
||||
(string=?
|
||||
(cadr name-pass)
|
||||
(bytes->string/utf-8 password)))
|
||||
#f
|
||||
(pass-entry-domain x)))))
|
||||
passwords)))
|
||||
(lambda (req user pass) #f)))))
|
||||
(define (read-passwords password-path)
|
||||
(with-handlers ([void (lambda (exn)
|
||||
(raise (make-exn:password-file (string->immutable-string
|
||||
(format "could not load password file ~a" password-path))
|
||||
(current-continuation-marks))))])
|
||||
(if (and (file-exists? password-path) (memq 'read (file-or-directory-permissions password-path)))
|
||||
(let ([passwords
|
||||
(let ([raw (load password-path)])
|
||||
(unless (password-list? raw)
|
||||
(raise "malformed passwords"))
|
||||
(map (lambda (x) (make-pass-entry (car x) (regexp (cadr x)) (cddr x)))
|
||||
raw))])
|
||||
|
||||
;; string symbol bytes -> (union #f string)
|
||||
(lambda (request-path user-name password)
|
||||
(ormap (lambda (x)
|
||||
(and (regexp-match (pass-entry-pattern x) request-path)
|
||||
(let ([name-pass (assq user-name (pass-entry-users x))])
|
||||
(if (and name-pass
|
||||
(string=?
|
||||
(cadr name-pass)
|
||||
(bytes->string/utf-8 password)))
|
||||
#f
|
||||
(pass-entry-domain x)))))
|
||||
passwords)))
|
||||
(lambda (req user pass) #f))))
|
||||
|
||||
(define fake-user (gensym))
|
||||
|
||||
|
|
@ -113,10 +109,10 @@
|
|||
;; request-authentication : connection Method URL iport oport host str bool -> bool
|
||||
;; GregP: at first look, it seems that this gets called when the user
|
||||
;; has supplied bad authentication credentials.
|
||||
(define (request-authentication conn method uri host-info realm)
|
||||
(define (request-authentication conn method uri authentication-responder realm)
|
||||
(output-response/method
|
||||
conn
|
||||
((responders-authentication (host-responders host-info))
|
||||
uri `(WWW-Authenticate . ,(string-append " Basic
|
||||
realm=\"" realm "\"")))
|
||||
(authentication-responder
|
||||
uri
|
||||
`(WWW-Authenticate . ,(format " Basic realm=\"~a\"" realm)))
|
||||
method)))
|
||||
|
|
@ -1,13 +1,10 @@
|
|||
(module dispatch-servlets mzscheme
|
||||
(require (lib "url.ss" "net")
|
||||
(lib "unitsig.ss")
|
||||
(lib "list.ss"))
|
||||
(lib "unitsig.ss"))
|
||||
(require "dispatch.ss"
|
||||
"web-server-structs.ss"
|
||||
"connection-manager.ss"
|
||||
"configuration-structures.ss"
|
||||
"response.ss"
|
||||
"request-parsing.ss"
|
||||
"servlet-tables.ss"
|
||||
"servlet.ss"
|
||||
"sig.ss"
|
||||
|
|
@ -18,13 +15,17 @@
|
|||
gen-dispatcher)
|
||||
|
||||
(define interface-version 'v1)
|
||||
(define (gen-dispatcher host-info config:instances config:scripts config:make-servlet-namespace)
|
||||
(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)
|
||||
;; ************************************************************
|
||||
;; ************************************************************
|
||||
;; SERVING SERVLETS
|
||||
|
||||
;; servlet-content-producer: connection request host -> void
|
||||
(define (servlet-content-producer conn req host-info)
|
||||
;; servlet-content-producer: connection request -> void
|
||||
(define (servlet-content-producer conn req)
|
||||
(let ([meth (request-method req)])
|
||||
(if (eq? meth 'head)
|
||||
(output-response/method
|
||||
|
|
@ -36,54 +37,34 @@
|
|||
(let ([uri (request-uri req)])
|
||||
(set-request-bindings/raw!
|
||||
req
|
||||
(read-bindings/handled conn meth uri (request-headers req)
|
||||
host-info))
|
||||
(read-bindings/handled conn meth uri (request-headers req)))
|
||||
(cond
|
||||
[(continuation-url? uri)
|
||||
=> (lambda (k-ref)
|
||||
(invoke-servlet-continuation conn req k-ref host-info))]
|
||||
(invoke-servlet-continuation conn req k-ref))]
|
||||
[else
|
||||
(servlet-content-producer/path conn req host-info uri)])))))
|
||||
(servlet-content-producer/path conn req uri)])))))
|
||||
|
||||
;; read-bindings/handled: connection symbol url headers host -> (listof (list (symbol string))
|
||||
;; read-bindings/handled: connection symbol url headers -> (listof (list (symbol string))
|
||||
;; read the bindings and handle any exceptions
|
||||
(define (read-bindings/handled conn meth uri headers host-info)
|
||||
(define (read-bindings/handled conn meth uri headers)
|
||||
(with-handlers ([exn? (lambda (e)
|
||||
(output-response/method
|
||||
conn
|
||||
;((responders-protocol (host-responders host-info))
|
||||
; (exn-message e))
|
||||
((responders-servlet-loading (host-responders
|
||||
host-info))
|
||||
uri e)
|
||||
|
||||
|
||||
meth)
|
||||
(output-response/method conn (responders-servlet-loading uri e) meth)
|
||||
'())])
|
||||
(read-bindings conn meth uri headers)))
|
||||
|
||||
;; servlet-content-producer/path: connection request host url -> void
|
||||
;; 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
|
||||
(define (servlet-content-producer/path conn req host-info uri)
|
||||
(define (servlet-content-producer/path conn req uri)
|
||||
(with-handlers (;; couldn't find the servlet
|
||||
[exn:fail:filesystem:exists:servlet?
|
||||
(lambda (the-exn)
|
||||
(output-response/method
|
||||
conn
|
||||
((responders-file-not-found (host-responders
|
||||
host-info))
|
||||
(request-uri req))
|
||||
(request-method req)))]
|
||||
(output-response/method conn (responders-file-not-found (request-uri req)) (request-method req)))]
|
||||
;; servlet won't load (e.g. syntax error)
|
||||
[(lambda (x) #t)
|
||||
(lambda (the-exn)
|
||||
(output-response/method
|
||||
conn
|
||||
((responders-servlet-loading
|
||||
(host-responders host-info))
|
||||
uri the-exn)
|
||||
(request-method req)))])
|
||||
(output-response/method conn (responders-servlet-loading uri the-exn) (request-method req)))])
|
||||
(let ([sema (make-semaphore 0)]
|
||||
[last-inst (thread-cell-ref current-servlet-instance)])
|
||||
(let/cc suspend
|
||||
|
|
@ -101,19 +82,18 @@
|
|||
(exn-message e)
|
||||
(exn-continuation-marks e))))])
|
||||
(url-path->path
|
||||
(paths-servlet (host-paths host-info))
|
||||
servlet-root
|
||||
(url-path->string (url-path uri))))]
|
||||
[servlet-exit-handler (make-servlet-exit-handler inst)])
|
||||
(parameterize ([current-directory (get-servlet-base-dir real-servlet-path)]
|
||||
[current-custodian servlet-custodian]
|
||||
[current-servlet-continuation-expiration-handler
|
||||
(make-default-servlet-continuation-expiration-handler host-info)]
|
||||
(make-default-servlet-continuation-expiration-handler)]
|
||||
[exit-handler servlet-exit-handler])
|
||||
(thread-cell-set! current-servlet-instance inst)
|
||||
(let (;; timer thread must be within the dynamic extent of
|
||||
;; servlet custodian
|
||||
[time-bomb (start-timer (timeouts-default-servlet
|
||||
(host-timeouts host-info))
|
||||
[time-bomb (start-timer timeouts-default-servlet
|
||||
(lambda ()
|
||||
(servlet-exit-handler #f)))]
|
||||
;; any resources (e.g. threads) created when the
|
||||
|
|
@ -123,7 +103,7 @@
|
|||
(parameterize ([current-namespace (servlet-namespace the-servlet)])
|
||||
(set-servlet-instance-timer! inst time-bomb)
|
||||
(with-handlers ([(lambda (x) #t)
|
||||
(make-servlet-exception-handler inst host-info)])
|
||||
(make-servlet-exception-handler inst)])
|
||||
;; Two possibilities:
|
||||
;; - module servlet. start : Request -> Void handles
|
||||
;; output-response via send/finish, etc.
|
||||
|
|
@ -148,23 +128,21 @@
|
|||
(servlet-instance-context inst)))
|
||||
(custodian-shutdown-all (servlet-instance-custodian inst))))
|
||||
|
||||
;; make-default-server-continuation-expiration-handler : host -> (request -> response)
|
||||
(define (make-default-servlet-continuation-expiration-handler host-info)
|
||||
;; make-default-server-continuation-expiration-handler : -> (request -> response)
|
||||
(define (make-default-servlet-continuation-expiration-handler)
|
||||
(lambda (req)
|
||||
(send/back
|
||||
((responders-file-not-found (host-responders
|
||||
host-info))
|
||||
(responders-file-not-found
|
||||
(request-uri req)))))
|
||||
|
||||
|
||||
;; make-default-server-instance-expiration-handler : host -> (request -> response)
|
||||
(define (make-default-servlet-instance-expiration-handler host-info)
|
||||
;; make-default-server-instance-expiration-handler : -> (request -> response)
|
||||
(define (make-default-servlet-instance-expiration-handler)
|
||||
(lambda (req)
|
||||
((responders-file-not-found (host-responders
|
||||
host-info))
|
||||
(responders-file-not-found
|
||||
(request-uri req))))
|
||||
|
||||
;; make-servlet-exception-handler: host -> exn -> void
|
||||
;; make-servlet-exception-handler: servlet-instance -> exn -> void
|
||||
;; This exception handler traps all unhandled servlet exceptions
|
||||
;; * Must occur within the dynamic extent of the servlet
|
||||
;; custodian since several connection custodians will typically
|
||||
|
|
@ -177,12 +155,11 @@
|
|||
;; * Also, suspend will post to the semaphore so that future
|
||||
;; requests won't be blocked.
|
||||
;; * This fixes PR# 7066
|
||||
(define (make-servlet-exception-handler inst host-info)
|
||||
(define (make-servlet-exception-handler inst)
|
||||
(lambda (the-exn)
|
||||
(let* ([ctxt (servlet-instance-context inst)]
|
||||
[req (execution-context-request ctxt)]
|
||||
[resp ((responders-servlet (host-responders
|
||||
host-info))
|
||||
[resp (responders-servlet
|
||||
(request-uri req)
|
||||
the-exn)])
|
||||
;; Don't handle twice
|
||||
|
|
@ -203,21 +180,20 @@
|
|||
(or (and (directory-exists? base) base)
|
||||
(loop base))))))
|
||||
|
||||
;; invoke-servlet-continuation: connection request continuation-reference
|
||||
;; host -> void
|
||||
;; invoke-servlet-continuation: connection request continuation-reference -> void
|
||||
;; pull the continuation out of the table and apply it
|
||||
(define (invoke-servlet-continuation conn req k-ref host-info)
|
||||
(define (invoke-servlet-continuation conn req k-ref)
|
||||
(let-values ([(uk-instance uk-id uk-salt) (apply values k-ref)])
|
||||
(let* ([uri (request-uri req)]
|
||||
[real-servlet-path (url-path->path
|
||||
(paths-servlet (host-paths host-info))
|
||||
servlet-root
|
||||
(url-path->string (url-path uri)))]
|
||||
[the-servlet (cached-load real-servlet-path)])
|
||||
(parameterize ([current-custodian (servlet-custodian the-servlet)])
|
||||
(let ([default-servlet-instance-expiration-handler
|
||||
(make-default-servlet-instance-expiration-handler host-info)]
|
||||
(make-default-servlet-instance-expiration-handler)]
|
||||
[default-servlet-continuation-expiration-handler
|
||||
(make-default-servlet-continuation-expiration-handler host-info)]
|
||||
(make-default-servlet-continuation-expiration-handler)]
|
||||
[last-inst (thread-cell-ref current-servlet-instance)])
|
||||
(thread-cell-set! current-servlet-instance #f)
|
||||
(with-handlers ([exn:servlet:instance?
|
||||
|
|
@ -338,9 +314,8 @@
|
|||
(make-servlet (v0.servlet->v1.lambda s)
|
||||
servlet-custodian
|
||||
(current-namespace)
|
||||
(timeouts-default-servlet
|
||||
(host-timeouts host-info))
|
||||
(make-default-servlet-instance-expiration-handler host-info))]
|
||||
timeouts-default-servlet
|
||||
(make-default-servlet-instance-expiration-handler))]
|
||||
; FIX - reason about exceptions from dynamic require (catch and report if not already)
|
||||
;; module servlet
|
||||
[(void? s)
|
||||
|
|
@ -353,9 +328,8 @@
|
|||
(make-servlet (v1.module->v1.lambda timeout start)
|
||||
servlet-custodian
|
||||
(current-namespace)
|
||||
(timeouts-default-servlet
|
||||
(host-timeouts host-info))
|
||||
(make-default-servlet-instance-expiration-handler host-info)))]
|
||||
timeouts-default-servlet
|
||||
(make-default-servlet-instance-expiration-handler)))]
|
||||
[(v2-transitional) ; XXX: Undocumented
|
||||
(let ([timeout (dynamic-require module-name 'timeout)]
|
||||
[instance-expiration-handler (dynamic-require module-name 'instance-expiration-handler)]
|
||||
|
|
@ -372,9 +346,8 @@
|
|||
(make-servlet (v0.response->v1.lambda s a-path)
|
||||
servlet-custodian
|
||||
(current-namespace)
|
||||
(timeouts-default-servlet
|
||||
(host-timeouts host-info))
|
||||
(make-default-servlet-instance-expiration-handler host-info))]
|
||||
timeouts-default-servlet
|
||||
(make-default-servlet-instance-expiration-handler))]
|
||||
[else
|
||||
(raise 'load-servlet/path "Loading ~e produced ~n~e~n instead of a servlet." a-path s)]))))))
|
||||
|
||||
|
|
@ -392,13 +365,13 @@
|
|||
(cache-table-clear! (unbox config:scripts))
|
||||
(output-response/method
|
||||
conn
|
||||
((responders-servlets-refreshed (host-responders host-info)))
|
||||
(responders-servlets-refreshed)
|
||||
method)]
|
||||
[(servlet-bin? path)
|
||||
(adjust-connection-timeout!
|
||||
conn
|
||||
(timeouts-servlet-connection (host-timeouts host-info)))
|
||||
timeouts-servlet-connection)
|
||||
;; more here - make timeouts proportional to size of bindings
|
||||
(servlet-content-producer conn req host-info)]
|
||||
(servlet-content-producer conn req)]
|
||||
[else
|
||||
(next-dispatcher)])))))
|
||||
|
|
@ -1,4 +1,3 @@
|
|||
|
||||
(module gui-launch mzscheme
|
||||
(require "launch.ss"
|
||||
(lib "class.ss")
|
||||
|
|
|
|||
|
|
@ -2,12 +2,13 @@
|
|||
(require (lib "list.ss")
|
||||
(lib "etc.ss")
|
||||
(lib "xml.ss" "xml")
|
||||
(lib "base64.ss" "net"))
|
||||
(lib "base64.ss" "net")
|
||||
(lib "url.ss" "net"))
|
||||
(require "util.ss"
|
||||
"response.ss"
|
||||
"request-parsing.ss")
|
||||
|
||||
(provide extract-binding/single
|
||||
(provide get-host
|
||||
extract-binding/single
|
||||
extract-bindings
|
||||
exists-binding?
|
||||
extract-user-pass
|
||||
|
|
@ -21,6 +22,17 @@
|
|||
(all-from "request-parsing.ss")
|
||||
(rename get-parsed-bindings request-bindings)
|
||||
translate-escapes)
|
||||
|
||||
;; get-host : Url (listof (cons Symbol String)) -> Symbol
|
||||
;; host names are case insesitive---Internet RFC 1034
|
||||
(define DEFAULT-HOST-NAME '<none>)
|
||||
(define (get-host uri headers)
|
||||
(cond
|
||||
[(url-host uri) => string->symbol]
|
||||
[(assq 'host headers)
|
||||
=>
|
||||
(lambda (h) (string->symbol (bytes->string/utf-8 (cdr h))))]
|
||||
[else DEFAULT-HOST-NAME]))
|
||||
|
||||
;; get-parsed-bindings : request -> (listof (cons sym str))
|
||||
(define (get-parsed-bindings r)
|
||||
|
|
|
|||
|
|
@ -10,7 +10,6 @@
|
|||
(define timer-ch (make-async-channel))
|
||||
|
||||
; start-timer-manager : custodian -> void
|
||||
; Thanks to Matthew!
|
||||
; The timer manager thread
|
||||
(define (start-timer-manager server-custodian)
|
||||
(parameterize ([current-custodian server-custodian])
|
||||
|
|
|
|||
|
|
@ -11,30 +11,16 @@
|
|||
(prefix passwords: "dispatch-passwords.ss")
|
||||
(prefix files: "dispatch-files.ss")
|
||||
(prefix servlets: "dispatch-servlets.ss")
|
||||
(prefix path-procedure: "dispatch-pathprocedure.ss"))
|
||||
(prefix path-procedure: "dispatch-pathprocedure.ss")
|
||||
(prefix log: "dispatch-log.ss")
|
||||
(prefix host: "dispatch-host.ss"))
|
||||
(require (lib "tcp-sig.ss" "net")
|
||||
(lib "unitsig.ss")
|
||||
(lib "string.ss")
|
||||
(lib "url.ss" "net"))
|
||||
(provide web-server@)
|
||||
|
||||
;; ****************************************
|
||||
;; stick this auxilliary outside the unit so
|
||||
;; I can get at it with require/expose
|
||||
|
||||
;; get-host : Url (listof (cons Symbol String)) -> Symbol
|
||||
;; host names are case insesitive---Internet RFC 1034
|
||||
(define DEFAULT-HOST-NAME '<none>)
|
||||
(define (get-host uri headers)
|
||||
(cond
|
||||
[(url-host uri) => string->symbol]
|
||||
[(assq 'host headers)
|
||||
=>
|
||||
(lambda (h) (string->symbol (bytes->string/utf-8 (cdr h))))]
|
||||
[else DEFAULT-HOST-NAME]))
|
||||
|
||||
;; ****************************************
|
||||
(provide web-server@)
|
||||
|
||||
;; ****************************************
|
||||
(define dispatch-server@
|
||||
(unit/sig dispatch-server^
|
||||
(import net:tcp^ (config : dispatch-server-config^))
|
||||
|
|
@ -55,25 +41,23 @@
|
|||
;; listener-loop : -> void
|
||||
;; loops around starting a listener if the current listener dies
|
||||
(define (listener-loop)
|
||||
(let ([sema (make-semaphore 0)])
|
||||
(let loop ()
|
||||
(let ([listener (tcp-listen config:port config:max-waiting
|
||||
#t config:listen-ip)])
|
||||
(let ([get-ports
|
||||
(lambda () (tcp-accept listener))])
|
||||
(thread
|
||||
(lambda ()
|
||||
(with-handlers ([void (lambda (e)
|
||||
; If the exception did not kill the listener
|
||||
(with-handlers ([void void])
|
||||
(tcp-close listener))
|
||||
(semaphore-post sema)
|
||||
; Rethrow the error to this thread's error printer
|
||||
(raise e))])
|
||||
(server-loop get-ports
|
||||
tcp-addresses))))))
|
||||
(semaphore-wait sema)
|
||||
(loop))))
|
||||
(let loop ()
|
||||
(thread-wait
|
||||
(let* ([listener (tcp-listen config:port config:max-waiting
|
||||
#t config:listen-ip)]
|
||||
[get-ports
|
||||
(lambda () (tcp-accept listener))])
|
||||
(thread
|
||||
(lambda ()
|
||||
(with-handlers ([void (lambda (e)
|
||||
; If the exception did not kill the listener
|
||||
(with-handlers ([void void])
|
||||
(tcp-close listener))
|
||||
; Rethrow the error to this thread's error printer
|
||||
(raise e))])
|
||||
(server-loop get-ports
|
||||
tcp-addresses))))))
|
||||
(loop)))
|
||||
|
||||
;; server-loop: (-> input-port output-port) (input-port -> string string) -> void
|
||||
;; start a thread to handle each incoming connection
|
||||
|
|
@ -138,39 +122,41 @@
|
|||
(define max-waiting config:max-waiting)
|
||||
(define initial-connection-timeout config:initial-connection-timeout)
|
||||
|
||||
;; dispatch: connection request host -> void
|
||||
;; NOTE: (Jay) First step towards a different way of doing dispatching. Initially,
|
||||
;; the dispatchers will be hard-coded based on the configuration file.
|
||||
;; Eventually, they will be more configurable and extensible.
|
||||
;; NOTE: (GregP) I'm going to use the dispatch logic out of v208 for now.
|
||||
;; I will move the other dispatch logic out of the prototype
|
||||
;; at a later time.
|
||||
;; dispatch : connection request -> void
|
||||
(define dispatch
|
||||
(let* ([cache (make-cache-table)]
|
||||
[lookup-dispatcher
|
||||
(lambda (host host-info)
|
||||
(cache-table-lookup!
|
||||
cache host
|
||||
(lambda ()
|
||||
(host-info->dispatcher host-info))))])
|
||||
(lambda (conn req)
|
||||
(let* ([host (get-host (request-uri req) (request-headers req))]
|
||||
[host-info (config:virtual-hosts (symbol->string host))])
|
||||
((host-log-message host-info) (request-host-ip req)
|
||||
(request-client-ip req) (request-method req) (request-uri req) host)
|
||||
((lookup-dispatcher host host-info)
|
||||
conn req)))))
|
||||
(let* ([cache (make-cache-table)])
|
||||
(host:gen-dispatcher
|
||||
(lambda (host)
|
||||
(cache-table-lookup!
|
||||
cache host
|
||||
(lambda ()
|
||||
(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
|
||||
(passwords:gen-dispatcher host-info config:access)
|
||||
(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 host-info
|
||||
config:instances config:scripts config:make-servlet-namespace)
|
||||
(files:gen-dispatcher 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))
|
||||
(host-indices host-info)
|
||||
(responders-file-not-found (host-responders host-info)))))))
|
||||
|
||||
(define web-server@
|
||||
(compound-unit/sig
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user