diff --git a/collects/handin-server/main.ss b/collects/handin-server/main.ss index d3cbbbca97..1d3c42d4f9 100644 --- a/collects/handin-server/main.ss +++ b/collects/handin-server/main.ss @@ -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)) diff --git a/collects/handin-server/run-servlet.ss b/collects/handin-server/run-servlet.ss index 30cf9fbeb1..65fbad3301 100644 --- a/collects/handin-server/run-servlet.ss +++ b/collects/handin-server/run-servlet.ss @@ -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)]))) diff --git a/collects/handin-server/web-status-server.ss b/collects/handin-server/web-status-server.ss index 52d9315997..031eca897e 100644 --- a/collects/handin-server/web-status-server.ss +++ b/collects/handin-server/web-status-server.ss @@ -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]))