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

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

@ -1,21 +1,22 @@
(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)
(define last-poll #f)
(define last-filetime #f)
(define raw-config #f)
(define config-cache #f)
(provide get-conf)
(define (get-conf key)
(unless (and raw-config
(< (- (current-inexact-milliseconds) last-poll) poll-freq))
(set! last-poll (current-inexact-milliseconds))
@ -33,8 +34,8 @@
(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
(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
@ -42,16 +43,16 @@
(translate (cond [(assq key raw-config) => cadr]
[else default]))
default)])
(hash-table-put! config-cache key v)
(hash-set! config-cache key v)
v))))
(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))
(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))
(define (config-default+translate which)
(define (config-default+translate which)
(case which
[(active-dirs) (values '() path-list )]
[(inactive-dirs) (values '() path-list )]
@ -90,9 +91,9 @@
#f)]
[else (error 'get-conf "unknown configuration entry: ~s" which)]))
;; 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)
;; 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
@ -102,10 +103,8 @@
(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)
;; 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)]))
)

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

@ -1,23 +1,24 @@
(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)
(provide current-session)
(define current-session (make-parameter #f))
;; 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 (prefix)
(define (prefix)
(parameterize ([date-display-format 'iso-8601])
(format "[~a|~a] "
(or (current-session) '-)
(date->string (seconds->date (current-seconds)) #t))))
(define (combine-outputs o1 o2)
(define (combine-outputs o1 o2)
(let-values ([(i o) (make-pipe)])
(thread
(lambda ()
@ -30,9 +31,9 @@
(loop)))))))
o))
;; 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)
;; 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
@ -67,11 +68,11 @@
(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)
;; 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])))))
[else #f]))))

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

@ -1,5 +1,5 @@
(module md5 mzscheme
(require (prefix mz: mzlib/md5))
(define (md5 s)
#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))
(provide md5)