suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Removing hardcoded configuration

Browse Source 
svn: r6359
This commit is contained in:
Jay McCarthy 2007-05-28 18:11:26 +00:00
parent 036ed0c126
commit 9b494f9d1b
3 changed files with 54 additions and 151 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

136
collects/web-server/prototype-web-server/hardcoded-configuration.ss
View File

@ -1,136 +0,0 @@
(module hardcoded-configuration mzscheme
(require (lib "configuration-structures.ss" "web-server" "private")
(lib "util.ss" "web-server" "private")
(lib "response.ss" "web-server")
(lib "dirs.ss" "setup"))
(provide hardcoded-host)
;; ************************************************************
;; HARDCODED HOST
; error-response : nat str str [(cons sym str) ...] -> response
; more here - cache files with a refresh option.
; The server should still start without the files there, so the
; configuration tool still runs. (Alternatively, find an work around.)
(define (error-response code short text-file . extra-headers)
(make-response/full code short
(current-seconds) TEXT/HTML-MIME-TYPE
extra-headers
(list (read-file text-file))))
; read-file : str -> str
(define (read-file path)
(call-with-input-file path
(lambda (in) (read-string (file-size path) in))))
;; error files:
(define server-root-path (build-path "~" "Development" "plt" "default-web-root"))
(define default-host-path (build-path server-root-path "conf"))
(define servlet-error-file (build-path default-host-path "servlet-error.html"))
(define access-denied-file (build-path default-host-path "forbidden.html"))
(define servlet-refresh-file (build-path default-host-path "servlet-refresh.html"))
(define password-refresh-file (build-path default-host-path "passwords-refresh.html"))
(define file-not-found-file (build-path default-host-path "not-found.html"))
(define protocol-file (build-path default-host-path "protocol-error.html"))
(define collect-garbage-file (build-path default-host-path "collect-garbage.html"))
(define hardcoded-host
; host = (make-host (listof str) (str str sym url str -> str)
; passwords resopnders timeouts paths)
(make-host
;; indices
(list "index.html" "index.htm")
;; log-format
'none
;; log-message
"log"
;; passwords
"passwords"
(make-responders
;; servlet: url tst -> response
(lambda (url exn)
; more here - use separate log file
;(printf "Servlet exception:\n~s\n" (exn-message exn))
((error-display-handler)
(format "Servlet exception:\n~a\n" (exn-message exn))
exn)
(error-response 500 "Servlet error" servlet-error-file))
;; servlet-loading: url tst -> response
; more here - parameterize error based on a configurable file, perhaps?
; This is slightly tricky since the (interesting) content comes from the exception.
(lambda (url exn)
((error-display-handler)
(format "Servlet loading exception:\n~a\n" (exn-message exn))
exn)
(make-response/full 500 "Servlet didn't load"
(current-seconds)
#"text/plain" ;TEXT/HTML-MIME-TYPE
'() ; check
(list "Servlet didn't load.\n"
(exn->string exn))))
;; authentication: url (cons sym str) -> response
(lambda (uri recommended-header)
(error-response 401 "Authorization Required" access-denied-file
recommended-header))
;; servlets-refreshed: -> response
(lambda ()
(error-response 200 "Servlet cache refreshed" servlet-refresh-file))
;; passwords-refreshed: -> response
(lambda ()
(error-response 200 "Passwords refreshed" password-refresh-file))
;; file-not-found: url->response
(lambda (url)
(error-response 404 "File not found" file-not-found-file))
;; protocol: string -> response
(lambda (error-message)
(error-response 400 "Malformed Request" protocol-file))
;; collect-garbage: -> response
(lambda ()
(error-response 200 "Collected Garbage" collect-garbage-file))
)
; timeouts = (make-timeouts nat^5)
(make-timeouts
; default-servlet-timeout
60
;password-connection-timeout
300
; servlet-connection-timeout
86400
; file-per-byte-connection-timeout
1/20
; file-base-connection-timeout
30)
; paths = (make-paths str^6)
(make-paths
; configuration-root
(build-path server-root-path "conf")
; host-root
(build-path server-root-path "default-web-root")
; log-file-path
"log"
; file-root
(build-path server-root-path "htdocs")
; servlet-root
(build-path (find-collects-dir) "web-server" "prototype-web-server")
; mime-types
(build-path server-root-path "mime.types")
; password-authentication
(build-path server-root-path "passwords")))))

4
collects/web-server/prototype-web-server/private/utils.ss
View File

