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

yet more v4-isms

Browse Source 
svn: r11684
This commit is contained in:
Eli Barzilay 2008-09-12 15:41:34 +00:00
parent 0c0630d50d
commit 5541890dd5
6 changed files with 173 additions and 195 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
collects/handin-server/checker.ss
View File

@ -191,10 +191,8 @@
;; This code will hack textualization of text boxes ;; This code will hack textualization of text boxes
(define (insert-to-editor editor . xs) (define (insert-to-editor editor . xs)
(for-each (lambda (x) (for ([x xs])
(send editor insert (send editor insert (if (string? x) x (make-object editor-snip% x)))))
(if (string? x) x (make-object editor-snip% x))))
xs))
;; support for "text-box%" ;; support for "text-box%"
(define text-box-sc (define text-box-sc
@ -284,10 +282,9 @@
'(ok-cancel caution))))) '(ok-cancel caution)))))
(error* "Aborting..."))) (error* "Aborting...")))
;; This will create copies of the original files ;; This will create copies of the original files
;; (for-each (lambda (file) ;; (for ([file files])
;; (with-output-to-file (car file) ;; (with-output-to-file (car file)
;; (lambda () (display (cadr file)) (flush-output)))) ;; (lambda () (display (cadr file)) (flush-output))))
;; files)
(let* ([pfx-len (string-length markup-prefix)] (let* ([pfx-len (string-length markup-prefix)]
[line-len (- maxwidth pfx-len)] [line-len (- maxwidth pfx-len)]
[=s (lambda (n) (if (<= 0 n) (make-string n #\=) ""))] [=s (lambda (n) (if (<= 0 n) (make-string n #\=) ""))]
@ -301,14 +298,12 @@
(display ===) (display ===)
(newline)) (newline))
(parameterize ([current-output-port (open-output-bytes)]) (parameterize ([current-output-port (open-output-bytes)])
(for-each (lambda (file) (for ([file files])
(sep (car file)) (sep (car file))
(parameterize ([current-input-port (parameterize ([current-input-port (open-input-bytes (cadr file))]
(open-input-bytes (cadr file))] [current-processed-file (car file)])
[current-processed-file (car file)]) (input->process->output
(input->process->output maxwidth textualize? untabify? prefix-re)))
maxwidth textualize? untabify? prefix-re)))
files)
(get-output-bytes (current-output-port)))))) (get-output-bytes (current-output-port))))))
;; ============================================================================ ;; ============================================================================
@ -394,10 +389,9 @@
[user-post (id 'user-post)] [user-post (id 'user-post)]
[(body ...) (syntax-case #'(body ...) () [(body ...) (syntax-case #'(body ...) ()
[() #'(void)] [_ #'(body ...)])]) [() #'(void)] [_ #'(body ...)])])
(for-each (lambda (x) (for ([x keyvals])
(unless (memq (car x) got) (unless (memq (car x) got)
(raise-syntax-error #f "unknown keyword" stx (cadr x)))) (raise-syntax-error #f "unknown keyword" stx (cadr x))))
keyvals)
#'(begin #'(begin
(provide checker) (provide checker)
(define checker (define checker
@ -476,10 +470,8 @@
(set-run-status "creating text file") (set-run-status "creating text file")
(with-output-to-file text-file #:exists 'truncate (with-output-to-file text-file #:exists 'truncate
(lambda () (lambda ()
(for-each (lambda (user) (for ([user users])
(prefix-line (prefix-line (user-substs user student-line)))
(user-substs user student-line)))
users)
(for-each prefix-line/substs extra-lines) (for-each prefix-line/substs extra-lines)
(for-each prefix-line/substs (for-each prefix-line/substs
(or (thread-cell-ref added-lines) '())) (or (thread-cell-ref added-lines) '()))

68
collects/handin-server/main.ss
View File

@ -24,7 +24,7 @@
(error (apply format fmt args))) (error (apply format fmt args)))
(define (write+flush port . xs) (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)) (flush-output port))
(define-struct alist (name [l #:mutable])) (define-struct alist (name [l #:mutable]))
@ -87,20 +87,18 @@
;; SUCCESS, or things that are newer in the main submission ;; SUCCESS, or things that are newer in the main submission
;; directory are kept (but subdirs in SUCCESS will are copied as ;; directory are kept (but subdirs in SUCCESS will are copied as
;; is)) ;; is))
(for-each (for ([f (directory-list dir)])
(lambda (f) (define dir/f (build-path dir f))
(define dir/f (build-path dir f)) (cond [(not (or (file-exists? f) (directory-exists? f)))
(cond [(not (or (file-exists? f) (directory-exists? f))) ;; f is in dir but not in the working directory
;; f is in dir but not in the working directory (copy-directory/files dir/f f)]
(copy-directory/files dir/f f)] [(or (<= (file-or-directory-modify-seconds f)
[(or (<= (file-or-directory-modify-seconds f) (file-or-directory-modify-seconds dir/f))
(file-or-directory-modify-seconds dir/f)) (and (file-exists? f) (file-exists? dir/f)
(and (file-exists? f) (file-exists? dir/f) (not (= (file-size f) (file-size dir/f)))))
(not (= (file-size f) (file-size dir/f))))) ;; f is newer in dir than in the working directory
;; f is newer in dir than in the working directory (delete-directory/files f)
(delete-directory/files f) (copy-directory/files dir/f f)])))))
(copy-directory/files dir/f f)]))
(directory-list dir)))))
(define cleanup-sema (make-semaphore 1)) (define cleanup-sema (make-semaphore 1))
(define (cleanup-submission dir) (define (cleanup-submission dir)
@ -118,14 +116,12 @@
(define (cleanup-all-submissions) (define (cleanup-all-submissions)
(log-line "Cleaning up all submission directories") (log-line "Cleaning up all submission directories")
(for-each (lambda (pset) (for ([pset (get-conf 'all-dirs)]
(when (directory-exists? pset) ; just in case #:when (directory-exists? pset)) ; just in case
(parameterize ([current-directory pset]) (parameterize ([current-directory pset])
(for-each (lambda (sub) (for ([sub (directory-list)]
(when (directory-exists? sub) ; filter non-dirs #:when (directory-exists? sub)) ; filter non-dirs
(cleanup-submission sub))) (cleanup-submission sub)))))
(directory-list)))))
(get-conf 'all-dirs)))
;; On startup, we scan all submissions, then repeat at random intervals (only ;; 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 ;; 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 ;; we have a submission, need to create a directory if needed, make
;; sure that no users submitted work with someone else ;; sure that no users submitted work with someone else
(unless (directory-exists? dirname) (unless (directory-exists? dirname)
(for-each (for* ([dir (directory-list)]
(lambda (dir) [d (regexp-split #rx" *[+] *" (path->string dir))])
(for-each (when (member d users)
(lambda (d) (error* "bad submission: ~a has an existing submission (~a)"
(when (member d users) d dir)))
(error* "bad submission: ~a has an existing submission (~a)"
d dir)))
(regexp-split #rx" *[+] *" (path->string dir))))
(directory-list))
(make-directory dirname)) (make-directory dirname))
(parameterize ([current-directory dirname] (parameterize ([current-directory dirname]
[current-messenger [current-messenger
@ -378,9 +370,9 @@
(error* "the username \"checker.ss\" is reserved")) (error* "the username \"checker.ss\" is reserved"))
(when (get-user-data username) (when (get-user-data username)
(error* "username already exists: `~a'" username)) (error* "username already exists: `~a'" username))
(for-each (lambda (str info) (for ([str extra-fields]
(check-field str (cadr info) (car info) (caddr info))) [info (get-conf 'extra-fields)])
extra-fields (get-conf 'extra-fields)) (check-field str (cadr info) (car info) (caddr info)))
(wait-for-lock "+newuser+") (wait-for-lock "+newuser+")
(log-line "create user: ~a" username) (log-line "create user: ~a" username)
(hook 'user-create `([username ,username] [fields ,extra-fields])) (hook 'user-create `([username ,username] [fields ,extra-fields]))
@ -405,9 +397,9 @@
(error* "changing information not allowed: ~a" username)) (error* "changing information not allowed: ~a" username))
(when (equal? new-data old-data) (when (equal? new-data old-data)
(error* "no fields changed: ~a" username)) (error* "no fields changed: ~a" username))
(for-each (lambda (str info) (for ([str (cdr new-data)]
(check-field str (cadr info) (car info) (caddr info))) [info (get-conf 'extra-fields)])
(cdr new-data) (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) (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 (unless (equal? (cdr new-data) (cdr old-data)) ; not for password change
(hook 'user-change `([username ,username] (hook 'user-change `([username ,username]

27
collects/handin-server/private/hooker.ss
View File

@ -1,18 +1,17 @@
(module hooker mzscheme #lang scheme/base
(require "config.ss" "logger.ss" "reloadable.ss")
(provide hook) (require "config.ss" "logger.ss" "reloadable.ss")
(define hook-file #f) (provide hook)
(define hook-proc #f)
(define (hook what alist) (define hook-file #f)
(let ([file (get-conf 'hook-file)]) (define hook-proc #f)
(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 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))))

117
collects/handin-server/private/lock.ss
View File

@ -1,64 +1,63 @@
(module lock mzscheme #lang scheme/base
(require mzlib/list)
(provide wait-for-lock) (provide wait-for-lock)
;; wait-for-lock : string -> void ;; wait-for-lock : string -> void
;; Gets a lock on `user' for the calling thread; the lock lasts until the ;; 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 ;; 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 ;; release the cleanup-thunk will be executed (unless it is #f), even if it
;; was released when the acquiring thread crashed. ;; was released when the acquiring thread crashed.
;; *** Warning: It's vital that a clean-up thunk doesn't raise an exception, ;; *** 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 ;; since this will kill the lock thread which will lock down everything
(define (wait-for-lock user . cleanup-thunk) (define (wait-for-lock user . cleanup-thunk)
(let ([s (make-semaphore)]) (let ([s (make-semaphore)])
(channel-put req-ch (channel-put req-ch
(make-req (thread-dead-evt (current-thread)) user s (make-req (thread-dead-evt (current-thread)) user s
(and (pair? cleanup-thunk) (car cleanup-thunk)))) (and (pair? cleanup-thunk) (car cleanup-thunk))))
(semaphore-wait s))) (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 (thread
(lambda () (lambda ()
(let loop ([locks null] (let loop ([locks null]
[reqs null]) [reqs null])
(let-values ([(locks reqs) (let-values ([(locks reqs)
;; Try to satisfy lock requests: ;; Try to satisfy lock requests:
(let loop ([reqs (reverse reqs)] (let loop ([reqs (reverse reqs)]
[locks locks] [locks locks]
[new-reqs null]) [new-reqs null])
(if (null? reqs) (if (null? reqs)
(values locks new-reqs) (values locks new-reqs)
(let ([req (car reqs)] (let ([req (car reqs)]
[rest (cdr reqs)]) [rest (cdr reqs)])
(if (assoc (req-user req) locks) (if (assoc (req-user req) locks)
;; Lock not available: ;; Lock not available:
(loop rest locks (cons req new-reqs)) (loop rest locks (cons req new-reqs))
;; Lock is available, so take it: ;; Lock is available, so take it:
(begin (semaphore-post (req-sema req)) (begin (semaphore-post (req-sema req))
(loop (cdr reqs) (loop (cdr reqs)
(cons (cons (req-user req) req) locks) (cons (cons (req-user req) req) locks)
new-reqs))))))]) new-reqs))))))])
(sync (sync
(handle-evt req-ch (lambda (req) (loop locks (cons req reqs)))) (handle-evt req-ch (lambda (req) (loop locks (cons req reqs))))
;; Release a lock whose thread is gone: ;; Release a lock whose thread is gone:
(apply choice-evt (apply choice-evt
(map (lambda (name+req) (map (lambda (name+req)
(handle-evt (handle-evt
(req-thread-dead-evt (cdr name+req)) (req-thread-dead-evt (cdr name+req))
(lambda (v) (lambda (v)
;; releasing a lock => run cleanup ;; releasing a lock => run cleanup
(cond [(req-cleanup-thunk (cdr name+req)) (cond [(req-cleanup-thunk (cdr name+req))
=> (lambda (t) (t))]) => (lambda (t) (t))])
(loop (remq name+req locks) reqs)))) (loop (remq name+req locks) reqs))))
locks)) locks))
;; Throw away a request whose thread is gone: ;; Throw away a request whose thread is gone:
(apply choice-evt (apply choice-evt
(map (lambda (req) (map (lambda (req)
(handle-evt (handle-evt
(req-thread-dead-evt req) (req-thread-dead-evt req)
(lambda (v) (loop locks (remq req reqs))))) (lambda (v) (loop locks (remq req reqs)))))
reqs)))))))) reqs)))))))

84
collects/handin-server/private/reloadable.ss
View File

@ -1,48 +1,46 @@
(module reloadable mzscheme #lang scheme/base
(require syntax/moddep "logger.ss") (require syntax/moddep "logger.ss")
(provide reload-module) (provide reload-module)
(define (reload-module modspec path) (define (reload-module modspec path)
;; the path argument is not needed (could use resolve-module-path here), ;; the path argument is not needed (could use resolve-module-path here), but
;; but its always known when this function is called ;; its always known when this function is called
(let* ([name ((current-module-name-resolver) modspec #f #f)]) (let* ([name ((current-module-name-resolver) modspec #f #f)])
(log-line "(re)loading module from ~a" modspec) (log-line "(re)loading module from ~a" modspec)
(parameterize ([current-module-declare-name name] (parameterize ([current-module-declare-name name]
[compile-enforce-module-constants #f]) [compile-enforce-module-constants #f])
(namespace-require '(only mzscheme module #%top-interaction)) (namespace-require '(only mzscheme module #%top-interaction))
(load/use-compiled path)))) (load/use-compiled path))))
;; pulls out a value from a module, reloading the module if its source file ;; pulls out a value from a module, reloading the module if its source file was
;; was modified ;; modified
(provide auto-reload-value) (provide auto-reload-value)
(define module-times (make-hash-table 'equal)) (define module-times (make-hash))
(define (auto-reload-value modspec valname) (define (auto-reload-value modspec valname)
(let* ([path (resolve-module-path modspec #f)] (let* ([path (resolve-module-path modspec #f)]
[last (hash-table-get module-times path #f)] [last (hash-ref module-times path #f)]
[cur (file-or-directory-modify-seconds path)]) [cur (file-or-directory-modify-seconds path)])
(unless (equal? cur last) (unless (equal? cur last)
(hash-table-put! module-times path cur) (hash-set! module-times path cur)
(reload-module modspec path)) (reload-module modspec path))
(dynamic-require modspec valname))) (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 ;; pulls out a procedure from a module, and returns a wrapped procedure that
;; automatically reloads the module if the file was changed whenever the ;; automatically reloads the module if the file was changed whenever the
;; procedure is used ;; procedure is used
(provide auto-reload-procedure) (provide auto-reload-procedure)
(define (auto-reload-procedure modspec procname) (define (auto-reload-procedure modspec procname)
(let ([path (resolve-module-path modspec #f)] [date #f] [proc #f] [poll #f]) (let ([path (resolve-module-path modspec #f)] [date #f] [proc #f] [poll #f])
(define (reload) (define (reload)
(unless (and proc (< (- (current-inexact-milliseconds) poll) poll-freq)) (unless (and proc (< (- (current-inexact-milliseconds) poll) poll-freq))
(set! poll (current-inexact-milliseconds)) (set! poll (current-inexact-milliseconds))
(let ([cur (file-or-directory-modify-seconds path)]) (let ([cur (file-or-directory-modify-seconds path)])
(unless (equal? cur date) (unless (equal? cur date)
(set! date cur) (set! date cur)
(reload-module modspec path) (reload-module modspec path)
(set! proc (dynamic-require modspec procname)))))) (set! proc (dynamic-require modspec procname))))))
(reload) (reload)
(lambda xs (reload) (apply proc xs)))) (lambda xs (reload) (apply proc xs))))
)

32
collects/handin-server/private/run-status.ss
View File

@ -1,21 +1,19 @@
(module run-status mzscheme #lang scheme/base
(provide current-run-status-box set-run-status (provide current-run-status-box set-run-status
current-messenger message) current-messenger message)
;; current-run-status-box is used to let the client know where we are in the ;; current-run-status-box is used to let the client know where we are in the
;; submission process. ;; submission process.
(define current-run-status-box (make-parameter #f)) (define current-run-status-box (make-parameter #f))
;; current-messenger is a function that will send a message to the client. ;; current-messenger is a function that will send a message to the client.
(define current-messenger (make-parameter #f)) (define current-messenger (make-parameter #f))
(define (message . args) (define (message . args)
(let ([messenger (current-messenger)]) (let ([messenger (current-messenger)])
(and messenger (apply messenger args)))) (and messenger (apply messenger args))))
;; Set the current-run-status-box and send a message. ;; Set the current-run-status-box and send a message.
(define (set-run-status s) (define (set-run-status s)
(let ([b (current-run-status-box)]) (let ([b (current-run-status-box)])
(when b (set-box! b s) (message s)))) (when b (set-box! b s) (message s))))
)