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

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

View File

@ -624,13 +624,64 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define stop-status (web:run))
(define web-controller (web:run))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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))
(parameterize ([error-display-handler (lambda (msg exn) (log-line msg))]
[error-print-context-length 0]
@ -643,54 +694,13 @@
port
(lambda (r w)
(error-print-context-length default-context-length)
(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 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)))))))
(handle-*-request r w)
;; 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
(lambda (exn)
(log-line "ERROR: ~a" (if (exn? exn) (exn-message exn) exn)))
@ -702,6 +712,6 @@
l))
(lambda (l)
(log-line "shutting down")
(stop-status)
(web-controller 'shutdown)
(ssl-close l))
ssl-accept ssl-accept/enable-break))

View File

@ -11,51 +11,102 @@
web-server/managers/lru
(prefix-in sequencer: web-server/dispatchers/dispatch-sequencer)
(prefix-in log: web-server/dispatchers/dispatch-log)
web-server/private/connection-manager
web-server/http/request-structs
scheme/async-channel
net/url
net/tcp-sig
net/ssl-tcp-unit)
openssl
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)
(define (run-servlet dispatcher port server-dir
(define (run-servlet dispatcher
#:namespace [namespace '()]
#: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)
(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@ tcp@
#:dispatch
(sequencer:make
(and log-file (log:make #:format (log:log-format->format 'apache-default)
#:log-path log-file))
(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))))
;; This can be used to serve html content too; doesn't make sense now,
;; since the servlet will be used for all requests, and it never calls
;; (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 () "/")))
)))
(define shut
(serve
#:tcp@ (make-tcp@ ach)
#:dispatch
(wrap-sequence
(and log-file (log:make #:format (log:log-format->format 'apache-default)
#:log-path log-file))
(let ([init-path (make-parameter "/")])
(dispatch/servlet
(lambda (req)
(init-path (url->string (request-uri req)))
(dispatcher req))
#:regexp #rx""
#:namespace namespace
#:manager (make-threshold-LRU-manager
(send-error "Your session has expired" init-path)
(* 12 1024 1024))))
;; This can be used to serve html content too; doesn't make sense now,
;; since the servlet will be used for all requests, and it never calls
;; (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 () "/")))
)))
(lambda (msg . args)
(case msg
[(shutdown) (shut)]
[(connect) (async-channel-put ach args)])))

View File

@ -258,12 +258,12 @@
=> (lambda (p)
(begin0 (parameterize ([error-print-context-length 0])
(run-servlet
dispatcher p server-dir
dispatcher
#: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)))
(log-line "*** embedded web server started on port ~a" p)))]
(log-line "*** embedded web server started")))]
[else void]))