@ -76,12 +76,12 @@
;; The second value is the prefix of the url-path used to find the servlet.
;; The third value is the remaining suffix of the url-path.
(define (url->servlet-path servlet-dir uri)
(printf "~S~n" `(url->servlet-path ,servlet-dir ,uri))
#;(printf "~S~n" `(url->servlet-path ,servlet-dir ,uri))
#;(printf " current-directory = ~s~n" (current-directory))
(let loop ([base-path servlet-dir]
[servlet-path '()]
[path-list (simplify-url-path uri)])
(printf "~S~n" `(loop ,base-path ,servlet-path ,path-list))
#;(printf "~S~n" `(loop ,base-path ,servlet-path ,path-list))
(if
(null? path-list)
(values #f #f #f)

65
collects/web-server/prototype-web-server/run.ss
View File

@ -3,33 +3,72 @@
(lib "tcp-sig.ss" "net"))
(require (lib "dispatch-server-sig.ss" "web-server" "private")
(lib "dispatch-server-unit.ss" "web-server" "private")
(lib "response.ss" "web-server")
(lib "util.ss" "web-server" "private")
(prefix http: (lib "request.ss" "web-server" "private"))
(lib "configuration-structures.ss" "web-server" "private")
(prefix files: (lib "dispatch-files.ss" "web-server" "dispatchers"))
(prefix filter: (lib "dispatch-filter.ss" "web-server" "dispatchers"))
(prefix sequencer: (lib "dispatch-sequencer.ss" "web-server" "dispatchers")))
(require "hardcoded-configuration.ss"
(prefix sequencer: (lib "dispatch-sequencer.ss" "web-server" "dispatchers"))
(prefix servlets2: "dispatch-servlets2.ss"))
; error-response : nat str str [(cons sym str) ...] -> response
(define (error-response code short text-file . extra-headers)
(make-response/full code short
(current-seconds) TEXT/HTML-MIME-TYPE
extra-headers
(list (read-file text-file))))
; read-file : str -> str
(define (read-file path)
(call-with-input-file path
(lambda (in) (read-string (file-size path) in))))
(define port 8080)
(define listen-ip #f)
(define max-waiting 40)
(define initial-connection-timeout 60)
(define host-info hardcoded-host)
(define read-request http:read-request)
(define server-root-path (build-path "~" "Development" "plt" "default-web-root"))
(define default-host-path (build-path server-root-path "conf"))
(define htdocs-path (build-path server-root-path "htdocs"))
(define file-not-found-file (build-path default-host-path "not-found.html"))
(define servlet-error-file (build-path default-host-path "servlet-error.html"))
(define responders-file-not-found
(lambda (url)
(error-response 404 "File not found" file-not-found-file)))
(define responders-servlet
(lambda (url exn)
((error-display-handler)
(format "Servlet exception:\n~a\n" (exn-message exn))
exn)
(error-response 500 "Servlet error" servlet-error-file)))
(define responders-servlet-loading
(lambda (url exn)
((error-display-handler)
(format "Servlet loading exception:\n~a\n" (exn-message exn))
exn)
(make-response/full 500 "Servlet didn't load"
(current-seconds)
#"text/plain"
'()
(list "Servlet didn't load.\n"
(exn->string exn)))))
(define dispatch
(sequencer:make
(filter:make
#rx"\\.ss$"
(servlets2:make #:htdocs-path (paths-htdocs (host-paths host-info))
#:timeouts-servlet-connection (timeouts-servlet-connection (host-timeouts host-info))
#:responders-servlet-loading (responders-servlet-loading (host-responders host-info))
#:responders-servlet (responders-servlet (host-responders host-info))
#:responders-file-not-found (responders-file-not-found (host-responders host-info))))
(files:make #:htdocs-path (paths-htdocs (host-paths host-info))
#:mime-types-path (paths-mime-types (host-paths host-info))
#:indices (host-indices host-info)
#:file-not-found-responder (responders-file-not-found (host-responders host-info)))))
(servlets2:make #:htdocs-path htdocs-path
#:timeouts-servlet-connection 86400
#:responders-servlet-loading responders-servlet-loading
#:responders-servlet responders-servlet
#:responders-file-not-found responders-file-not-found))
(files:make #:htdocs-path htdocs-path
#:mime-types-path (build-path server-root-path "mime.types")
#:indices (list "index.html" "index.htm")
#:file-not-found-responder responders-file-not-found)))
(define-values/invoke-unit
dispatch-server@