From 8af562f7a118e56a17da306dd91d9beaf4d44f8e Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 10 Jan 2007 18:16:51 +0000 Subject: [PATCH] use configuration keys dynamically svn: r5303 --- collects/handin-server/doc.txt | 24 ++++- collects/handin-server/extra-utils.ss | 5 +- collects/handin-server/handin-server.ss | 87 ++++++++----------- collects/handin-server/private/config.ss | 56 +++++++----- collects/handin-server/private/logger.ss | 5 +- .../status-web-root/servlets/status.ss | 4 +- collects/handin-server/utils.ss | 5 +- collects/handin-server/web-status-server.ss | 4 +- 8 files changed, 100 insertions(+), 90 deletions(-) diff --git a/collects/handin-server/doc.txt b/collects/handin-server/doc.txt index 9f726fbf4c..d6ba5bdf4e 100644 --- a/collects/handin-server/doc.txt +++ b/collects/handin-server/doc.txt @@ -169,7 +169,7 @@ sub-directories: (( ) ...) - for the following keys: + The following keys can be used (without the preceding quote): 'port-number : the port for the main handin server; the default is 7979 @@ -214,9 +214,9 @@ sub-directories: for no description; the default is "alphanumeric string" which matches the default user-regexp - 'username-case-sensitive? : a boolean; when #f, usernames - are case-folded for all purposes; defaults to #f (note that - you should not set this to #t on Windows or when using other + 'username-case-sensitive : a boolean; when #f, usernames are + case-folded for all purposes; defaults to #f (note that you + should not set this to #t on Windows or when using other case-insensitive filesystems, since usernames are used as directory names) @@ -289,6 +289,18 @@ sub-directories: information. (The third element for such descriptors is ignored.) + 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 + configured at startup. All other options will change the behavior + of the running server (but things like `username-case-sensitive?' + it would be unwise to do so). (For safety, options are not + reloaded until the file parses correctly, but make sure that you + don't save a copy that has inconsistent options: it is best to + create a new configuration file and move it over the old one, or + use an editor that does so and not save until the new contents is + ready.) + * "users.ss" (created if not present if a user is added) --- keeps the list of user accounts, along with the associated password (actually the MD5 hash of the password), and extra string fields @@ -538,6 +550,10 @@ Checker Utilities The _utils.ss_ module provides utilities helpful in implementing `checker' functions: +> (get-conf key) + Returns a value from the configuration file (useful for reading + things like field names etc) + > (unpack-submission bytes) Returns two text% objects corresponding to the submitted definitions and interactions windows. diff --git a/collects/handin-server/extra-utils.ss b/collects/handin-server/extra-utils.ss index dd75af629b..bb32e0226f 100644 --- a/collects/handin-server/extra-utils.ss +++ b/collects/handin-server/extra-utils.ss @@ -26,10 +26,7 @@ (define (error* fmt . args) (error (apply format fmt args))) -(define fields - (map car (or (get-preference 'extra-fields (lambda () #f) #f - (build-path server-dir "config.ss")) - (error* "bad configuration file: missing extra-fields entry")))) +(define fields (map car (get-conf 'extra-fields))) (provide submission-dir) (define submission-dir-re diff --git a/collects/handin-server/handin-server.ss b/collects/handin-server/handin-server.ss index 30e674c16a..ca5155afc2 100644 --- a/collects/handin-server/handin-server.ss +++ b/collects/handin-server/handin-server.ss @@ -29,24 +29,6 @@ [(pair? default) (car default)] [else (error (alist-name alist) "no value for `~s'" key)])) - (define PORT-NUMBER (get-config 'port-number)) - (define HTTPS-PORT-NUMBER (get-config 'https-port-number)) - (define SESSION-TIMEOUT (get-config 'session-timeout)) - (define SESSION-MEMORY-LIMIT (get-config 'session-memory-limit)) - (define DEFAULT-FILE-NAME (get-config 'default-file-name)) - (define MAX-UPLOAD (get-config 'max-upload)) - (define MAX-UPLOAD-KEEP (get-config 'max-upload-keep)) - (define USER-REGEXP (get-config 'user-regexp)) - (define USER-DESC (get-config 'user-desc)) - (define USERNAME-CASE-SENSITIVE? (get-config 'username-case-sensitive?)) - (define ALLOW-NEW-USERS? (get-config 'allow-new-users)) - (define ALLOW-CHANGE-INFO? (get-config 'allow-change-info)) - (define MASTER-PASSWD (get-config 'master-password)) - (define EXTRA-FIELDS (get-config 'extra-fields)) - ;; separate user-controlled fields, and hidden fields - (define USER-FIELDS - (filter (lambda (f) (not (eq? '- (cadr f)))) EXTRA-FIELDS)) - (define orig-custodian (current-custodian)) ;; On startup, check that the users file is not locked: @@ -69,10 +51,9 @@ (define (make-success-dir-available n) (let ([name (success-dir n)]) (when (directory-exists? name) - (if (< n MAX-UPLOAD-KEEP) - (begin - (make-success-dir-available (add1 n)) - (rename-file-or-directory name (success-dir (add1 n)))) + (if (< n (get-conf 'max-upload-keep)) + (begin (make-success-dir-available (add1 n)) + (rename-file-or-directory name (success-dir (add1 n)))) (delete-directory/files name))))) (define ATTEMPT-RE (regexp (format "^~a$" ATTEMPT-DIR))) @@ -189,10 +170,10 @@ (set! len (read r-safe)) (unless (and (number? len) (integer? len) (positive? len)) (error 'handin "bad length: ~s" len)) - (unless (len . < . MAX-UPLOAD) + (unless (len . < . (get-conf 'max-upload)) (error 'handin "max handin file size is ~s bytes, file to handin is too big (~s bytes)" - MAX-UPLOAD len)) + (get-conf 'max-upload) len)) (parameterize ([current-directory (build-path "active" assignment)]) (wait-for-lock dirname (let ([dir (build-path (current-directory) dirname)]) @@ -267,7 +248,7 @@ (let ([part (if checker (parameterize ([current-directory ATTEMPT-DIR]) (checker users s)) - DEFAULT-FILE-NAME)]) + (get-conf 'default-file-name))]) (write+flush w 'confirm) (let ([v (read (make-limited-input-port r 50))]) (if (eq? v 'check) @@ -360,20 +341,22 @@ ;; Utility for the next two functions: reconstruct a full list of ;; extra-fields from user-fields, using "" for hidden fields (define (add-hidden-to-user-fields user-fields) - (let ([user-field-name->user-field (map cons USER-FIELDS user-fields)]) + (let ([user-field-name->user-field + (map cons (get-conf 'user-fields) user-fields)]) (map (lambda (f) (cond [(assq f user-field-name->user-field) => cdr] [else ""])) - EXTRA-FIELDS))) + (get-conf 'extra-fields)))) (define (add-new-user data) (define username (a-ref data 'username/s)) (define passwd (a-ref data 'password)) (define user-fields (a-ref data 'user-fields)) (define extra-fields (add-hidden-to-user-fields user-fields)) - (unless ALLOW-NEW-USERS? + (unless (get-conf 'allow-new-users) (error 'handin "new users not allowed: ~a" username)) - (check-field username USER-REGEXP "username" USER-DESC) + (check-field username (get-conf 'user-regexp) "username" + (get-conf 'user-desc)) ;; Since we're going to use the username in paths, and + to split names: (when (regexp-match #rx"[+/\\:|\"<>]" username) (error 'handin "username must not contain one of the following: + / \\ : | \" < >")) @@ -389,9 +372,9 @@ (error 'handin "the username \"checker.ss\" is reserved")) (when (get-user-data username) (error 'handin "username already exists: `~a'" username)) - (for-each - (lambda (str info) (check-field str (cadr info) (car info) (caddr info))) - extra-fields EXTRA-FIELDS) + (for-each (lambda (str info) + (check-field str (cadr info) (car info) (caddr info))) + extra-fields (get-conf 'extra-fields)) (wait-for-lock "+newuser+") (log-line "create user: ~a" username) (put-user-data username (cons passwd extra-fields))) @@ -409,13 +392,14 @@ ;; hidden fields) (let ([new-data (map (lambda (old new) (if (equal? "" new) old new)) (car user-datas) (cons passwd extra-fields))]) - (unless (or ALLOW-CHANGE-INFO? (equal? (cdr new-data) (cdar user-datas))) + (unless (or (get-conf 'allow-change-info) + (equal? (cdr new-data) (cdar user-datas))) (error 'handin "changing information not allowed: ~a" (car usernames))) (when (equal? new-data (car user-datas)) (error 'handin "no fields changed: ~a" (car usernames))) - (for-each - (lambda (str info) (check-field str (cadr info) (car info) (caddr info))) - (cdr new-data) EXTRA-FIELDS) + (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))) @@ -426,8 +410,9 @@ (error 'handin "cannot get user-info for multiple users: ~a" usernames)) ;; filter out hidden fields (let ([all-data (cdar (a-ref data 'user-datas))]) - (filter values (map (lambda (d f) (and (memq f USER-FIELDS) d)) - all-data EXTRA-FIELDS)))) + (filter values (map (lambda (d f) + (and (memq f (get-conf 'user-fields)) d)) + all-data (get-conf 'extra-fields))))) (define crypt (let ([c #f] [sema (make-semaphore 1)]) @@ -475,14 +460,14 @@ (unless (symbol? key) (perror "bad key value: ~e" key)) (unless (if (eq? 'user-fields key) (and (list? val) - (- (length val) (length USER-FIELDS)) + (- (length val) (length (get-conf 'user-fields))) (andmap string? val)) (string? val)) (perror "bad value for set: ~e" val)) (when (a-ref data key #f) (perror "multiple values for ~e" key)) (case key [(username/s) - (unless USERNAME-CASE-SENSITIVE? + (unless (get-conf 'username-case-sensitive) (set! val (string-foldcase val))) (let ([usernames ;; Username lists must always be sorted, and never empty @@ -506,7 +491,7 @@ (write+flush w active-assignments) (loop)] [(get-user-fields) - (write+flush w (map car USER-FIELDS)) + (write+flush w (map car (get-conf 'user-fields))) (loop)] ;; ---------------------------------------- ;; action handlers @@ -525,7 +510,8 @@ (not (has-password? (a-ref data 'raw-password) (a-ref data 'password) - (cons MASTER-PASSWD (map car user-datas))))) + (cons (get-conf 'master-password) + (map car user-datas))))) (log-line "failed login: ~a" (a-ref data 'username/s)) (error 'handin "bad username or password for ~a" (a-ref data 'username/s))) @@ -560,7 +546,7 @@ (if (rational? msg) (set! timeout (+ (current-inexact-milliseconds) (* 1000 msg))) (case msg - [(reset) (timeout-control SESSION-TIMEOUT)] + [(reset) (timeout-control (get-conf 'session-timeout))] [(disable) (set! timeout #f)] [else (error 'timeout-control "bad argument: ~s" msg)]))) (current-timeout-control timeout-control) @@ -570,7 +556,9 @@ (lambda (x) (set! no-limit-warning? #t) (log-line "WARNING: per-session memory limit not supported by MrEd"))]) - (custodian-limit-memory session-cust SESSION-MEMORY-LIMIT session-cust))) + (custodian-limit-memory session-cust + (get-conf 'session-memory-limit) + session-cust))) (let* ([watcher (parameterize ([current-custodian orig-custodian]) (thread @@ -596,7 +584,8 @@ (and t ((current-inexact-milliseconds) . > . t))) ;; Shutdown here to get the handin-terminated error ;; message, instead of relying on - ;; SESSION-TIMEOUT at the run-server level + ;; (get-conf 'session-timeout) + ;; at the run-server level (custodian-shutdown-all session-cust) (loop #t)] [else @@ -628,16 +617,16 @@ (log-line "server started ------------------------------") - (define stop-status (serve-status HTTPS-PORT-NUMBER)) + (define stop-status (serve-status (get-conf 'https-port-number))) (define session-count 0) (parameterize ([error-display-handler (lambda (msg exn) (log-line msg))]) (run-server - PORT-NUMBER + (get-conf 'port-number) (lambda (r w) (set! connection-num (add1 connection-num)) - (when ((current-memory-use) . > . SESSION-MEMORY-LIMIT) + (when ((current-memory-use) . > . (get-conf 'session-memory-limit)) (collect-garbage)) (parameterize ([current-session (begin (set! session-count (add1 session-count)) @@ -668,7 +657,7 @@ (log-line "normal exit") (kill-watcher) ;; This close-output-port should not be necessary, and it's - ;; here due to a deficiency in the SLL binding. The problem is + ;; here due to a deficiency in the SSL binding. The problem is ;; that a custodian shutdown of w is harsher for SSL output ;; than a normal close. A normal close flushes an internal ;; buffer that's not supposed to exist, while the shutdown diff --git a/collects/handin-server/private/config.ss b/collects/handin-server/private/config.ss index 4e5ba29cd7..ef37b51c62 100644 --- a/collects/handin-server/private/config.ss +++ b/collects/handin-server/private/config.ss @@ -1,5 +1,5 @@ (module config mzscheme - (require (lib "file.ss")) + (require (lib "file.ss") (lib "list.ss")) ;; This module should be invoked when we're in the server directory (provide server-dir) @@ -14,8 +14,8 @@ (define raw-config #f) (define config-cache #f) - (provide get-config) - (define (get-config key) + (provide get-conf) + (define (get-conf key) (unless (and raw-config (< (- (current-inexact-milliseconds) last-poll) poll-freq)) (set! last-poll (current-inexact-milliseconds)) @@ -25,7 +25,7 @@ (set! last-filetime filetime) (set! raw-config (with-handlers ([void (lambda (_) - (error 'get-config + (error 'get-conf "could not read conf (~a)" config-file))]) (printf "reading...\n") @@ -34,8 +34,11 @@ (hash-table-get config-cache key (lambda () (let*-values ([(default translate) (config-default+translate key)] - [(v) (translate (cond [(assq key raw-config) => cadr] - [else default]))]) + ;; translate = #f => this is a computed value + [(v) (if translate + (translate (cond [(assq key raw-config) => cadr] + [else default])) + default)]) (hash-table-put! config-cache key v) v)))) @@ -46,29 +49,34 @@ (define (config-default+translate which) (case which - [(port-number) (values 7979 id )] - [(https-port-number) (values (add1 (get-config 'port-number)) id)] - [(session-timeout) (values 300 id )] - [(session-memory-limit) (values 40000000 id )] - [(default-file-name) (values "handin.scm" id )] - [(max-upload) (values 500000 id )] - [(max-upload-keep) (values 9 id )] - [(user-regexp) (values #rx"^[a-z][a-z0-9]+$" rx )] - [(user-desc) (values "alphanumeric string" id )] - [(username-case-sensitive?) (values #f id )] - [(allow-new-users) (values #f id )] - [(allow-change-info) (values #f id )] - [(master-password) (values #f id )] - [(web-base-dir) (values #f path/false )] - [(log-output) (values #t id )] - [(log-file) (values "log" path/false )] - [(web-log-file) (values #f path/false )] + [(port-number) (values 7979 id )] + [(https-port-number) (values (add1 (get-conf 'port-number)) id )] + [(session-timeout) (values 300 id )] + [(session-memory-limit) (values 40000000 id )] + [(default-file-name) (values "handin.scm" id )] + [(max-upload) (values 500000 id )] + [(max-upload-keep) (values 9 id )] + [(user-regexp) (values #rx"^[a-z][a-z0-9]+$" rx )] + [(user-desc) (values "alphanumeric string" id )] + [(username-case-sensitive) (values #f id )] + [(allow-new-users) (values #f id )] + [(allow-change-info) (values #f id )] + [(master-password) (values #f id )] + [(web-base-dir) (values #f path/false )] + [(log-output) (values #t id )] + [(log-file) (values "log" path/false )] + [(web-log-file) (values #f path/false )] [(extra-fields) (values '(("Full Name" #f #f) ("ID#" #f #f) ("Email" #rx"^[^@<>\"`',]+@[a-zA-Z0-9_.-]+[.][a-zA-Z]+$" "a valid email address")) id)] - [else (error 'get-config "unknown configuration entry: ~s" which)])) + ;; computed from the above (mark by translate = #f) + [(user-fields) + (values (filter (lambda (f) (not (eq? '- (cadr f)))) + (get-conf 'extra-fields)) + #f)] + [else (error 'get-conf "unknown configuration entry: ~s" which)])) ) diff --git a/collects/handin-server/private/logger.ss b/collects/handin-server/private/logger.ss index 2e26983bcd..3ca5c4ac1e 100644 --- a/collects/handin-server/private/logger.ss +++ b/collects/handin-server/private/logger.ss @@ -72,7 +72,6 @@ (define (install-logger-port) (current-error-port (make-logger-port - (and (get-config 'log-output) (current-output-port)) - (cond [(get-config 'log-file) - => (lambda (f) (open-output-file f 'append))] + (and (get-conf 'log-output) (current-output-port)) + (cond [(get-conf 'log-file) => (lambda (f) (open-output-file f 'append))] [else #f]))))) diff --git a/collects/handin-server/status-web-root/servlets/status.ss b/collects/handin-server/status-web-root/servlets/status.ss index 0dc1270701..163ad529d8 100644 --- a/collects/handin-server/status-web-root/servlets/status.ss +++ b/collects/handin-server/status-web-root/servlets/status.ss @@ -14,8 +14,6 @@ (define inactive-dir (build-path server-dir "inactive")) (define active/inactive-dirs (list active-dir inactive-dir)) - (define master-password (get-config 'master-password)) - (define get-user-data (let ([users-file (build-path server-dir "users.ss")]) (lambda (user) @@ -251,7 +249,7 @@ (string? passwd) (let ([pw (md5 passwd)]) (or (equal? pw (car user-data)) - (equal? pw master-password)))) + (equal? pw (get-conf 'master-password))))) (status-page user for-handin)] [else (login-page status for-handin "Bad username or password")]))) diff --git a/collects/handin-server/utils.ss b/collects/handin-server/utils.ss index dc995bcf17..0cda4f9353 100644 --- a/collects/handin-server/utils.ss +++ b/collects/handin-server/utils.ss @@ -3,13 +3,16 @@ (lib "mred.ss" "mred") (lib "posn.ss" "lang") "private/run-status.ss" + "private/config.ss" (prefix pc: (lib "pconvert.ss")) (lib "pretty.ss") (lib "list.ss") (lib "string.ss") (only "handin-server.ss" timeout-control)) - (provide unpack-submission + (provide get-conf + + unpack-submission make-evaluator make-evaluator/submission diff --git a/collects/handin-server/web-status-server.ss b/collects/handin-server/web-status-server.ss index 4fc14b29b3..6c2c8ab127 100644 --- a/collects/handin-server/web-status-server.ss +++ b/collects/handin-server/web-status-server.ss @@ -16,7 +16,7 @@ (define web-dir (path->string - (or (get-config 'web-base-dir) + (or (get-conf 'web-base-dir) (build-path (this-expression-source-directory) "status-web-root")))) (define config @@ -44,7 +44,7 @@ (paths (configuration-root "conf") (host-root ,web-dir) - (log-file-path ,(cond [(get-config 'web-log-file) => path->string] + (log-file-path ,(cond [(get-conf 'web-log-file) => path->string] [else #f])) (file-root "htdocs") (servlet-root ,web-dir)