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

Make `with-watcher' deal with timeouts if not in 3m,

Browse Source 
removed timeout from `run-server'.

svn: r1040
This commit is contained in:
Eli Barzilay 2005-10-11 05:36:32 +00:00
parent b93a25c3ad
commit f30e285be4
1 changed files with 62 additions and 69 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

131
collects/handin-server/handin-server.ss
View File

@ -35,7 +35,7 @@
;; Assemble log into into a single string, to make ;; Assemble log into into a single string, to make
;; interleaved log lines unlikely: ;; interleaved log lines unlikely:
(let ([line (let ([line
(format "(~a ~s ~s)~n" (format "(~a ~s ~s)\n"
(current-session) (current-session)
(parameterize ([date-display-format 'iso-8601]) (parameterize ([date-display-format 'iso-8601])
(date->string (seconds->date (current-seconds)) #t)) (date->string (seconds->date (current-seconds)) #t))
@ -529,72 +529,67 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define no-limit-warning? #f) (define no-limit-warning? #f) ; will be set to #t if no memory limits
(define (with-watcher w proc) (define (with-watcher w proc)
(if no-limit-warning? (let ([session-cust (make-custodian)]
;; Already know watcher doesn't work: [session-channel (make-channel)]
(proc void) [timeout (+ (current-inexact-milliseconds) (* 1000 SESSION-TIMEOUT))]
;; Try making a watcher: [status-box (box #f)])
(let ([session-cust (make-custodian)] (unless no-limit-warning?
[session-channel (make-channel)] (with-handlers ([exn:fail:unsupported?
[timeout (+ (current-inexact-milliseconds) (lambda (x)
(* 1000 SESSION-TIMEOUT))] (set! no-limit-warning? #t)
[status-box (box #f)]) (LOG "WARNING: per-session memory limit not supported by MrEd"))])
(let ([watcher (custodian-limit-memory session-cust SESSION-MEMORY-LIMIT session-cust)))
(with-handlers ([exn:fail:unsupported? (let* ([watcher
(lambda (x) (parameterize ([current-custodian orig-custodian])
(set! no-limit-warning? #t) (thread
(LOG "WARNING: per-session memory limit not supported by MrEd") (lambda ()
#f)]) (let ([session-thread (channel-get session-channel)])
(custodian-limit-memory session-cust SESSION-MEMORY-LIMIT session-cust) (let loop ([timed-out? #f])
(parameterize ([current-custodian orig-custodian]) (cond
(thread (lambda () [(sync/timeout 3 session-thread)
(let ([session-thread (channel-get session-channel)]) (LOG "session killed ~awhile ~s"
(let loop ([timed-out? #f]) (if timed-out? "(timeout) " "")
(cond (unbox status-box))
[(sync/timeout 3 session-thread) (write+flush
(LOG "session killed ~awhile ~s" w (format "handin terminated due to ~a (program doesn't terminate?)~a"
(if timed-out? "(timeout) " "") (if timed-out? "time limit" "excessive memory use")
(unbox status-box)) (if (unbox status-box)
(write+flush (format " while ~a" (unbox status-box))
w (format "handin terminated due to ~a (program doesn't terminate?)~a" "")))
(if timed-out? "time limit" "excessive memory use") (close-output-port w)
(if (unbox status-box) (channel-put session-channel 'done)]
(format " while ~a" (unbox status-box)) [((current-inexact-milliseconds) . > . timeout)
""))) ;; Shutdown here to get the handin-terminated error
(close-output-port w) ;; message, instead of relying on
(channel-put session-channel 'done)] ;; SESSION-TIMEOUT at the run-server level
[((current-inexact-milliseconds) . > . timeout) (custodian-shutdown-all session-cust)
;; Shutdown here to get the handin-terminated error (loop #t)]
;; message, instead of relying on [else
;; SESSION-TIMEOUT at the run-server level (collect-garbage)
(custodian-shutdown-all session-cust) (LOG "running ~a ~a"
(loop #t)] (current-memory-use session-cust)
[else (if no-limit-warning?
(collect-garbage) "(total)"
(LOG "running ~a (~a ~a)" (list (current-memory-use orig-custodian)
(current-memory-use session-cust) (current-memory-use))))
(current-memory-use orig-custodian) (loop #f)]))))))])
(current-memory-use)) ;; Run proc in a thread under session-cust:
(loop #f)])))))))]) (let ([session-thread
(if watcher (parameterize ([current-custodian session-cust]
;; Run proc in a thread under session-cust: [current-run-status-box status-box])
(let ([session-thread (thread
(parameterize ([current-custodian session-cust] (lambda ()
[current-run-status-box status-box]) (proc (lambda ()
(thread ;; Proc has succeeded...
(lambda () (parameterize ([current-custodian orig-custodian])
(proc (lambda () (kill-thread watcher))))
;; Proc has succeeded... (channel-put session-channel 'done-normal))))])
(parameterize ([current-custodian orig-custodian]) (channel-put session-channel session-thread)
(kill-thread watcher)))) ;; Wait until the proc is done or killed (and kill is reported):
(channel-put session-channel 'done-normal))))]) (channel-get session-channel)))))
(channel-put session-channel session-thread)
;; Wait until the proc is done or killed (and kill is reported):
(channel-get session-channel))
;; Watcher didn't work:
(proc void))))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -649,11 +644,9 @@
;; flushes an internal buffer that's not supposed to exist, while ;; flushes an internal buffer that's not supposed to exist, while
;; the shutdown gives up immediately. ;; the shutdown gives up immediately.
(close-output-port w))))))) (close-output-port w)))))))
(+ SESSION-TIMEOUT 30) ; extra 30 seconds gives watcher thread time to produce a nice message #f ; `with-watcher' handles our timeouts
(lambda (exn) (lambda (exn)
(printf "~a~n" (if (exn? exn) (printf "~a\n" (if (exn? exn) (exn-message exn) exn)))
(exn-message exn)
exn)))
(lambda (port-k cnt reuse?) (lambda (port-k cnt reuse?)
(let ([l (ssl-listen port-k cnt #t)]) (let ([l (ssl-listen port-k cnt #t)])
(ssl-load-certificate-chain! l "server-cert.pem") (ssl-load-certificate-chain! l "server-cert.pem")