use configuration keys dynamically
svn: r5303
This commit is contained in:
Eli Barzilay
parent
9e78a08d6e
commit
8af562f7a1
|
|
@ -169,7 +169,7 @@ sub-directories:
|
|||
|
||||
((<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
|
||||
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.
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)]))
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -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])))))
|
||||
|
|
|
|||
|
|
@ -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")])))
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user