#lang scheme/base
(require (for-syntax scheme/base)
net/url
scheme/contract
srfi/26
web-server/configuration/namespace
web-server/dispatchers/filesystem-map
web-server/http
web-server/managers/lru
web-server/managers/manager
web-server/private/mime-types
web-server/servlet/setup
(prefix-in file: web-server/dispatchers/dispatch-files)
(prefix-in sequencer: web-server/dispatchers/dispatch-sequencer)
(prefix-in servlets: web-server/dispatchers/dispatch-servlets)
(planet untyped/mirrors:1)
"defaults.ss"
"run-server.ss")
(define (go! start
#:port [port 8765]
#:listen-ip [listen-ip "127.0.0.1"]
#:htdocs-paths [htdocs-paths default-htdocs-paths]
#:mime-types-path [mime-types-path default-mime-types-path]
#:servlet-namespace [servlet-namespace default-servlet-namespace]
#:manager [manager (make-instaservlet-manager)])
(define htdocs-dispatcher
(apply sequencer:make
(map (lambda (path)
(file:make #:url->path (make-url->path (path->complete-path path))
#:path->mime-type (make-path->mime-type (path->complete-path mime-types-path))))
htdocs-paths)))
(define servlet-dispatcher
(let ([servlet-box (box #f)]
[make-namespace (make-make-servlet-namespace #:to-be-copied-module-specs servlet-namespace)])
(servlets:make
(lambda (url)
(or (unbox servlet-box)
(let ([servlet
(parameterize ([current-custodian (make-custodian)]
[current-namespace (make-namespace)])
(if stateless? #f
(make-stateless.servlet (current-directory) start)
(make-v2.servlet (current-directory) manager start)))])
(set-box! servlet-box servlet)
servlet))))))
(define (not-found-dispatcher connection request)
(make-html-response (xml (html (body (p "Not found."))))))
(define top-level-dispatcher
(sequencer:make htdocs-dispatcher servlet-dispatcher not-found-dispatcher))
(parameterize ([print-hash-table #t]
[print-struct #t]
[error-print-width 1024]
[error-print-context-length 50])
(console-loop (cut run-server port listen-ip top-level-dispatcher))))
(define (make-instaservlet-manager [threshold (* 64 1024 1024)])
(make-threshold-LRU-manager make-expired-response threshold))
(define stylesheet
(xml (style (@ [type "text/css"])
#<<ENDCSS
body { background: #eee#container { border: 1px solid #aaah1 { font-family: verdana,arial,sans-serifp { font-family: arial,sans-serifENDCSS
)))
(define (make-not-found-response request)
(make-html-response
#:code 404
#:message "Not found"
#:seconds (current-seconds)
(xml (html (head (title "404 not found")
,stylesheet)
(body (div (@ [id "container"])
(h1 "Controller not found")
(p "You visited the URL:")
(p (@ [class "example"])
(span (@ [class "argument"])
"\"" ,(url->string (request-uri request)) "\""))
(p "Unfortunately, we could not find this page or resource on our site.")))))))
(define (make-expired-response request)
(make-html-response
#:code 200
#:message "Page expired"
#:seconds (current-seconds)
(xml (html (head (title "Page expired")
,stylesheet)
(body (div (@ [id "container"])
(h1 "Page expired")
(p "Sorry, this page has expired, either due to changes to the "
"data stored here or due to a period of inactivity.")))))))
(provide/contract
[go! (->* ((-> request? response?))
(#:port natural-number/c
#:listen-ip (or/c string? false/c)
#:htdocs-paths (listof path?)
#:mime-types-path path?
#:servlet-namespace any/c
#:manager manager?)
void?)]
[make-instaservlet-manager (->* () (natural-number/c) manager?)]
[make-not-found-response (-> request? response?)]
[make-expired-response (-> request? response?)])