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

use configuration keys dynamically

Browse Source 
svn: r5303
This commit is contained in:
Eli Barzilay 2007-01-10 18:16:51 +00:00
parent 9e78a08d6e
commit 8af562f7a1
8 changed files with 100 additions and 90 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -169,7 +169,7 @@ sub-directories:
((<key> <val>) ...) ((<key> <val>) ...)
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 'port-number : the port for the main handin server; the default
is 7979 is 7979
@ -214,9 +214,9 @@ sub-directories:
for no description; the default is "alphanumeric string" for no description; the default is "alphanumeric string"
which matches the default user-regexp which matches the default user-regexp
'username-case-sensitive? : a boolean; when #f, usernames 'username-case-sensitive : a boolean; when #f, usernames are
are case-folded for all purposes; defaults to #f (note that case-folded for all purposes; defaults to #f (note that you
you should not set this to #t on Windows or when using other should not set this to #t on Windows or when using other
case-insensitive filesystems, since usernames are used as case-insensitive filesystems, since usernames are used as
directory names) directory names)
@ -289,6 +289,18 @@ sub-directories:
information. (The third element for such descriptors is information. (The third element for such descriptors is
ignored.) 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 * "users.ss" (created if not present if a user is added) --- keeps
the list of user accounts, along with the associated password the list of user accounts, along with the associated password
(actually the MD5 hash of the password), and extra string fields (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 The _utils.ss_ module provides utilities helpful in implementing
`checker' functions: `checker' functions:
> (get-conf key)
Returns a value from the configuration file (useful for reading
things like field names etc)
> (unpack-submission bytes) > (unpack-submission bytes)
Returns two text% objects corresponding to the submitted definitions Returns two text% objects corresponding to the submitted definitions
and interactions windows. and interactions windows.

5
collects/handin-server/extra-utils.ss
View File

@ -26,10 +26,7 @@
(define (error* fmt . args) (define (error* fmt . args)
(error (apply format fmt args))) (error (apply format fmt args)))
(define fields (define fields (map car (get-conf 'extra-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"))))
(provide submission-dir) (provide submission-dir)
(define submission-dir-re (define submission-dir-re

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

@ -29,24 +29,6 @@
[(pair? default) (car default)] [(pair? default) (car default)]
[else (error (alist-name alist) "no value for `~s'" key)])) [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)) (define orig-custodian (current-custodian))
;; On startup, check that the users file is not locked: ;; On startup, check that the users file is not locked:
@ -69,10 +51,9 @@
(define (make-success-dir-available n) (define (make-success-dir-available n)
(let ([name (success-dir n)]) (let ([name (success-dir n)])
(when (directory-exists? name) (when (directory-exists? name)
(if (< n MAX-UPLOAD-KEEP) (if (< n (get-conf 'max-upload-keep))
(begin (begin (make-success-dir-available (add1 n))
(make-success-dir-available (add1 n)) (rename-file-or-directory name (success-dir (add1 n))))
(rename-file-or-directory name (success-dir (add1 n))))
(delete-directory/files name))))) (delete-directory/files name)))))
(define ATTEMPT-RE (regexp (format "^~a$" ATTEMPT-DIR))) (define ATTEMPT-RE (regexp (format "^~a$" ATTEMPT-DIR)))
@ -189,10 +170,10 @@
(set! len (read r-safe)) (set! len (read r-safe))
(unless (and (number? len) (integer? len) (positive? len)) (unless (and (number? len) (integer? len) (positive? len))
(error 'handin "bad length: ~s" len)) (error 'handin "bad length: ~s" len))
(unless (len . < . MAX-UPLOAD) (unless (len . < . (get-conf 'max-upload))
(error 'handin (error 'handin
"max handin file size is ~s bytes, file to handin is too big (~s bytes)" "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)]) (parameterize ([current-directory (build-path "active" assignment)])
(wait-for-lock dirname (wait-for-lock dirname
(let ([dir (build-path (current-directory) dirname)]) (let ([dir (build-path (current-directory) dirname)])
@ -267,7 +248,7 @@
(let ([part (if checker (let ([part (if checker
(parameterize ([current-directory ATTEMPT-DIR]) (parameterize ([current-directory ATTEMPT-DIR])
(checker users s)) (checker users s))
DEFAULT-FILE-NAME)]) (get-conf 'default-file-name))])
(write+flush w 'confirm) (write+flush w 'confirm)
(let ([v (read (make-limited-input-port r 50))]) (let ([v (read (make-limited-input-port r 50))])
(if (eq? v 'check) (if (eq? v 'check)
@ -360,20 +341,22 @@
;; Utility for the next two functions: reconstruct a full list of ;; Utility for the next two functions: reconstruct a full list of
;; extra-fields from user-fields, using "" for hidden fields ;; extra-fields from user-fields, using "" for hidden fields
(define (add-hidden-to-user-fields user-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) (map (lambda (f)
(cond [(assq f user-field-name->user-field) => cdr] (cond [(assq f user-field-name->user-field) => cdr]
[else ""])) [else ""]))
EXTRA-FIELDS))) (get-conf 'extra-fields))))
(define (add-new-user data) (define (add-new-user data)
(define username (a-ref data 'username/s)) (define username (a-ref data 'username/s))
(define passwd (a-ref data 'password)) (define passwd (a-ref data 'password))
(define user-fields (a-ref data 'user-fields)) (define user-fields (a-ref data 'user-fields))
(define extra-fields (add-hidden-to-user-fields 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)) (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: ;; Since we're going to use the username in paths, and + to split names:
(when (regexp-match #rx"[+/\\:|\"<>]" username) (when (regexp-match #rx"[+/\\:|\"<>]" username)
(error 'handin "username must not contain one of the following: + / \\ : | \" < >")) (error 'handin "username must not contain one of the following: + / \\ : | \" < >"))
@ -389,9 +372,9 @@
(error 'handin "the username \"checker.ss\" is reserved")) (error 'handin "the username \"checker.ss\" is reserved"))
(when (get-user-data username) (when (get-user-data username)
(error 'handin "username already exists: `~a'" username)) (error 'handin "username already exists: `~a'" username))
(for-each (for-each (lambda (str info)
(lambda (str info) (check-field str (cadr info) (car info) (caddr info))) (check-field str (cadr info) (car info) (caddr info)))
extra-fields EXTRA-FIELDS) extra-fields (get-conf 'extra-fields))
(wait-for-lock "+newuser+") (wait-for-lock "+newuser+")
(log-line "create user: ~a" username) (log-line "create user: ~a" username)
(put-user-data username (cons passwd extra-fields))) (put-user-data username (cons passwd extra-fields)))
@ -409,13 +392,14 @@
;; hidden fields) ;; hidden fields)
(let ([new-data (map (lambda (old new) (if (equal? "" new) old new)) (let ([new-data (map (lambda (old new) (if (equal? "" new) old new))
(car user-datas) (cons passwd extra-fields))]) (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))) (error 'handin "changing information not allowed: ~a" (car usernames)))
(when (equal? new-data (car user-datas)) (when (equal? new-data (car user-datas))
(error 'handin "no fields changed: ~a" (car usernames))) (error 'handin "no fields changed: ~a" (car usernames)))
(for-each (for-each (lambda (str info)
(lambda (str info) (check-field str (cadr info) (car info) (caddr info))) (check-field str (cadr info) (car info) (caddr info)))
(cdr new-data) EXTRA-FIELDS) (cdr new-data) (get-conf 'extra-fields))
(log-line "change info for ~a ~s -> ~s" (log-line "change info for ~a ~s -> ~s"
(car usernames) (car user-datas) new-data) (car usernames) (car user-datas) new-data)
(put-user-data (car usernames) new-data))) (put-user-data (car usernames) new-data)))
@ -426,8 +410,9 @@
(error 'handin "cannot get user-info for multiple users: ~a" usernames)) (error 'handin "cannot get user-info for multiple users: ~a" usernames))
;; filter out hidden fields ;; filter out hidden fields
(let ([all-data (cdar (a-ref data 'user-datas))]) (let ([all-data (cdar (a-ref data 'user-datas))])
(filter values (map (lambda (d f) (and (memq f USER-FIELDS) d)) (filter values (map (lambda (d f)
all-data EXTRA-FIELDS)))) (and (memq f (get-conf 'user-fields)) d))
all-data (get-conf 'extra-fields)))))
(define crypt (define crypt
(let ([c #f] [sema (make-semaphore 1)]) (let ([c #f] [sema (make-semaphore 1)])
@ -475,14 +460,14 @@
(unless (symbol? key) (perror "bad key value: ~e" key)) (unless (symbol? key) (perror "bad key value: ~e" key))
(unless (if (eq? 'user-fields key) (unless (if (eq? 'user-fields key)
(and (list? val) (and (list? val)
(- (length val) (length USER-FIELDS)) (- (length val) (length (get-conf 'user-fields)))
(andmap string? val)) (andmap string? val))
(string? val)) (string? val))
(perror "bad value for set: ~e" val)) (perror "bad value for set: ~e" val))
(when (a-ref data key #f) (perror "multiple values for ~e" key)) (when (a-ref data key #f) (perror "multiple values for ~e" key))
(case key (case key
[(username/s) [(username/s)
(unless USERNAME-CASE-SENSITIVE? (unless (get-conf 'username-case-sensitive)
(set! val (string-foldcase val))) (set! val (string-foldcase val)))
(let ([usernames (let ([usernames
;; Username lists must always be sorted, and never empty ;; Username lists must always be sorted, and never empty
@ -506,7 +491,7 @@
(write+flush w active-assignments) (write+flush w active-assignments)
(loop)] (loop)]
[(get-user-fields) [(get-user-fields)
(write+flush w (map car USER-FIELDS)) (write+flush w (map car (get-conf 'user-fields)))
(loop)] (loop)]
;; ---------------------------------------- ;; ----------------------------------------
;; action handlers ;; action handlers
@ -525,7 +510,8 @@
(not (has-password? (not (has-password?
(a-ref data 'raw-password) (a-ref data 'raw-password)
(a-ref data '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)) (log-line "failed login: ~a" (a-ref data 'username/s))
(error 'handin "bad username or password for ~a" (error 'handin "bad username or password for ~a"
(a-ref data 'username/s))) (a-ref data 'username/s)))
@ -560,7 +546,7 @@
(if (rational? msg) (if (rational? msg)
(set! timeout (+ (current-inexact-milliseconds) (* 1000 msg))) (set! timeout (+ (current-inexact-milliseconds) (* 1000 msg)))
(case msg (case msg
[(reset) (timeout-control SESSION-TIMEOUT)] [(reset) (timeout-control (get-conf 'session-timeout))]
[(disable) (set! timeout #f)] [(disable) (set! timeout #f)]
[else (error 'timeout-control "bad argument: ~s" msg)]))) [else (error 'timeout-control "bad argument: ~s" msg)])))
(current-timeout-control timeout-control) (current-timeout-control timeout-control)
@ -570,7 +556,9 @@
(lambda (x) (lambda (x)
(set! no-limit-warning? #t) (set! no-limit-warning? #t)
(log-line "WARNING: per-session memory limit not supported by MrEd"))]) (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 (let* ([watcher
(parameterize ([current-custodian orig-custodian]) (parameterize ([current-custodian orig-custodian])
(thread (thread
@ -596,7 +584,8 @@
(and t ((current-inexact-milliseconds) . > . t))) (and t ((current-inexact-milliseconds) . > . t)))
;; Shutdown here to get the handin-terminated error ;; Shutdown here to get the handin-terminated error
;; message, instead of relying on ;; 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) (custodian-shutdown-all session-cust)
(loop #t)] (loop #t)]
[else [else
@ -628,16 +617,16 @@
(log-line "server started ------------------------------") (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) (define session-count 0)
(parameterize ([error-display-handler (lambda (msg exn) (log-line msg))]) (parameterize ([error-display-handler (lambda (msg exn) (log-line msg))])
(run-server (run-server
PORT-NUMBER (get-conf 'port-number)
(lambda (r w) (lambda (r w)
(set! connection-num (add1 connection-num)) (set! connection-num (add1 connection-num))
(when ((current-memory-use) . > . SESSION-MEMORY-LIMIT) (when ((current-memory-use) . > . (get-conf 'session-memory-limit))
(collect-garbage)) (collect-garbage))
(parameterize ([current-session (parameterize ([current-session
(begin (set! session-count (add1 session-count)) (begin (set! session-count (add1 session-count))
@ -668,7 +657,7 @@
(log-line "normal exit") (log-line "normal exit")
(kill-watcher) (kill-watcher)
;; This close-output-port should not be necessary, and it's ;; 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 ;; that a custodian shutdown of w is harsher for SSL output
;; than a normal close. A normal close flushes an internal ;; than a normal close. A normal close flushes an internal
;; buffer that's not supposed to exist, while the shutdown ;; buffer that's not supposed to exist, while the shutdown

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

@ -1,5 +1,5 @@
(module config mzscheme (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 ;; This module should be invoked when we're in the server directory
(provide server-dir) (provide server-dir)
@ -14,8 +14,8 @@
(define raw-config #f) (define raw-config #f)
(define config-cache #f) (define config-cache #f)
(provide get-config) (provide get-conf)
(define (get-config key) (define (get-conf key)
(unless (and raw-config (unless (and raw-config
(< (- (current-inexact-milliseconds) last-poll) poll-freq)) (< (- (current-inexact-milliseconds) last-poll) poll-freq))
(set! last-poll (current-inexact-milliseconds)) (set! last-poll (current-inexact-milliseconds))
@ -25,7 +25,7 @@
(set! last-filetime filetime) (set! last-filetime filetime)
(set! raw-config (set! raw-config
(with-handlers ([void (lambda (_) (with-handlers ([void (lambda (_)
(error 'get-config (error 'get-conf
"could not read conf (~a)" "could not read conf (~a)"
config-file))]) config-file))])
(printf "reading...\n") (printf "reading...\n")
@ -34,8 +34,11 @@
(hash-table-get config-cache key (hash-table-get config-cache key
(lambda () (lambda ()
(let*-values ([(default translate) (config-default+translate key)] (let*-values ([(default translate) (config-default+translate key)]
[(v) (translate (cond [(assq key raw-config) => cadr] ;; translate = #f => this is a computed value
[else default]))]) [(v) (if translate
(translate (cond [(assq key raw-config) => cadr]
[else default]))
default)])
(hash-table-put! config-cache key v) (hash-table-put! config-cache key v)
v)))) v))))
@ -46,29 +49,34 @@
(define (config-default+translate which) (define (config-default+translate which)
(case which (case which
[(port-number) (values 7979 id )] [(port-number) (values 7979 id )]
[(https-port-number) (values (add1 (get-config 'port-number)) id)] [(https-port-number) (values (add1 (get-conf 'port-number)) id )]
[(session-timeout) (values 300 id )] [(session-timeout) (values 300 id )]
[(session-memory-limit) (values 40000000 id )] [(session-memory-limit) (values 40000000 id )]
[(default-file-name) (values "handin.scm" id )] [(default-file-name) (values "handin.scm" id )]
[(max-upload) (values 500000 id )] [(max-upload) (values 500000 id )]
[(max-upload-keep) (values 9 id )] [(max-upload-keep) (values 9 id )]
[(user-regexp) (values #rx"^[a-z][a-z0-9]+$" rx )] [(user-regexp) (values #rx"^[a-z][a-z0-9]+$" rx )]
[(user-desc) (values "alphanumeric string" id )] [(user-desc) (values "alphanumeric string" id )]
[(username-case-sensitive?) (values #f id )] [(username-case-sensitive) (values #f id )]
[(allow-new-users) (values #f id )] [(allow-new-users) (values #f id )]
[(allow-change-info) (values #f id )] [(allow-change-info) (values #f id )]
[(master-password) (values #f id )] [(master-password) (values #f id )]
[(web-base-dir) (values #f path/false )] [(web-base-dir) (values #f path/false )]
[(log-output) (values #t id )] [(log-output) (values #t id )]
[(log-file) (values "log" path/false )] [(log-file) (values "log" path/false )]
[(web-log-file) (values #f path/false )] [(web-log-file) (values #f path/false )]
[(extra-fields) [(extra-fields)
(values '(("Full Name" #f #f) (values '(("Full Name" #f #f)
("ID#" #f #f) ("ID#" #f #f)
("Email" #rx"^[^@<>\"`',]+@[a-zA-Z0-9_.-]+[.][a-zA-Z]+$" ("Email" #rx"^[^@<>\"`',]+@[a-zA-Z0-9_.-]+[.][a-zA-Z]+$"
"a valid email address")) "a valid email address"))
id)] 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)]))
) )

5
collects/handin-server/private/logger.ss
View File

@ -72,7 +72,6 @@
(define (install-logger-port) (define (install-logger-port)
(current-error-port (current-error-port
(make-logger-port (make-logger-port
(and (get-config 'log-output) (current-output-port)) (and (get-conf 'log-output) (current-output-port))
(cond [(get-config 'log-file) (cond [(get-conf 'log-file) => (lambda (f) (open-output-file f 'append))]
=> (lambda (f) (open-output-file f 'append))]
[else #f]))))) [else #f])))))

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

@ -14,8 +14,6 @@
(define inactive-dir (build-path server-dir "inactive")) (define inactive-dir (build-path server-dir "inactive"))
(define active/inactive-dirs (list active-dir inactive-dir)) (define active/inactive-dirs (list active-dir inactive-dir))
(define master-password (get-config 'master-password))
(define get-user-data (define get-user-data
(let ([users-file (build-path server-dir "users.ss")]) (let ([users-file (build-path server-dir "users.ss")])
(lambda (user) (lambda (user)
@ -251,7 +249,7 @@
(string? passwd) (string? passwd)
(let ([pw (md5 passwd)]) (let ([pw (md5 passwd)])
(or (equal? pw (car user-data)) (or (equal? pw (car user-data))
(equal? pw master-password)))) (equal? pw (get-conf 'master-password)))))
(status-page user for-handin)] (status-page user for-handin)]
[else (login-page status for-handin "Bad username or password")]))) [else (login-page status for-handin "Bad username or password")])))

5
collects/handin-server/utils.ss
View File

@ -3,13 +3,16 @@
(lib "mred.ss" "mred") (lib "mred.ss" "mred")
(lib "posn.ss" "lang") (lib "posn.ss" "lang")
"private/run-status.ss" "private/run-status.ss"
"private/config.ss"
(prefix pc: (lib "pconvert.ss")) (prefix pc: (lib "pconvert.ss"))
(lib "pretty.ss") (lib "pretty.ss")
(lib "list.ss") (lib "list.ss")
(lib "string.ss") (lib "string.ss")
(only "handin-server.ss" timeout-control)) (only "handin-server.ss" timeout-control))
(provide unpack-submission (provide get-conf
unpack-submission
make-evaluator make-evaluator
make-evaluator/submission make-evaluator/submission

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

@ -16,7 +16,7 @@
(define web-dir (define web-dir
(path->string (path->string
(or (get-config 'web-base-dir) (or (get-conf 'web-base-dir)
(build-path (this-expression-source-directory) "status-web-root")))) (build-path (this-expression-source-directory) "status-web-root"))))
(define config (define config
@ -44,7 +44,7 @@
(paths (paths
(configuration-root "conf") (configuration-root "conf")
(host-root ,web-dir) (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])) [else #f]))
(file-root "htdocs") (file-root "htdocs")
(servlet-root ,web-dir) (servlet-root ,web-dir)