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
parent
a0ff244a81
commit
237682244c
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)])))
|
||||
|
|
|
|||
|
|
@ -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]))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user