diff --git a/collects/handin-server/doc.txt b/collects/handin-server/doc.txt index 537a6650a3..641f9a5623 100644 --- a/collects/handin-server/doc.txt +++ b/collects/handin-server/doc.txt @@ -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. * "/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 diff --git a/collects/handin-server/handin-server.ss b/collects/handin-server/handin-server.ss index 3e32bc3b1b..66e8532f73 100644 --- a/collects/handin-server/handin-server.ss +++ b/collects/handin-server/handin-server.ss @@ -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) diff --git a/collects/handin-server/private/config.ss b/collects/handin-server/private/config.ss index 6c42452ce3..84f3f44f37 100644 --- a/collects/handin-server/private/config.ss +++ b/collects/handin-server/private/config.ss @@ -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 )] diff --git a/collects/handin-server/private/hooker.ss b/collects/handin-server/private/hooker.ss new file mode 100644 index 0000000000..ef40587927 --- /dev/null +++ b/collects/handin-server/private/hooker.ss @@ -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)))) + + ) diff --git a/collects/handin-server/private/reloadable.ss b/collects/handin-server/private/reloadable.ss new file mode 100644 index 0000000000..44d76fb1dc --- /dev/null +++ b/collects/handin-server/private/reloadable.ss @@ -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)))) + + ) diff --git a/collects/handin-server/status-web-root/servlets/status.ss b/collects/handin-server/status-web-root/servlets/status.ss index 726ed33fe1..6f17bf06cd 100644 --- a/collects/handin-server/status-web-root/servlets/status.ss +++ b/collects/handin-server/status-web-root/servlets/status.ss @@ -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))) diff --git a/collects/handin-server/web-status-server.ss b/collects/handin-server/web-status-server.ss index 6c2c8ab127..2cb5078715 100644 --- a/collects/handin-server/web-status-server.ss +++ b/collects/handin-server/web-status-server.ss @@ -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@