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

* Move namespace specs back to main code, and pass them through a

Browse Source 
`#:namespace' keyword
* More robust error handler -- use the url that initiated the
  interaction

svn: r17428
This commit is contained in:
Eli Barzilay 2009-12-29 16:02:59 +00:00
parent 9660490922
commit 8aa62e22b2
2 changed files with 35 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

54
collects/handin-server/run-servlet.ss
View File

@ -14,41 +14,47 @@
(prefix-in sequencer: web-server/dispatchers/dispatch-sequencer)
(prefix-in files: web-server/dispatchers/dispatch-files)
(prefix-in log: web-server/dispatchers/dispatch-log)
web-server/http/request-structs
net/url
net/tcp-sig
net/ssl-tcp-unit)
(define ((send-error msg) req)
`(html (head (meta [(http-equiv "refresh") (content "3;URL=/")])
(title ,msg))
(body ,msg "; " (a ([href "/"]) "restarting") " in 3 seconds.")))
(provide run-servlet)
(define (run-servlet dispatcher port server-dir
#:namespace [namespace '()]
#:log-file [log-file #f])
(define ((send-error msg to) req)
(let ([to (to)])
`(html (head (meta ([http-equiv "refresh"]
[content ,(format "3;URL=~a" to)]))
(title ,msg))
(body ,msg "; " (a ([href ,to]) "restarting") " in 3 seconds."))))
(define tcp@
(let ()
(define-unit-binding ssl-tcp@
(make-ssl-tcp@ (build-path server-dir "server-cert.pem")
(build-path server-dir "private-key.pem")
#f #f #f #f #f)
(import) (export tcp^))
ssl-tcp@))
(serve
#:port port #:listen-ip #f
#:tcp@ (let ()
(define-unit-binding ssl-tcp@
(make-ssl-tcp@ (build-path server-dir "server-cert.pem")
(build-path server-dir "private-key.pem")
#f #f #f #f #f)
(import) (export tcp^))
ssl-tcp@)
#:tcp@ tcp@
#:dispatch
(sequencer:make
(and log-file (log:make #:format (log:log-format->format 'apache-default)
#:log-path log-file))
(dispatch/servlet
dispatcher
#:regexp #rx""
#:namespace '(handin-server/private/md5
handin-server/private/logger
handin-server/private/config
handin-server/private/hooker
handin-server/private/reloadable)
#:current-directory server-dir
#:manager (make-threshold-LRU-manager
(send-error "Your session has expired") (* 12 1024 1024)))
(let ([init-path (make-parameter "/")])
(dispatch/servlet
(lambda (req)
(init-path (url->string (request-uri req)))
(dispatcher req))
#:regexp #rx"^/(?:/|$)"
#:namespace namespace
#:current-directory server-dir
#:manager (make-threshold-LRU-manager
(send-error "Your session has expired" init-path)
(* 12 1024 1024))))
(files:make
#:url->path (fsmap:make-url->path (build-path server-dir "htdocs")))
(lift:make (send-error "File not found")))))
(lift:make (send-error "File not found" (lambda () "/"))))))

5
collects/handin-server/web-status-server.ss
View File

@ -259,5 +259,10 @@
(log-line "*** starting web server")
(parameterize ([error-print-context-length 0])
(run-servlet dispatcher p server-dir
#:namespace '(handin-server/private/md5
handin-server/private/logger
handin-server/private/config
handin-server/private/hooker
handin-server/private/reloadable)
#:log-file (get-conf 'web-log-file))))]
[else void]))