diff --git a/collects/handin-server/checker.ss b/collects/handin-server/checker.ss index ced5594804..01abf7ab88 100644 --- a/collects/handin-server/checker.ss +++ b/collects/handin-server/checker.ss @@ -191,10 +191,8 @@ ;; This code will hack textualization of text boxes (define (insert-to-editor editor . xs) - (for-each (lambda (x) - (send editor insert - (if (string? x) x (make-object editor-snip% x)))) - xs)) + (for ([x xs]) + (send editor insert (if (string? x) x (make-object editor-snip% x))))) ;; support for "text-box%" (define text-box-sc @@ -284,10 +282,9 @@ '(ok-cancel caution))))) (error* "Aborting..."))) ;; This will create copies of the original files - ;; (for-each (lambda (file) - ;; (with-output-to-file (car file) - ;; (lambda () (display (cadr file)) (flush-output)))) - ;; files) + ;; (for ([file files]) + ;; (with-output-to-file (car file) + ;; (lambda () (display (cadr file)) (flush-output)))) (let* ([pfx-len (string-length markup-prefix)] [line-len (- maxwidth pfx-len)] [=s (lambda (n) (if (<= 0 n) (make-string n #\=) ""))] @@ -301,14 +298,12 @@ (display ===) (newline)) (parameterize ([current-output-port (open-output-bytes)]) - (for-each (lambda (file) - (sep (car file)) - (parameterize ([current-input-port - (open-input-bytes (cadr file))] - [current-processed-file (car file)]) - (input->process->output - maxwidth textualize? untabify? prefix-re))) - files) + (for ([file files]) + (sep (car file)) + (parameterize ([current-input-port (open-input-bytes (cadr file))] + [current-processed-file (car file)]) + (input->process->output + maxwidth textualize? untabify? prefix-re))) (get-output-bytes (current-output-port)))))) ;; ============================================================================ @@ -394,10 +389,9 @@ [user-post (id 'user-post)] [(body ...) (syntax-case #'(body ...) () [() #'(void)] [_ #'(body ...)])]) - (for-each (lambda (x) - (unless (memq (car x) got) - (raise-syntax-error #f "unknown keyword" stx (cadr x)))) - keyvals) + (for ([x keyvals]) + (unless (memq (car x) got) + (raise-syntax-error #f "unknown keyword" stx (cadr x)))) #'(begin (provide checker) (define checker @@ -476,10 +470,8 @@ (set-run-status "creating text file") (with-output-to-file text-file #:exists 'truncate (lambda () - (for-each (lambda (user) - (prefix-line - (user-substs user student-line))) - users) + (for ([user users]) + (prefix-line (user-substs user student-line))) (for-each prefix-line/substs extra-lines) (for-each prefix-line/substs (or (thread-cell-ref added-lines) '())) diff --git a/collects/handin-server/main.ss b/collects/handin-server/main.ss index 59174ad353..260ef0a1ea 100644 --- a/collects/handin-server/main.ss +++ b/collects/handin-server/main.ss @@ -24,7 +24,7 @@ (error (apply format fmt args))) (define (write+flush port . xs) - (for-each (lambda (x) (write x port) (newline port)) xs) + (for ([x xs]) (write x port) (newline port)) (flush-output port)) (define-struct alist (name [l #:mutable])) @@ -87,20 +87,18 @@ ;; SUCCESS, or things that are newer in the main submission ;; directory are kept (but subdirs in SUCCESS will are copied as ;; is)) - (for-each - (lambda (f) - (define dir/f (build-path dir f)) - (cond [(not (or (file-exists? f) (directory-exists? f))) - ;; f is in dir but not in the working directory - (copy-directory/files dir/f f)] - [(or (<= (file-or-directory-modify-seconds f) - (file-or-directory-modify-seconds dir/f)) - (and (file-exists? f) (file-exists? dir/f) - (not (= (file-size f) (file-size dir/f))))) - ;; f is newer in dir than in the working directory - (delete-directory/files f) - (copy-directory/files dir/f f)])) - (directory-list dir))))) + (for ([f (directory-list dir)]) + (define dir/f (build-path dir f)) + (cond [(not (or (file-exists? f) (directory-exists? f))) + ;; f is in dir but not in the working directory + (copy-directory/files dir/f f)] + [(or (<= (file-or-directory-modify-seconds f) + (file-or-directory-modify-seconds dir/f)) + (and (file-exists? f) (file-exists? dir/f) + (not (= (file-size f) (file-size dir/f))))) + ;; f is newer in dir than in the working directory + (delete-directory/files f) + (copy-directory/files dir/f f)]))))) (define cleanup-sema (make-semaphore 1)) (define (cleanup-submission dir) @@ -118,14 +116,12 @@ (define (cleanup-all-submissions) (log-line "Cleaning up all submission directories") - (for-each (lambda (pset) - (when (directory-exists? pset) ; just in case - (parameterize ([current-directory pset]) - (for-each (lambda (sub) - (when (directory-exists? sub) ; filter non-dirs - (cleanup-submission sub))) - (directory-list))))) - (get-conf 'all-dirs))) + (for ([pset (get-conf 'all-dirs)] + #:when (directory-exists? pset)) ; just in case + (parameterize ([current-directory pset]) + (for ([sub (directory-list)] + #:when (directory-exists? sub)) ; filter non-dirs + (cleanup-submission sub))))) ;; On startup, we scan all submissions, then repeat at random intervals (only ;; if clients connected in that time), and check often for changes in the @@ -193,15 +189,11 @@ ;; we have a submission, need to create a directory if needed, make ;; sure that no users submitted work with someone else (unless (directory-exists? dirname) - (for-each - (lambda (dir) - (for-each - (lambda (d) - (when (member d users) - (error* "bad submission: ~a has an existing submission (~a)" - d dir))) - (regexp-split #rx" *[+] *" (path->string dir)))) - (directory-list)) + (for* ([dir (directory-list)] + [d (regexp-split #rx" *[+] *" (path->string dir))]) + (when (member d users) + (error* "bad submission: ~a has an existing submission (~a)" + d dir))) (make-directory dirname)) (parameterize ([current-directory dirname] [current-messenger @@ -378,9 +370,9 @@ (error* "the username \"checker.ss\" is reserved")) (when (get-user-data username) (error* "username already exists: `~a'" username)) - (for-each (lambda (str info) - (check-field str (cadr info) (car info) (caddr info))) - extra-fields (get-conf 'extra-fields)) + (for ([str extra-fields] + [info (get-conf 'extra-fields)]) + (check-field str (cadr info) (car info) (caddr info))) (wait-for-lock "+newuser+") (log-line "create user: ~a" username) (hook 'user-create `([username ,username] [fields ,extra-fields])) @@ -405,9 +397,9 @@ (error* "changing information not allowed: ~a" username)) (when (equal? new-data old-data) (error* "no fields changed: ~a" username)) - (for-each (lambda (str info) - (check-field str (cadr info) (car info) (caddr info))) - (cdr new-data) (get-conf 'extra-fields)) + (for ([str (cdr new-data)] + [info (get-conf 'extra-fields)]) + (check-field str (cadr info) (car info) (caddr info))) (log-line "change info for ~a ~s -> ~s" username old-data new-data) (unless (equal? (cdr new-data) (cdr old-data)) ; not for password change (hook 'user-change `([username ,username] diff --git a/collects/handin-server/private/hooker.ss b/collects/handin-server/private/hooker.ss index ef40587927..f8ae54b0f2 100644 --- a/collects/handin-server/private/hooker.ss +++ b/collects/handin-server/private/hooker.ss @@ -1,18 +1,17 @@ -(module hooker mzscheme - (require "config.ss" "logger.ss" "reloadable.ss") +#lang scheme/base - (provide hook) +(require "config.ss" "logger.ss" "reloadable.ss") - (define hook-file #f) - (define hook-proc #f) +(provide hook) - (define (hook what alist) - (let ([file (get-conf 'hook-file)]) - (when file - (unless (equal? file hook-file) - (set! hook-file file) - (set! hook-proc (auto-reload-procedure `(file ,(path->string file)) - 'hook))) - (hook-proc what (current-session) alist)))) +(define hook-file #f) +(define hook-proc #f) - ) +(define (hook what alist) + (let ([file (get-conf 'hook-file)]) + (when file + (unless (equal? file hook-file) + (set! hook-file file) + (set! hook-proc (auto-reload-procedure `(file ,(path->string file)) + 'hook))) + (hook-proc what (current-session) alist)))) diff --git a/collects/handin-server/private/lock.ss b/collects/handin-server/private/lock.ss index 870cbb5bbc..9804eb8f0c 100644 --- a/collects/handin-server/private/lock.ss +++ b/collects/handin-server/private/lock.ss @@ -1,64 +1,63 @@ -(module lock mzscheme - (require mzlib/list) +#lang scheme/base - (provide wait-for-lock) +(provide wait-for-lock) - ;; wait-for-lock : string -> void - ;; Gets a lock on `user' for the calling thread; the lock lasts until the - ;; calling thread terminates. If the lock was actually acquired, then on - ;; release the cleanup-thunk will be executed (unless it is #f), even if it - ;; was released when the acquiring thread crashed. - ;; *** Warning: It's vital that a clean-up thunk doesn't raise an exception, - ;; since this will kill the lock thread which will lock down everything - (define (wait-for-lock user . cleanup-thunk) - (let ([s (make-semaphore)]) - (channel-put req-ch - (make-req (thread-dead-evt (current-thread)) user s - (and (pair? cleanup-thunk) (car cleanup-thunk)))) - (semaphore-wait s))) +;; wait-for-lock : string -> void +;; Gets a lock on `user' for the calling thread; the lock lasts until the +;; calling thread terminates. If the lock was actually acquired, then on +;; release the cleanup-thunk will be executed (unless it is #f), even if it +;; was released when the acquiring thread crashed. +;; *** Warning: It's vital that a clean-up thunk doesn't raise an exception, +;; since this will kill the lock thread which will lock down everything +(define (wait-for-lock user . cleanup-thunk) + (let ([s (make-semaphore)]) + (channel-put req-ch + (make-req (thread-dead-evt (current-thread)) user s + (and (pair? cleanup-thunk) (car cleanup-thunk)))) + (semaphore-wait s))) - (define req-ch (make-channel)) +(define req-ch (make-channel)) - (define-struct req (thread-dead-evt user sema cleanup-thunk)) +(define-struct req (thread-dead-evt user sema cleanup-thunk)) - (thread - (lambda () - (let loop ([locks null] - [reqs null]) - (let-values ([(locks reqs) - ;; Try to satisfy lock requests: - (let loop ([reqs (reverse reqs)] - [locks locks] - [new-reqs null]) - (if (null? reqs) - (values locks new-reqs) - (let ([req (car reqs)] - [rest (cdr reqs)]) - (if (assoc (req-user req) locks) - ;; Lock not available: - (loop rest locks (cons req new-reqs)) - ;; Lock is available, so take it: - (begin (semaphore-post (req-sema req)) - (loop (cdr reqs) - (cons (cons (req-user req) req) locks) - new-reqs))))))]) - (sync - (handle-evt req-ch (lambda (req) (loop locks (cons req reqs)))) - ;; Release a lock whose thread is gone: - (apply choice-evt - (map (lambda (name+req) - (handle-evt - (req-thread-dead-evt (cdr name+req)) - (lambda (v) - ;; releasing a lock => run cleanup - (cond [(req-cleanup-thunk (cdr name+req)) - => (lambda (t) (t))]) - (loop (remq name+req locks) reqs)))) - locks)) - ;; Throw away a request whose thread is gone: - (apply choice-evt - (map (lambda (req) - (handle-evt - (req-thread-dead-evt req) - (lambda (v) (loop locks (remq req reqs))))) - reqs)))))))) +(thread + (lambda () + (let loop ([locks null] + [reqs null]) + (let-values ([(locks reqs) + ;; Try to satisfy lock requests: + (let loop ([reqs (reverse reqs)] + [locks locks] + [new-reqs null]) + (if (null? reqs) + (values locks new-reqs) + (let ([req (car reqs)] + [rest (cdr reqs)]) + (if (assoc (req-user req) locks) + ;; Lock not available: + (loop rest locks (cons req new-reqs)) + ;; Lock is available, so take it: + (begin (semaphore-post (req-sema req)) + (loop (cdr reqs) + (cons (cons (req-user req) req) locks) + new-reqs))))))]) + (sync + (handle-evt req-ch (lambda (req) (loop locks (cons req reqs)))) + ;; Release a lock whose thread is gone: + (apply choice-evt + (map (lambda (name+req) + (handle-evt + (req-thread-dead-evt (cdr name+req)) + (lambda (v) + ;; releasing a lock => run cleanup + (cond [(req-cleanup-thunk (cdr name+req)) + => (lambda (t) (t))]) + (loop (remq name+req locks) reqs)))) + locks)) + ;; Throw away a request whose thread is gone: + (apply choice-evt + (map (lambda (req) + (handle-evt + (req-thread-dead-evt req) + (lambda (v) (loop locks (remq req reqs))))) + reqs))))))) diff --git a/collects/handin-server/private/reloadable.ss b/collects/handin-server/private/reloadable.ss index ff8be9f1aa..defa9a8fc7 100644 --- a/collects/handin-server/private/reloadable.ss +++ b/collects/handin-server/private/reloadable.ss @@ -1,48 +1,46 @@ -(module reloadable mzscheme +#lang scheme/base - (require syntax/moddep "logger.ss") +(require syntax/moddep "logger.ss") - (provide reload-module) - (define (reload-module modspec path) - ;; the path argument is not needed (could use resolve-module-path here), - ;; but its always known when this function is called - (let* ([name ((current-module-name-resolver) modspec #f #f)]) - (log-line "(re)loading module from ~a" modspec) - (parameterize ([current-module-declare-name name] - [compile-enforce-module-constants #f]) - (namespace-require '(only mzscheme module #%top-interaction)) - (load/use-compiled path)))) +(provide reload-module) +(define (reload-module modspec path) + ;; the path argument is not needed (could use resolve-module-path here), but + ;; its always known when this function is called + (let* ([name ((current-module-name-resolver) modspec #f #f)]) + (log-line "(re)loading module from ~a" modspec) + (parameterize ([current-module-declare-name name] + [compile-enforce-module-constants #f]) + (namespace-require '(only mzscheme module #%top-interaction)) + (load/use-compiled path)))) - ;; pulls out a value from a module, reloading the module if its source file - ;; was modified - (provide auto-reload-value) - (define module-times (make-hash-table 'equal)) - (define (auto-reload-value modspec valname) - (let* ([path (resolve-module-path modspec #f)] - [last (hash-table-get module-times path #f)] - [cur (file-or-directory-modify-seconds path)]) - (unless (equal? cur last) - (hash-table-put! module-times path cur) - (reload-module modspec path)) - (dynamic-require modspec valname))) +;; pulls out a value from a module, reloading the module if its source file was +;; modified +(provide auto-reload-value) +(define module-times (make-hash)) +(define (auto-reload-value modspec valname) + (let* ([path (resolve-module-path modspec #f)] + [last (hash-ref module-times path #f)] + [cur (file-or-directory-modify-seconds path)]) + (unless (equal? cur last) + (hash-set! module-times path cur) + (reload-module modspec path)) + (dynamic-require modspec valname))) - (define poll-freq 2000.0) ; poll at most once every two seconds +(define poll-freq 2000.0) ; poll at most once every two seconds - ;; pulls out a procedure from a module, and returns a wrapped procedure that - ;; automatically reloads the module if the file was changed whenever the - ;; procedure is used - (provide auto-reload-procedure) - (define (auto-reload-procedure modspec procname) - (let ([path (resolve-module-path modspec #f)] [date #f] [proc #f] [poll #f]) - (define (reload) - (unless (and proc (< (- (current-inexact-milliseconds) poll) poll-freq)) - (set! poll (current-inexact-milliseconds)) - (let ([cur (file-or-directory-modify-seconds path)]) - (unless (equal? cur date) - (set! date cur) - (reload-module modspec path) - (set! proc (dynamic-require modspec procname)))))) - (reload) - (lambda xs (reload) (apply proc xs)))) - - ) +;; pulls out a procedure from a module, and returns a wrapped procedure that +;; automatically reloads the module if the file was changed whenever the +;; procedure is used +(provide auto-reload-procedure) +(define (auto-reload-procedure modspec procname) + (let ([path (resolve-module-path modspec #f)] [date #f] [proc #f] [poll #f]) + (define (reload) + (unless (and proc (< (- (current-inexact-milliseconds) poll) poll-freq)) + (set! poll (current-inexact-milliseconds)) + (let ([cur (file-or-directory-modify-seconds path)]) + (unless (equal? cur date) + (set! date cur) + (reload-module modspec path) + (set! proc (dynamic-require modspec procname)))))) + (reload) + (lambda xs (reload) (apply proc xs)))) diff --git a/collects/handin-server/private/run-status.ss b/collects/handin-server/private/run-status.ss index fdb82027c4..b960a81ffc 100644 --- a/collects/handin-server/private/run-status.ss +++ b/collects/handin-server/private/run-status.ss @@ -1,21 +1,19 @@ -(module run-status mzscheme +#lang scheme/base - (provide current-run-status-box set-run-status - current-messenger message) +(provide current-run-status-box set-run-status + current-messenger message) - ;; current-run-status-box is used to let the client know where we are in the - ;; submission process. - (define current-run-status-box (make-parameter #f)) +;; current-run-status-box is used to let the client know where we are in the +;; submission process. +(define current-run-status-box (make-parameter #f)) - ;; current-messenger is a function that will send a message to the client. - (define current-messenger (make-parameter #f)) - (define (message . args) - (let ([messenger (current-messenger)]) - (and messenger (apply messenger args)))) +;; current-messenger is a function that will send a message to the client. +(define current-messenger (make-parameter #f)) +(define (message . args) + (let ([messenger (current-messenger)]) + (and messenger (apply messenger args)))) - ;; Set the current-run-status-box and send a message. - (define (set-run-status s) - (let ([b (current-run-status-box)]) - (when b (set-box! b s) (message s)))) - - ) +;; Set the current-run-status-box and send a message. +(define (set-run-status s) + (let ([b (current-run-status-box)]) + (when b (set-box! b s) (message s))))