107 lines
5.0 KiB
Scheme
107 lines
5.0 KiB
Scheme
#lang scheme/base
|
|
(require net/tcp-sig
|
|
mzlib/unit)
|
|
(require "web-server-sig.ss"
|
|
"web-config-sig.ss"
|
|
"private/dispatch-server-unit.ss"
|
|
"private/dispatch-server-sig.ss"
|
|
"private/web-server-structs.ss"
|
|
"private/mime-types.ss"
|
|
"configuration/configuration-table-structs.ss"
|
|
"private/cache-table.ss"
|
|
(prefix-in http: web-server/http/request))
|
|
(require "dispatchers/dispatch.ss"
|
|
web-server/servlet/setup
|
|
(prefix-in fsmap: "dispatchers/filesystem-map.ss")
|
|
(prefix-in sequencer: "dispatchers/dispatch-sequencer.ss")
|
|
(prefix-in timeout: web-server/dispatchers/dispatch-timeout)
|
|
(prefix-in passwords: "dispatchers/dispatch-passwords.ss")
|
|
(prefix-in files: "dispatchers/dispatch-files.ss")
|
|
(prefix-in servlets: "dispatchers/dispatch-servlets.ss")
|
|
(prefix-in path-procedure: "dispatchers/dispatch-pathprocedure.ss")
|
|
(prefix-in log: "dispatchers/dispatch-log.ss")
|
|
(prefix-in host: "dispatchers/dispatch-host.ss")
|
|
(prefix-in filter: "dispatchers/dispatch-filter.ss")
|
|
(prefix-in lift: "dispatchers/dispatch-lift.ss"))
|
|
|
|
(provide web-server@)
|
|
|
|
(define-unit web-config@->dispatch-server-config@
|
|
(import (prefix config: web-config^))
|
|
(export dispatch-server-config^)
|
|
(init-depend web-config^)
|
|
(define read-request http: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 -> void
|
|
(define dispatch-cache (make-cache-table))
|
|
(define dispatch
|
|
(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:make
|
|
(timeout:make initial-connection-timeout)
|
|
(if (and (host-log-format host-info)
|
|
(host-log-path host-info))
|
|
(log:make #:format (log:log-format->format (host-log-format host-info))
|
|
#:log-path (host-log-path host-info))
|
|
(lambda (conn req) (next-dispatcher)))
|
|
(if (host-passwords host-info)
|
|
(let-values ([(update-password-cache! password-check)
|
|
(passwords:password-file->authorized? (host-passwords host-info))])
|
|
(sequencer:make
|
|
(timeout:make (timeouts-password (host-timeouts host-info)))
|
|
(passwords:make
|
|
(passwords:make-basic-denied?/path
|
|
password-check)
|
|
#:authentication-responder (responders-authentication (host-responders host-info)))
|
|
(path-procedure:make "/conf/refresh-passwords"
|
|
(lambda _
|
|
(update-password-cache!)
|
|
((responders-passwords-refreshed (host-responders host-info)))))))
|
|
(lambda (conn req) (next-dispatcher)))
|
|
(path-procedure:make "/conf/collect-garbage"
|
|
(lambda _
|
|
(collect-garbage)
|
|
((responders-collect-garbage (host-responders host-info)))))
|
|
(let-values ([(clear-cache! url->servlet)
|
|
(servlets:make-cached-url->servlet
|
|
(fsmap:filter-url->path
|
|
#rx"\\.(ss|scm)$"
|
|
(fsmap:make-url->valid-path
|
|
(fsmap:make-url->path (paths-servlet (host-paths host-info)))))
|
|
(make-default-path->servlet
|
|
#:make-servlet-namespace config:make-servlet-namespace
|
|
#:timeouts-default-servlet (timeouts-default-servlet (host-timeouts host-info))))])
|
|
(sequencer:make
|
|
(path-procedure:make "/conf/refresh-servlets"
|
|
(lambda _
|
|
(clear-cache!)
|
|
((responders-servlets-refreshed (host-responders host-info)))))
|
|
(sequencer:make
|
|
(timeout:make (timeouts-servlet-connection (host-timeouts host-info)))
|
|
(servlets:make url->servlet
|
|
#:responders-servlet-loading (responders-servlet-loading (host-responders host-info))
|
|
#:responders-servlet (responders-servlet (host-responders host-info))))))
|
|
(files:make #:url->path (fsmap:make-url->path (paths-htdocs (host-paths host-info)))
|
|
#:path->mime-type (make-path->mime-type (paths-mime-types (host-paths host-info)))
|
|
#:indices (host-indices host-info))
|
|
(lift:make (responders-file-not-found (host-responders host-info))))))
|
|
|
|
(define-compound-unit/infer web-server@
|
|
(import tcp^ web-config^)
|
|
(export web-server^)
|
|
(link web-config@->dispatch-server-config@ dispatch-server@))
|