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

* checker modules are reloaded when the file changes, so there is no

Browse Source 
longer any need to restart the server.
* Added a 'hook-file option that specifies a module providing a
  generic hook.  Useful for notifications when important things
  happen, but can be used for anything.  Reloaded on change too.

svn: r5463
This commit is contained in:
Eli Barzilay 2007-01-26 06:51:36 +00:00
parent ebcf1e7817
commit 2698bf52fb
7 changed files with 159 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

61
collects/handin-server/doc.txt
View File

@ -297,6 +297,40 @@ This directory contains the following files and sub-directories:
information. (The third element for such descriptors is
ignored.)
'hook-file : a path (relative to handin server directory or
absolute) that specifies a filename that contains a `hook'
module. This is useful as a general device for customizing
the server through Scheme code. The file is expected to
contain a module that provides a `hook' function, which
should be receiving three arguments:
- a symbol that indicates the operation that is now taking
place;
- a datum that specifies the connection context (a number for
handin connections, a `wN' symbol for servlet connections,
and #f for other server operations);
- an alist of information relevant to this operation.
Currently, the hook is used in several places after an
operation has completed. The first argument will be one of
these symbols: 'server-start, 'server-connect, 'user-create,
'user-change, 'login, 'submission-received,
'submission-committed, 'submission-retrieved, 'status-login,
'status-file-get. For example, here is a simple hook module
that sends notification messages when users are created or
their information has changed:
(module hook mzscheme
(provide hook)
(require (lib "sendmail.ss" "net"))
(define (hook what session alist)
(when (memq what '(user-create user-change))
(send-mail-message
"course-staff@university.edu"
(format "[server] ~a (~a)" what session)
'("course-staff@university.edu") '() '()
(map (lambda (key+val)
(apply format "~a: ~s" key+val))
alist)))))
Changes to "config.ss" are detected, the file will be re-read, and
options are reloaded. A few options are fixed at startup time:
port numbers, log file specs, and the `web-base-dir' are as
@ -438,14 +472,18 @@ This directory contains the following files and sub-directories:
web server.
* "<active-assignment>/checker.ss" (optional) --- a module that
exports a `checker' function. This function receives two strings.
The first is a username list and the second is the submission as a
byte string. (See also `unpack-submission', etc. from "util.ss",
below.) To reject the submission, the `checker' function can
raise an exception; the exception message will be relayed back to
the student. The module is loaded when the current directory is
the main server directory, so it can read information from
"config.ss".
exports a `checker' function. This function receives two
arguments: a username list and a submission as a byte string.
(See also `unpack-submission', etc. from "util.ss", below.) To
reject the submission, the `checker' function can raise an
exception; the exception message will be relayed back to the
student. The module is loaded when the current directory is the
main server directory, so it can read files from there (but note
that to read values from "config.ss" it is better to use
`get-conf'). Also, the module will be reloaded if the checker
file is modified -- no need to restart the server, but make sure
that you do not save a broken checker (ie, do not save in
mid-edit).
The first argument is a list of usernames with at least one
username, and more than one if this is a joint submission (where
@ -523,10 +561,9 @@ related crashes.
The server currently provides no mechanism for a graceful shutdown,
but terminating the server is no worse than a network outage. (In
particular, no data should be lost.) To reconfigure the server (e.g.,
to change a checker module), stop it and restart it. (Changing the
configuration file is detected, and options are reloaded, so no
restart is needed for that.)
particular, no data should be lost.) The server reloads the
configuration file, checker modules etc, so there should not be any
need to restart it for reconfigurations.
The client and server are designed to be robust against network
problems and timeouts. The client-side tool always provides a

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

@ -11,6 +11,8 @@
"private/lock.ss"
"private/md5.ss"
"private/run-status.ss"
"private/reloadable.ss"
"private/hooker.ss"
"web-status-server.ss")
(install-logger-port)
@ -163,6 +165,7 @@
(unless (member assignment assignments)
(error* "not an active assignment: ~a" assignment))
(log-line "assignment for ~a: ~a" users assignment)
(hook 'submission-received `([usernames ,users] [assignment ,assignment]))
(write+flush w 'ok)
(set! len (read r-safe))
(unless (and (number? len) (integer? len) (positive? len))
@ -216,7 +219,9 @@
(let* ([checker* (path->complete-path (build-path 'up "checker.ss"))]
[checker* (and (file-exists? checker*)
(parameterize ([current-directory server-dir])
(dynamic-require checker* 'checker)))])
(auto-reload-value
`(file ,(path->string checker*))
'checker)))])
(define-values (pre checker post)
(cond [(not checker*) (values #f #f #f)]
[(procedure? checker*) (values #f checker* #f)]
@ -257,6 +262,8 @@
;; no SUCCESS-0:
(make-success-dir-available 0)
(rename-file-or-directory ATTEMPT-DIR (success-dir 0))
(hook 'submission-committed
`([usernames ,users] [assignment ,assignment]))
(when post
(parameterize ([current-directory (success-dir 0)])
(post users s))))
@ -299,7 +306,9 @@
(write+flush w len)
(display "$" w)
(display (with-input-from-file file (lambda () (read-bytes len))) w)
(flush-output w))
(flush-output w)
(hook 'submission-retrieved
`([usernames ,users] [assignment ,assignment])))
(error* "no ~a submission file found for ~a" assignment users))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -369,6 +378,7 @@
extra-fields (get-conf 'extra-fields))
(wait-for-lock "+newuser+")
(log-line "create user: ~a" username)
(hook 'user-create `([username ,username] [fields ,extra-fields]))
(put-user-data username (cons passwd extra-fields)))
(define (change-user-info data)
@ -381,19 +391,24 @@
(error* "cannot change a password for multiple users: ~a" usernames))
;; the new data is the same as the old one for every empty string (includes
;; hidden fields)
(let ([new-data (map (lambda (old new) (if (equal? "" new) old new))
(car user-datas) (cons passwd extra-fields))])
(let* ([username (car usernames)]
[old-data (car user-datas)]
[new-data (map (lambda (old new) (if (equal? "" new) old new))
old-data (cons passwd extra-fields))])
(unless (or (get-conf 'allow-change-info)
(equal? (cdr new-data) (cdar user-datas)))
(error* "changing information not allowed: ~a" (car usernames)))
(when (equal? new-data (car user-datas))
(error* "no fields changed: ~a" (car usernames)))
(equal? (cdr new-data) (cdr old-data)))
(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))
(log-line "change info for ~a ~s -> ~s"
(car usernames) (car user-datas) new-data)
(put-user-data (car usernames) 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
(hook 'user-change `([username ,username]
[old ,(cdr old-data)]
[new ,(cdr new-data)])))
(put-user-data username new-data)))
(define (get-user-info data)
(define usernames (a-ref data 'usernames))
@ -506,7 +521,8 @@
(log-line "failed login: ~a" (a-ref data 'username/s))
(error* "bad username or password for ~a"
(a-ref data 'username/s)))
(log-line "login: ~a" usernames))
(log-line "login: ~a" usernames)
(hook 'login `([usernames ,usernames])))
(case msg
[(change-user-info) (change-user-info data)]
[(save-submission) (accept-specific-submission data r r-safe w)]
@ -606,6 +622,7 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(log-line "server started ------------------------------")
(hook 'server-start `([port ,(get-conf 'port-number)]))
(define stop-status (serve-status (get-conf 'https-port-number)))
@ -622,7 +639,8 @@
(begin (set! session-count (add1 session-count))
session-count)])
(let-values ([(here there) (ssl-addresses r)])
(log-line "connect from ~a" there))
(log-line "connect from ~a" there)
(hook 'server-connect `([from ,there])))
(with-watcher
w
(lambda (kill-watcher)

1
collects/handin-server/private/config.ss
View File

@ -52,6 +52,7 @@
[(inactive-dirs) (values '() path-list )]
[(port-number) (values 7979 id )]
[(https-port-number) (values (add1 (get-conf 'port-number)) id )]
[(hook-file) (values #f path/false )]
[(session-timeout) (values 300 id )]
[(session-memory-limit) (values 40000000 id )]
[(default-file-name) (values "handin.scm" id )]

18
collects/handin-server/private/hooker.ss Normal file
View File

@ -0,0 +1,18 @@
(module hooker mzscheme
(require "config.ss" "logger.ss" "reloadable.ss")
(provide hook)
(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))))
)

53
collects/handin-server/private/reloadable.ss Normal file
View File

@ -0,0 +1,53 @@
(module reloadable mzscheme
(require (lib "moddep.ss" "syntax"))
(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)]
[name (symbol->string name)]
[name (if (eq? #\, (string-ref name 0))
(substring name 1)
(error 'reload-module
"unexpected module name for ~e: ~e" modspec name))]
[prefix (let-values ([(base name dir?) (split-path name)])
(string->symbol (format ",~a" base)))])
(parameterize ([current-module-name-prefix prefix]
[compile-enforce-module-constants #f])
(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)))
(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))))
)

5
collects/handin-server/status-web-root/servlets/status.ss
View File

@ -8,7 +8,8 @@
(lib "uri-codec.ss" "net")
(lib "md5.ss" "handin-server" "private")
(lib "logger.ss" "handin-server" "private")
(lib "config.ss" "handin-server" "private"))
(lib "config.ss" "handin-server" "private")
(lib "hooker.ss" "handin-server" "private"))
(define get-user-data
(let ([users-file (build-path server-dir "users.ss")])
@ -185,6 +186,7 @@
(check file `(#rx"^solution" *) #f)
(error "Boom!"))
(log-line "Status file-get: ~s ~a" who file)
(hook 'status-file-get `([username ,(string->symbol who)] [file ,file]))
;; Return the downloaded file
(let* ([data (with-input-from-file file
(lambda () (read-bytes (file-size file))))]
@ -204,6 +206,7 @@
(define (status-page user for-handin)
(log-line "Status access: ~s" user)
(hook 'status-login `([username ,(string->symbol user)]))
(if for-handin
(one-status-page user for-handin)
(all-status-page user)))

4
collects/handin-server/web-status-server.ss
View File

@ -63,7 +63,9 @@
#:to-be-copied-module-specs
'((lib "md5.ss" "handin-server" "private")
(lib "logger.ss" "handin-server" "private")
(lib "config.ss" "handin-server" "private")))))
(lib "config.ss" "handin-server" "private")
(lib "hooker.ss" "handin-server" "private")
(lib "reloadable.ss" "handin-server" "private")))))
(define-unit-binding config@ configuration (import) (export web-config^))
(define-unit-binding ssl-tcp@