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

The embedded web server works now on the same port as the handin server.

Browse Source 
Small change to protocol: the client should send "handin" first

svn: r17448
This commit is contained in:
Eli Barzilay 2009-12-31 07:17:18 +00:00
parent a0ff244a81
commit 237682244c
3 changed files with 149 additions and 88 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

110
collects/handin-server/main.ss
View File

@ -624,13 +624,64 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define stop-status (web:run)) (define web-controller (web:run))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define session-count 0) (define session-count 0)
(define (handle-handin-request r w)
(set! connection-num (add1 connection-num))
(when ((current-memory-use) . > . (get-conf 'session-memory-limit))
(collect-garbage))
(parameterize ([current-session
(begin (set! session-count (add1 session-count))
session-count)])
(let-values ([(here there) (ssl-addresses r)])
(log-line "connect from ~a" there)
(hook 'server-connect `([from ,there])))
(with-watcher
w
(lambda (kill-watcher)
(let ([r-safe (make-limited-input-port r (* 4 1024))])
(with-handlers ([exn:fail?
(lambda (exn)
(let ([msg (if (exn? exn)
(exn-message exn)
(format "~e" exn))])
(kill-watcher)
(log-line "ERROR: ~a" msg)
(write+flush w msg)
;; see note on close-output-port below
(close-output-port w)))])
;; Initiate handin protocol (the 'handin token was already peeked)
(unless (eq? 'handin (read r-safe))
(error 'handin "internal error, didn't get peeked string"))
(write+flush w 'handin)
;; Check version:
(let ([ver (read r-safe)])
(if (eq? 'ver1 ver)
(write+flush w 'ver1)
(error 'handin "unknown handin version: ~e" ver)))
(handle-connection r r-safe w)
(log-line "normal exit")
(kill-watcher)))))))
(define (handle-http-request r w)
(let ([s (make-semaphore 0)])
(web-controller 'connect r w s)
(semaphore-wait s)))
(define (handle-*-request r w)
(let* ([proto (regexp-match-peek #rx#"^[^\r\n]*(?=\r?\n)" r 0 (* 4 1024))]
[proto (and proto (car proto))])
((cond [(not proto) (error 'handin "no protocol line" proto)]
[(equal? #"handin" proto) handle-handin-request]
[(regexp-match? #rx#"(?i:http/[0-9.]+)$" proto) handle-http-request]
[else (error 'handin "unknown protocol: ~e" proto)])
r w)))
(define default-context-length (error-print-context-length)) (define default-context-length (error-print-context-length))
(parameterize ([error-display-handler (lambda (msg exn) (log-line msg))] (parameterize ([error-display-handler (lambda (msg exn) (log-line msg))]
[error-print-context-length 0] [error-print-context-length 0]
@ -643,54 +694,13 @@
port port
(lambda (r w) (lambda (r w)
(error-print-context-length default-context-length) (error-print-context-length default-context-length)
(set! connection-num (add1 connection-num)) (handle-*-request r w)
(when ((current-memory-use) . > . (get-conf 'session-memory-limit)) ;; This close-output-port should not be necessary, and it's here
(collect-garbage)) ;; due to a deficiency in the SSL binding. The problem is that a
(parameterize ([current-session ;; custodian shutdown of w is harsher for SSL output than a normal
(begin (set! session-count (add1 session-count)) ;; close. A normal close flushes an internal buffer that's not
session-count)]) ;; supposed to exist, while the shutdown gives up immediately.
(let-values ([(here there) (ssl-addresses r)]) (close-output-port w))
(log-line "connect from ~a" there)
(hook 'server-connect `([from ,there])))
(with-watcher
w
(lambda (kill-watcher)
(let ([r-safe (make-limited-input-port r 2048)])
(write+flush w 'handin)
;; Check protocol:
(with-handlers ([exn:fail?
(lambda (exn)
(let ([msg (if (exn? exn)
(exn-message exn)
(format "~e" exn))])
(kill-watcher)
(log-line "ERROR: ~a" msg)
(write+flush w msg)
;; see note on close-output-port below
(close-output-port w)))])
(let ([protocol (read r-safe)])
(cond
[(eq? protocol 'ver1)
(write+flush w 'ver1)]
[(eq? protocol 'GET)
(error 'handin "got a GET request: maybe you are using the server-port instead of the https-server-port to connect to the https server? ~a"
(let ([port (get-conf 'https-port-number)])
(if port
(let-values ([(us them) (ssl-addresses r)])
(format "Try this url: https://~a:~a/"
us port))
(format "There is no https-port-number set in config.ss; try setting that first."))))]
[else (error 'handin "unknown protocol: ~e" protocol)]))
(handle-connection r r-safe w)
(log-line "normal exit")
(kill-watcher)
;; This close-output-port should not be necessary, and it's
;; here due to a deficiency in the SSL binding. The problem is
;; that a custodian shutdown of w is harsher for SSL output
;; than a normal close. A normal close flushes an internal
;; buffer that's not supposed to exist, while the shutdown
;; gives up immediately.
(close-output-port w)))))))
#f ; `with-watcher' handles our timeouts #f ; `with-watcher' handles our timeouts
(lambda (exn) (lambda (exn)
(log-line "ERROR: ~a" (if (exn? exn) (exn-message exn) exn))) (log-line "ERROR: ~a" (if (exn? exn) (exn-message exn) exn)))
@ -702,6 +712,6 @@
l)) l))
(lambda (l) (lambda (l)
(log-line "shutting down") (log-line "shutting down")
(stop-status) (web-controller 'shutdown)
(ssl-close l)) (ssl-close l))
ssl-accept ssl-accept/enable-break)) ssl-accept ssl-accept/enable-break))

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

@ -11,51 +11,102 @@
web-server/managers/lru web-server/managers/lru
(prefix-in sequencer: web-server/dispatchers/dispatch-sequencer) (prefix-in sequencer: web-server/dispatchers/dispatch-sequencer)
(prefix-in log: web-server/dispatchers/dispatch-log) (prefix-in log: web-server/dispatchers/dispatch-log)
web-server/private/connection-manager
web-server/http/request-structs web-server/http/request-structs
scheme/async-channel
net/url net/url
net/tcp-sig openssl
net/ssl-tcp-unit) net/tcp-sig)
;; maps ports to the underlying ssl ports (could be done with `prop:*-port')
(define port->ssl (make-weak-hasheq))
;; wrap a port so that the semaphore is posted to when it's closed
(define (wrap-with-closing-sema outp sema)
(make-output-port
(object-name outp) outp
(lambda (buf start end nonblock? breakable?)
((if nonblock?
write-bytes-avail*
(if breakable?
write-bytes-avail/enable-break
write-bytes-avail))
buf outp start end))
(lambda ()
(close-output-port outp)
(semaphore-post sema))))
;; creates a tcp unit that grabs connections from the async-channel, each
;; connection is passed as a list holding an input port, an output port, and a
;; semaphore that should be posted to when the connection is done.
(define (make-tcp@ ach)
(unit (import) (export tcp^)
(define (tcp-accept . _)
(define-values [inp outp sema] (apply values (async-channel-get ach)))
(define outp* (wrap-with-closing-sema outp sema))
(hash-set! port->ssl outp* outp)
(values inp outp*))
(define tcp-accept/enable-break tcp-accept)
(define (tcp-accept-ready? l)
;; FIXME: need to peek into the channel
#t)
(define (tcp-abandon-port p)
(ssl-abandon-port (hash-ref port->ssl p p)))
(define (tcp-addresses p . more)
(apply ssl-addresses (hash-ref port->ssl p p) more))
;; unused
(define tcp-close void)
(define tcp-listen void)
(define tcp-listener? void?)
(define tcp-connect void)
(define tcp-connect/enable-break void)))
(provide run-servlet) (provide run-servlet)
(define (run-servlet dispatcher port server-dir (define (run-servlet dispatcher
#:namespace [namespace '()] #:namespace [namespace '()]
#:log-file [log-file #f]) #:log-file [log-file #f])
;; a channel for incoming requests
(define ach (make-async-channel))
;; wrap the dispatcher so we can post on the waiting semaphore
(define (wrap-sequence . ds)
(let ([d (apply sequencer:make ds)])
(lambda (conn req)
(d conn req)
;; (cond [(hash-ref port->sema (connection-o-port conn) #f)
;; => semaphore-post])
)))
;; error handler that redirects back to where the interaction started
(define ((send-error msg to) req) (define ((send-error msg to) req)
(let ([to (to)]) (let ([to (to)])
`(html (head (meta ([http-equiv "refresh"] `(html (head (meta ([http-equiv "refresh"]
[content ,(format "3;URL=~a" to)])) [content ,(format "3;URL=~a" to)]))
(title ,msg)) (title ,msg))
(body ,msg "; " (a ([href ,to]) "restarting") " in 3 seconds.")))) (body ,msg "; " (a ([href ,to]) "restarting") " in 3 seconds."))))
(define tcp@ (define shut
(let () (serve
(define-unit-binding ssl-tcp@ #:tcp@ (make-tcp@ ach)
(make-ssl-tcp@ (build-path server-dir "server-cert.pem") #:dispatch
(build-path server-dir "private-key.pem") (wrap-sequence
#f #f #f #f #f) (and log-file (log:make #:format (log:log-format->format 'apache-default)
(import) (export tcp^)) #:log-path log-file))
ssl-tcp@)) (let ([init-path (make-parameter "/")])
(serve (dispatch/servlet
#:port port #:listen-ip #f (lambda (req)
#:tcp@ tcp@ (init-path (url->string (request-uri req)))
#:dispatch (dispatcher req))
(sequencer:make #:regexp #rx""
(and log-file (log:make #:format (log:log-format->format 'apache-default) #:namespace namespace
#:log-path log-file)) #:manager (make-threshold-LRU-manager
(let ([init-path (make-parameter "/")]) (send-error "Your session has expired" init-path)
(dispatch/servlet (* 12 1024 1024))))
(lambda (req) ;; This can be used to serve html content too; doesn't make sense now,
(init-path (url->string (request-uri req))) ;; since the servlet will be used for all requests, and it never calls
(dispatcher req)) ;; (next-dispatcher). (See "servlet-env.ss" for the needed `require's.)
#:regexp #rx"" ;; (files:make
#:namespace namespace ;; #:url->path (fsmap:make-url->path (build-path server-dir "htdocs")))
#:current-directory server-dir ;; (lift:make (send-error "File not found" (lambda () "/")))
#:manager (make-threshold-LRU-manager )))
(send-error "Your session has expired" init-path) (lambda (msg . args)
(* 12 1024 1024)))) (case msg
;; This can be used to serve html content too; doesn't make sense now, [(shutdown) (shut)]
;; since the servlet will be used for all requests, and it never calls [(connect) (async-channel-put ach args)])))
;; (next-dispatcher). (See "servlet-env.ss" for the needed `require's.)
;; (files:make
;; #:url->path (fsmap:make-url->path (build-path server-dir "htdocs")))
;; (lift:make (send-error "File not found" (lambda () "/")))
)))

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

@ -258,12 +258,12 @@
=> (lambda (p) => (lambda (p)
(begin0 (parameterize ([error-print-context-length 0]) (begin0 (parameterize ([error-print-context-length 0])
(run-servlet (run-servlet
dispatcher p server-dir dispatcher
#:namespace '(handin-server/private/md5 #:namespace '(handin-server/private/md5
handin-server/private/logger handin-server/private/logger
handin-server/private/config handin-server/private/config
handin-server/private/hooker handin-server/private/hooker
handin-server/private/reloadable) handin-server/private/reloadable)
#:log-file (get-conf 'web-log-file))) #:log-file (get-conf 'web-log-file)))
(log-line "*** embedded web server started on port ~a" p)))] (log-line "*** embedded web server started")))]
[else void])) [else void]))