184 lines
8.1 KiB
Scheme
184 lines
8.1 KiB
Scheme
(module web-server-unit mzscheme
|
|
(require "sig.ss"
|
|
"web-server-structs.ss"
|
|
"connection-manager.ss"
|
|
"configuration-structures.ss"
|
|
"servlet.ss"
|
|
"cache-table.ss"
|
|
(rename "request-parsing.ss"
|
|
the-read-request read-request))
|
|
(require (prefix sequencer: "dispatch-sequencer.ss")
|
|
(prefix passwords: "dispatch-passwords.ss")
|
|
(prefix files: "dispatch-files.ss")
|
|
(prefix servlets: "dispatch-servlets.ss")
|
|
(prefix path-procedure: "dispatch-pathprocedure.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]))
|
|
|
|
;; ****************************************
|
|
|
|
(define dispatch-server@
|
|
(unit/sig dispatch-server^
|
|
(import net:tcp^ (config : dispatch-server-config^))
|
|
|
|
;; serve: -> -> void
|
|
;; start the server and return a thunk to shut it down
|
|
(define (serve)
|
|
(let ([the-server-custodian (make-custodian)])
|
|
(start-connection-manager the-server-custodian)
|
|
(parameterize ([current-custodian the-server-custodian]
|
|
[current-server-custodian the-server-custodian])
|
|
(thread
|
|
(lambda ()
|
|
(listener-loop))))
|
|
(lambda ()
|
|
(custodian-shutdown-all the-server-custodian))))
|
|
|
|
;; 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))))
|
|
|
|
;; server-loop: (-> input-port output-port) (input-port -> string string) -> void
|
|
;; start a thread to handle each incoming connection
|
|
(define (server-loop get-ports port-addresses)
|
|
(let loop ()
|
|
(let ([connection-cust (make-custodian)])
|
|
(parameterize ([current-custodian connection-cust])
|
|
(let-values ([(ip op) (get-ports)])
|
|
(serve-ports/inner ip op
|
|
port-addresses))))
|
|
(loop)))
|
|
|
|
;; serve-ports : input-port output-port -> void
|
|
;; returns immediately, spawning a thread to handle
|
|
;; the connection
|
|
;; NOTE: (GregP) should allow the user to pass in a connection-custodian
|
|
(define (serve-ports ip op)
|
|
(let ([server-cust (make-custodian)])
|
|
(start-connection-manager server-cust)
|
|
(parameterize ([current-custodian server-cust]
|
|
[current-server-custodian server-cust])
|
|
(let ([connection-cust (make-custodian)])
|
|
(parameterize ([current-custodian connection-cust])
|
|
(serve-ports/inner ip op
|
|
(lambda (ip)
|
|
(values "127.0.0.1"
|
|
"127.0.0.1"))))))))
|
|
|
|
;; serve-ports/inner : input-port output-port (input-port -> string string) -> void
|
|
;; returns immediately, spawning a thread to handle
|
|
(define (serve-ports/inner ip op port-addresses)
|
|
(thread
|
|
(lambda ()
|
|
(let ([conn (new-connection config:initial-connection-timeout
|
|
ip op (current-custodian) #f)])
|
|
(with-handlers ([exn:fail:network?
|
|
(lambda (e)
|
|
(set-connection-close?! conn #t)
|
|
(kill-connection! conn)
|
|
(raise e))])
|
|
(serve-connection conn port-addresses))))))
|
|
|
|
;; serve-connection: connection (input-port -> string string) -> void
|
|
;; respond to all requests on this connection
|
|
(define (serve-connection conn port-addresses)
|
|
(let connection-loop ()
|
|
(let-values ([(req close?) (config:read-request conn config:port port-addresses)])
|
|
(set-connection-close?! conn close?)
|
|
(adjust-connection-timeout! conn config:initial-connection-timeout)
|
|
(config:dispatch conn req)
|
|
(cond
|
|
[(connection-close? conn) (kill-connection! conn)]
|
|
[else (connection-loop)]))))))
|
|
|
|
(define web-config@->dispatch-server-config@
|
|
(unit/sig dispatch-server-config^
|
|
(import (config : web-config^))
|
|
(define read-request the-read-request)
|
|
|
|
(define port config:port)
|
|
(define listen-ip config:listen-ip)
|
|
(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.
|
|
(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)))))
|
|
|
|
(define (host-info->dispatcher host-info)
|
|
(sequencer:gen-dispatcher
|
|
(passwords:gen-dispatcher host-info config:access)
|
|
(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)))))
|
|
|
|
(define web-server@
|
|
(compound-unit/sig
|
|
(import (TCP : net:tcp^)
|
|
(CONFIG : web-config^))
|
|
(link (DISPATCH-CONFIG : dispatch-server-config^
|
|
(web-config@->dispatch-server-config@ CONFIG))
|
|
(DISPATCH : dispatch-server^
|
|
(dispatch-server@ TCP DISPATCH-CONFIG)))
|
|
(export (open (DISPATCH : web-server^))))))
|