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

more v4-isms

Browse Source 
svn: r11683
This commit is contained in:
Eli Barzilay 2008-09-12 15:30:38 +00:00
parent 78632e178d
commit 0c0630d50d
3 changed files with 177 additions and 177 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,111 +1,110 @@
(module config mzscheme #lang scheme/base
(require mzlib/file mzlib/list)
;; This module should be invoked when we're in the server directory (require scheme/file)
(provide server-dir)
(define server-dir (or (getenv "PLT_HANDINSERVER_DIR") (current-directory)))
(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 poll-freq 2000.0) ; poll at most once every two seconds
(define last-filetime #f)
(define raw-config #f)
(define config-cache #f)
(provide get-conf) (define last-poll #f)
(define (get-conf key) (define last-filetime #f)
(unless (and raw-config (define raw-config #f)
(< (- (current-inexact-milliseconds) last-poll) poll-freq)) (define config-cache #f)
(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 (id x) x) (provide get-conf)
(define (rx s) (if (regexp? s) s (regexp s))) (define (get-conf key)
(define (path p) (path->complete-path p server-dir)) (unless (and raw-config
(define (path/false p) (and p (path p))) (< (- (current-inexact-milliseconds) last-poll) poll-freq))
(define (path-list l) (map path l)) (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) (define (id x) x)
(case which (define (rx s) (if (regexp? s) s (regexp s)))
[(active-dirs) (values '() path-list )] (define (path p) (path->complete-path p server-dir))
[(inactive-dirs) (values '() path-list )] (define (path/false p) (and p (path p)))
[(port-number) (values 7979 id )] (define (path-list l) (map path l))
[(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)]))
;; This is used below to map names to submission directory paths and back (define (config-default+translate which)
;; returns a (list-of (either (list name path) (list path name))) (case which
(define (paths->map dirs) [(active-dirs) (values '() path-list )]
(define (path->name dir) [(inactive-dirs) (values '() path-list )]
(unless (directory-exists? dir) [(port-number) (values 7979 id )]
(error 'get-conf [(https-port-number) (values #f id )]
"directory entry for an inexistent directory: ~e" dir)) [(hook-file) (values #f path/false )]
(let-values ([(_1 name _2) (split-path dir)]) [(session-timeout) (values 300 id )]
(bytes->string/locale (path-element->bytes name)))) [(session-memory-limit) (values 40000000 id )]
(let ([names (map path->name dirs)]) [(default-file-name) (values "handin.scm" id )]
(append (map list names dirs) (map list dirs names)))) [(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 ;; This is used below to map names to submission directory paths and back
(provide assignment<->dir) ;; returns a (list-of (either (list name path) (list path name)))
(define (assignment<->dir a/d) (define (paths->map dirs)
(cond [(assoc a/d (get-conf 'names-dirs)) => cadr] (define (path->name dir)
[else (error 'assignment<->dir "internal error: ~e" a/d)])) (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)]))

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

@ -1,77 +1,78 @@
(module logger mzscheme #lang scheme/base
(require "config.ss" mzlib/date mzlib/port)
(provide current-session) (require "config.ss" scheme/date scheme/port)
(define current-session (make-parameter #f))
;; A convenient function to print log lines (which really just assembles a (provide current-session)
;; string to print in one shot, and flushes the output) (define current-session (make-parameter #f))
(provide log-line)
(define (log-line fmt . args)
(let ([line (format "~a\n" (apply format fmt args))])
(display line (current-error-port))))
(define (prefix) ;; A convenient function to print log lines (which really just assembles a
(parameterize ([date-display-format 'iso-8601]) ;; string to print in one shot, and flushes the output)
(format "[~a|~a] " (provide log-line)
(or (current-session) '-) (define (log-line fmt . args)
(date->string (seconds->date (current-seconds)) #t)))) (let ([line (format "~a\n" (apply format fmt args))])
(display line (current-error-port))))
(define (combine-outputs o1 o2) (define (prefix)
(let-values ([(i o) (make-pipe)]) (parameterize ([date-display-format 'iso-8601])
(thread (format "[~a|~a] "
(lambda () (or (current-session) '-)
(let loop () (date->string (seconds->date (current-seconds)) #t))))
(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))
;; Implement a logger by making the current-error-port show prefix tags and (define (combine-outputs o1 o2)
;; output the line on the output port (let-values ([(i o) (make-pipe)])
(define (make-logger-port out log) (thread
(if (and (not out) (not log)) (lambda ()
;; /dev/null-like output port (let loop ()
(make-output-port 'nowhere (let ([line (read-bytes-line i)])
always-evt (if (eof-object? line)
(lambda (buf start end imm? break?) (- end start)) (begin (close-output-port o1) (close-output-port o2))
void) (begin (write-bytes line o1) (newline o1) (flush-output o1)
(let ([prompt? #t] (write-bytes line o2) (newline o2) (flush-output o2)
[sema (make-semaphore 1)] (loop)))))))
[outp (cond [(not log) out] o))
[(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 ;; Implement a logger by making the current-error-port show prefix tags and
(provide install-logger-port) ;; output the line on the output port
(define (install-logger-port) (define (make-logger-port out log)
(current-error-port (if (and (not out) (not log))
(make-logger-port ;; /dev/null-like output port
(and (get-conf 'log-output) (current-output-port)) (make-output-port 'nowhere
(cond [(get-conf 'log-file) => (lambda (f) (open-output-file f 'append))] always-evt
[else #f]))))) (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]))))

10
collects/handin-server/private/md5.ss
View File

@ -1,5 +1,5 @@
(module md5 mzscheme #lang scheme/base
(require (prefix mz: mzlib/md5)) (require (prefix-in mz: file/md5))
(define (md5 s) (define (md5 s)
(bytes->string/latin-1 (mz:md5 (string->bytes/utf-8 s)))) (bytes->string/latin-1 (mz:md5 (string->bytes/utf-8 s))))
(provide md5)) (provide md5)