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
(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) '()))

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

@ -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]

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

@ -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))))

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

@ -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)))))))

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)
(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))))

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
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))))