206 lines
7.9 KiB
Racket
206 lines
7.9 KiB
Racket
; Derived from plai/web/server, which was based on an older version of this
|
|
; Also derived from planet/untyped/instaservlet
|
|
#lang racket/base
|
|
(require racket/contract
|
|
racket/list
|
|
racket/serialize
|
|
racket/runtime-path
|
|
(for-syntax racket/base))
|
|
(require net/url
|
|
web-server/managers/lru
|
|
web-server/managers/manager
|
|
web-server/configuration/namespace
|
|
web-server/http
|
|
web-server/stuffers
|
|
web-server/configuration/responders
|
|
web-server/private/mime-types
|
|
web-server/servlet/setup
|
|
web-server/servlet/servlet-structs
|
|
web-server/servlet-dispatch
|
|
unstable/contract
|
|
(prefix-in lift: web-server/dispatchers/dispatch-lift)
|
|
(prefix-in fsmap: web-server/dispatchers/filesystem-map)
|
|
(prefix-in sequencer: web-server/dispatchers/dispatch-sequencer)
|
|
(prefix-in files: web-server/dispatchers/dispatch-files)
|
|
(prefix-in filter: web-server/dispatchers/dispatch-filter)
|
|
(prefix-in servlets: web-server/dispatchers/dispatch-servlets)
|
|
(prefix-in log: web-server/dispatchers/dispatch-log))
|
|
|
|
(define (quit-server sema)
|
|
(lift:make
|
|
(lambda (request)
|
|
(semaphore-post sema)
|
|
(response/xexpr
|
|
`(html (head (title "Server Stopped")
|
|
(link ([rel "stylesheet"] [href "/error.css"])))
|
|
(body (div ([class "section"])
|
|
(div ([class "title"]) "Server Stopped")
|
|
(p "Return to DrRacket."))))))))
|
|
|
|
(define-runtime-path default-web-root "default-web-root")
|
|
|
|
(provide/contract
|
|
[serve/servlet (((request? . -> . can-be-response?))
|
|
(#:connection-close? boolean?
|
|
#:command-line? boolean?
|
|
#:launch-browser? boolean?
|
|
#:quit? boolean?
|
|
#:banner? boolean?
|
|
#:listen-ip (or/c false/c string?)
|
|
#:port tcp-listen-port?
|
|
#:max-waiting exact-nonnegative-integer?
|
|
#:ssl? boolean?
|
|
#:ssl-cert (or/c false/c path-string?)
|
|
#:ssl-key (or/c false/c path-string?)
|
|
#:manager manager?
|
|
#:servlet-namespace (listof module-path?)
|
|
#:server-root-path path-string?
|
|
#:stateless? boolean?
|
|
#:stuffer (stuffer/c serializable? bytes?)
|
|
#:extra-files-paths (listof path-string?)
|
|
#:servlets-root path-string?
|
|
#:servlet-current-directory path-string?
|
|
#:file-not-found-responder (request? . -> . can-be-response?)
|
|
#:servlet-loading-responder (url? any/c . -> . can-be-response?)
|
|
#:servlet-responder (url? any/c . -> . can-be-response?)
|
|
#:mime-types-path path-string?
|
|
#:servlet-path string?
|
|
#:servlet-regexp regexp?
|
|
#:log-file (or/c false/c path-string?)
|
|
#:log-format (or/c log:log-format/c log:format-req/c))
|
|
. ->* .
|
|
void)])
|
|
|
|
;; utility for conveniently chaining dispatchers
|
|
(define (dispatcher-sequence . dispatchers)
|
|
(let loop ([ds dispatchers] [r '()])
|
|
(cond [(null? ds) (apply sequencer:make (reverse r))]
|
|
[(not (car ds)) (loop (cdr ds) r)]
|
|
[(list? (car ds)) (loop (append (car ds) (cdr ds)) r)]
|
|
[else (loop (cdr ds) (cons (car ds) r))])))
|
|
|
|
(define (serve/servlet
|
|
start
|
|
#:connection-close?
|
|
[connection-close? #f]
|
|
#:command-line?
|
|
[command-line? #f]
|
|
#:launch-browser?
|
|
[launch-browser? (not command-line?)]
|
|
#:quit?
|
|
[quit? (not command-line?)]
|
|
#:banner?
|
|
[banner? (not command-line?)]
|
|
|
|
#:listen-ip
|
|
[listen-ip "127.0.0.1"]
|
|
#:port
|
|
[the-port 8000]
|
|
#:max-waiting
|
|
[max-waiting 511]
|
|
|
|
#:manager
|
|
[manager
|
|
(make-threshold-LRU-manager
|
|
(lambda (request)
|
|
(response/xexpr
|
|
`(html (head (title "Page Has Expired."))
|
|
(body (p "Sorry, this page has expired. Please go back.")))))
|
|
(* 128 1024 1024))]
|
|
|
|
#:servlet-path
|
|
[servlet-path "/servlets/standalone.rkt"]
|
|
#:servlet-regexp
|
|
[servlet-regexp (regexp (format "^~a$" (regexp-quote servlet-path)))]
|
|
#:stateless?
|
|
[stateless? #f]
|
|
#:stuffer
|
|
[stuffer default-stuffer]
|
|
|
|
#:servlet-namespace
|
|
[servlet-namespace empty]
|
|
#:server-root-path
|
|
[server-root-path default-web-root]
|
|
#:extra-files-paths
|
|
[extra-files-paths (list (build-path server-root-path "htdocs"))]
|
|
#:servlets-root
|
|
[servlets-root (build-path server-root-path "htdocs")]
|
|
#:servlet-current-directory
|
|
[servlet-current-directory servlets-root]
|
|
#:file-not-found-responder
|
|
[file-not-found-responder
|
|
(gen-file-not-found-responder
|
|
(build-path server-root-path "conf" "not-found.html"))]
|
|
#:servlet-loading-responder
|
|
[responders-servlet-loading servlet-loading-responder]
|
|
#:servlet-responder
|
|
[responders-servlet servlet-error-responder]
|
|
|
|
#:mime-types-path
|
|
[mime-types-path (let ([p (build-path server-root-path "mime.types")])
|
|
(if (file-exists? p)
|
|
p
|
|
(build-path default-web-root "mime.types")))]
|
|
|
|
#:ssl?
|
|
[ssl? #f]
|
|
#:ssl-cert
|
|
[ssl-cert (and ssl? (build-path server-root-path "server-cert.pem"))]
|
|
#:ssl-key
|
|
[ssl-key (and ssl? (build-path server-root-path "private-key.pem"))]
|
|
|
|
#:log-file
|
|
[log-file #f]
|
|
#:log-format
|
|
[log-format 'apache-default])
|
|
(define (dispatcher sema)
|
|
(dispatcher-sequence
|
|
(and log-file (log:make #:format
|
|
(if (symbol? log-format)
|
|
(log:log-format->format log-format)
|
|
log-format)
|
|
#:log-path log-file))
|
|
(and quit? (filter:make #rx"^/quit$" (quit-server sema)))
|
|
(dispatch/servlet
|
|
start
|
|
#:regexp servlet-regexp
|
|
#:stateless? stateless?
|
|
#:stuffer stuffer
|
|
#:current-directory servlet-current-directory
|
|
#:manager manager
|
|
#:responders-servlet-loading
|
|
responders-servlet-loading
|
|
#:responders-servlet
|
|
responders-servlet)
|
|
(let-values ([(clear-cache! url->servlet)
|
|
(servlets:make-cached-url->servlet
|
|
(fsmap:filter-url->path
|
|
#rx"\\.(ss|scm|rkt|rktd)$"
|
|
(fsmap:make-url->valid-path
|
|
(fsmap:make-url->path servlets-root)))
|
|
(make-default-path->servlet
|
|
#:make-servlet-namespace
|
|
(make-make-servlet-namespace #:to-be-copied-module-specs servlet-namespace)))])
|
|
(servlets:make url->servlet))
|
|
(map (lambda (extra-files-path)
|
|
(files:make
|
|
#:url->path (fsmap:make-url->path extra-files-path)
|
|
#:path->mime-type (make-path->mime-type mime-types-path)
|
|
#:indices (list "index.html" "index.htm")))
|
|
extra-files-paths)
|
|
(files:make
|
|
#:url->path (fsmap:make-url->path (build-path server-root-path "htdocs"))
|
|
#:path->mime-type (make-path->mime-type mime-types-path)
|
|
#:indices (list "index.html" "index.htm"))
|
|
(lift:make (compose any->response file-not-found-responder))))
|
|
(serve/launch/wait
|
|
dispatcher
|
|
#:connection-close? connection-close?
|
|
#:launch-path (if launch-browser? servlet-path #f)
|
|
#:banner? banner?
|
|
#:listen-ip listen-ip
|
|
#:port the-port
|
|
#:max-waiting max-waiting
|
|
#:ssl-cert ssl-cert
|
|
#:ssl-key ssl-key))
|