more v4-isms
svn: r11683
This commit is contained in:
Eli Barzilay
parent
78632e178d
commit
0c0630d50d
|
|
@ -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)]))
|
||||
|
|
|
|||
|
|
@ -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]))))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user