diff --git a/collects/handin-server/private/config.ss b/collects/handin-server/private/config.ss index e90432ad26..2625ccf4c5 100644 --- a/collects/handin-server/private/config.ss +++ b/collects/handin-server/private/config.ss @@ -1,111 +1,110 @@ -(module config mzscheme - (require mzlib/file mzlib/list) +#lang scheme/base - ;; This module should be invoked when we're in the server directory - (provide server-dir) - (define server-dir (or (getenv "PLT_HANDINSERVER_DIR") (current-directory))) +(require scheme/file) - (define config-file (path->complete-path "config.ss" server-dir)) +;; This module should be invoked when we're in the server directory +(provide server-dir) +(define server-dir (or (getenv "PLT_HANDINSERVER_DIR") (current-directory))) - (define poll-freq 2000.0) ; poll at most once every two seconds +(define config-file (path->complete-path "config.ss" server-dir)) - (define last-poll #f) - (define last-filetime #f) - (define raw-config #f) - (define config-cache #f) +(define poll-freq 2000.0) ; poll at most once every two seconds - (provide get-conf) - (define (get-conf key) - (unless (and raw-config - (< (- (current-inexact-milliseconds) last-poll) poll-freq)) - (set! last-poll (current-inexact-milliseconds)) - (let ([filetime (file-or-directory-modify-seconds config-file)]) - (unless (and filetime (equal? filetime last-filetime)) - (set! last-filetime filetime) - (set! raw-config - (with-handlers ([void (lambda (_) - (error 'get-conf - "could not read conf (~a)" - config-file))]) - (when raw-config - ;; can't use log-line from logger, since it makes a cycle - (fprintf (current-error-port) - (format "loading configuration from ~a\n" - config-file))) - (with-input-from-file config-file read))) - (set! config-cache (make-hash-table))))) - (hash-table-get config-cache key - (lambda () - (let*-values ([(default translate) (config-default+translate key)] - ;; 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)))) +(define last-poll #f) +(define last-filetime #f) +(define raw-config #f) +(define config-cache #f) - (define (id x) x) - (define (rx s) (if (regexp? s) s (regexp s))) - (define (path p) (path->complete-path p server-dir)) - (define (path/false p) (and p (path p))) - (define (path-list l) (map path l)) +(provide get-conf) +(define (get-conf key) + (unless (and raw-config + (< (- (current-inexact-milliseconds) last-poll) poll-freq)) + (set! last-poll (current-inexact-milliseconds)) + (let ([filetime (file-or-directory-modify-seconds config-file)]) + (unless (and filetime (equal? filetime last-filetime)) + (set! last-filetime filetime) + (set! raw-config + (with-handlers ([void (lambda (_) + (error 'get-conf + "could not read conf (~a)" + config-file))]) + (when raw-config + ;; can't use log-line from logger, since it makes a cycle + (fprintf (current-error-port) + (format "loading configuration from ~a\n" + config-file))) + (with-input-from-file config-file read))) + (set! config-cache (make-hasheq))))) + (hash-ref config-cache key + (lambda () + (let*-values ([(default translate) (config-default+translate key)] + ;; translate = #f => this is a computed value + [(v) (if translate + (translate (cond [(assq key raw-config) => cadr] + [else default])) + default)]) + (hash-set! config-cache key v) + v)))) - (define (config-default+translate which) - (case which - [(active-dirs) (values '() path-list )] - [(inactive-dirs) (values '() path-list )] - [(port-number) (values 7979 id )] - [(https-port-number) (values #f 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 )] - [(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)] - ;; computed from the above (mark by translate = #f) - [(all-dirs) - (values (append (get-conf 'active-dirs) (get-conf 'inactive-dirs)) #f)] - [(names-dirs) ; see below - (values (paths->map (get-conf 'all-dirs)) #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)])) +(define (id x) x) +(define (rx s) (if (regexp? s) s (regexp s))) +(define (path p) (path->complete-path p server-dir)) +(define (path/false p) (and p (path p))) +(define (path-list l) (map path l)) - ;; This is used below to map names to submission directory paths and back - ;; returns a (list-of (either (list name path) (list path name))) - (define (paths->map dirs) - (define (path->name dir) - (unless (directory-exists? dir) - (error 'get-conf - "directory entry for an inexistent directory: ~e" dir)) - (let-values ([(_1 name _2) (split-path dir)]) - (bytes->string/locale (path-element->bytes name)))) - (let ([names (map path->name dirs)]) - (append (map list names dirs) (map list dirs names)))) +(define (config-default+translate which) + (case which + [(active-dirs) (values '() path-list )] + [(inactive-dirs) (values '() path-list )] + [(port-number) (values 7979 id )] + [(https-port-number) (values #f 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 )] + [(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)] + ;; computed from the above (mark by translate = #f) + [(all-dirs) + (values (append (get-conf 'active-dirs) (get-conf 'inactive-dirs)) #f)] + [(names-dirs) ; see below + (values (paths->map (get-conf 'all-dirs)) #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)])) - ;; Translates an assignment name to a directory path or back - (provide assignment<->dir) - (define (assignment<->dir a/d) - (cond [(assoc a/d (get-conf 'names-dirs)) => cadr] - [else (error 'assignment<->dir "internal error: ~e" a/d)])) +;; This is used below to map names to submission directory paths and back +;; returns a (list-of (either (list name path) (list path name))) +(define (paths->map dirs) + (define (path->name dir) + (unless (directory-exists? dir) + (error 'get-conf + "directory entry for an inexistent directory: ~e" dir)) + (let-values ([(_1 name _2) (split-path dir)]) + (bytes->string/locale (path-element->bytes name)))) + (let ([names (map path->name dirs)]) + (append (map list names dirs) (map list dirs names)))) - ) +;; Translates an assignment name to a directory path or back +(provide assignment<->dir) +(define (assignment<->dir a/d) + (cond [(assoc a/d (get-conf 'names-dirs)) => cadr] + [else (error 'assignment<->dir "internal error: ~e" a/d)])) diff --git a/collects/handin-server/private/logger.ss b/collects/handin-server/private/logger.ss index 4ef14de3e2..2246c88fb2 100644 --- a/collects/handin-server/private/logger.ss +++ b/collects/handin-server/private/logger.ss @@ -1,77 +1,78 @@ -(module logger mzscheme - (require "config.ss" mzlib/date mzlib/port) +#lang scheme/base - (provide current-session) - (define current-session (make-parameter #f)) +(require "config.ss" scheme/date scheme/port) - ;; A convenient function to print log lines (which really just assembles a - ;; string to print in one shot, and flushes the output) - (provide log-line) - (define (log-line fmt . args) - (let ([line (format "~a\n" (apply format fmt args))]) - (display line (current-error-port)))) +(provide current-session) +(define current-session (make-parameter #f)) - (define (prefix) - (parameterize ([date-display-format 'iso-8601]) - (format "[~a|~a] " - (or (current-session) '-) - (date->string (seconds->date (current-seconds)) #t)))) +;; A convenient function to print log lines (which really just assembles a +;; string to print in one shot, and flushes the output) +(provide log-line) +(define (log-line fmt . args) + (let ([line (format "~a\n" (apply format fmt args))]) + (display line (current-error-port)))) - (define (combine-outputs o1 o2) - (let-values ([(i o) (make-pipe)]) - (thread - (lambda () - (let loop () - (let ([line (read-bytes-line i)]) - (if (eof-object? line) - (begin (close-output-port o1) (close-output-port o2)) - (begin (write-bytes line o1) (newline o1) (flush-output o1) - (write-bytes line o2) (newline o2) (flush-output o2) - (loop))))))) - o)) +(define (prefix) + (parameterize ([date-display-format 'iso-8601]) + (format "[~a|~a] " + (or (current-session) '-) + (date->string (seconds->date (current-seconds)) #t)))) - ;; Implement a logger by making the current-error-port show prefix tags and - ;; output the line on the output port - (define (make-logger-port out log) - (if (and (not out) (not log)) - ;; /dev/null-like output port - (make-output-port 'nowhere - always-evt - (lambda (buf start end imm? break?) (- end start)) - void) - (let ([prompt? #t] - [sema (make-semaphore 1)] - [outp (cond [(not log) out] - [(not out) log] - [else (combine-outputs out log)])]) - (make-output-port - 'logger-output - outp - (lambda (buf start end imm? break?) - (dynamic-wind - (lambda () (semaphore-wait sema)) - (lambda () - (if (= start end) - (begin (flush-output outp) 0) - (let ([nl (regexp-match-positions #rx#"\n" buf start end)]) - ;; may be problematic if this hangs... - (when prompt? (display (prefix) outp) (set! prompt? #f)) - (if (not nl) - (write-bytes-avail* buf outp start end) - (let* ([nl (cdar nl)] - [l (write-bytes-avail* buf outp start nl)]) - (when (= l (- nl start)) - ;; pre-newline part written - (flush-output outp) (set! prompt? #t)) - l))))) - (lambda () (semaphore-post sema)))) - (lambda () (close-output-port outp)))))) +(define (combine-outputs o1 o2) + (let-values ([(i o) (make-pipe)]) + (thread + (lambda () + (let loop () + (let ([line (read-bytes-line i)]) + (if (eof-object? line) + (begin (close-output-port o1) (close-output-port o2)) + (begin (write-bytes line o1) (newline o1) (flush-output o1) + (write-bytes line o2) (newline o2) (flush-output o2) + (loop))))))) + o)) - ;; Install this wrapper as the current error port - (provide install-logger-port) - (define (install-logger-port) - (current-error-port - (make-logger-port - (and (get-conf 'log-output) (current-output-port)) - (cond [(get-conf 'log-file) => (lambda (f) (open-output-file f 'append))] - [else #f]))))) +;; Implement a logger by making the current-error-port show prefix tags and +;; output the line on the output port +(define (make-logger-port out log) + (if (and (not out) (not log)) + ;; /dev/null-like output port + (make-output-port 'nowhere + always-evt + (lambda (buf start end imm? break?) (- end start)) + void) + (let ([prompt? #t] + [sema (make-semaphore 1)] + [outp (cond [(not log) out] + [(not out) log] + [else (combine-outputs out log)])]) + (make-output-port + 'logger-output + outp + (lambda (buf start end imm? break?) + (dynamic-wind + (lambda () (semaphore-wait sema)) + (lambda () + (if (= start end) + (begin (flush-output outp) 0) + (let ([nl (regexp-match-positions #rx#"\n" buf start end)]) + ;; may be problematic if this hangs... + (when prompt? (display (prefix) outp) (set! prompt? #f)) + (if (not nl) + (write-bytes-avail* buf outp start end) + (let* ([nl (cdar nl)] + [l (write-bytes-avail* buf outp start nl)]) + (when (= l (- nl start)) + ;; pre-newline part written + (flush-output outp) (set! prompt? #t)) + l))))) + (lambda () (semaphore-post sema)))) + (lambda () (close-output-port outp)))))) + +;; Install this wrapper as the current error port +(provide install-logger-port) +(define (install-logger-port) + (current-error-port + (make-logger-port + (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/private/md5.ss b/collects/handin-server/private/md5.ss index 3471326533..91fadac41a 100644 --- a/collects/handin-server/private/md5.ss +++ b/collects/handin-server/private/md5.ss @@ -1,5 +1,5 @@ -(module md5 mzscheme - (require (prefix mz: mzlib/md5)) - (define (md5 s) - (bytes->string/latin-1 (mz:md5 (string->bytes/utf-8 s)))) - (provide md5)) +#lang scheme/base +(require (prefix-in mz: file/md5)) +(define (md5 s) + (bytes->string/latin-1 (mz:md5 (string->bytes/utf-8 s)))) +(provide md5)