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

* New log facility is actually working

Browse Source 
* New configuration options to set output log, log file, and web log file
* Centralized dealing with configuration options (including conversions and
  defaults)

svn: r4890
This commit is contained in:
Eli Barzilay 2006-11-20 09:07:07 +00:00
parent 42327b10e6
commit 3b9770c76a
5 changed files with 167 additions and 85 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
collects/handin-server/doc.txt
View File

@ -164,7 +164,7 @@ sub-directories:
students with the handin client, "private-key.pem" is kept
private.
* "config.ss" (optional) --- configuration options. The file format
* "config.ss" (optional) --- configuration options. The file format
is
((<key> <val>) ...)
@ -231,13 +231,25 @@ sub-directories:
allows login as any user; the default is #f, which disables
the password
'log-output : a boolean that controls whether the handin server
log is written on the standard output; defaults to #t
'log-file : a path (relative to handin server directory or
absolute) that specifies a filename for the handin server log
(possibly combined with the 'log-output option), or #f for no
log file; defaults to "log"
'web-base-dir : if #f (the default), the built-in web server
will use the "status-web-root" in this collection for its
configuration; to have complete control over the built in
server, you can copy and edit "status-web-root" to the
directory you're running the handin server server from, and
add this configuration entry with the name of your new copy
(relative to the handin server directory)
server, you can copy and edit "status-web-root", and add this
configuration entry with the name of your new copy (relative
to the handin server directory, or absolute)
'web-log-file : a path (relative to handin server directory or
absolute) that specifies a filename for logging the internal
HTTPS status web server; or #f (the default) to disable this
log
'extra-fields : a list that describes extra string fields of
information for student records; each element in this list is
@ -445,15 +457,15 @@ sub-directories:
To specify only pre/post-checker, use #f for the one you want to
omit.
* "log.ss" (created if not present, appended otherwise) --- records
connections and actions, where each entry is of the form
* "log" (or any other name that the 'log-file configuration option
specifies (if any), created if not present, appended otherwise)
--- records connections and actions, where each entry is of the
form
(id time-str msg-str)
and `id' is an integer representing the connection (numbered
consecutively from 1 when the server starts) or 0 for a message
for server without a connection.
* "web-status-log.ss" (created if not present, appended otherwise)
--- records accesses of the HTTPS status web server.
[<id>|<time>] <msg>
where `<id>' is an integer representing the connection (numbered
consecutively from 1 when the server starts) or "-" for a message
without a connection.
* "[in]active/<assignment>/<user>/<filename>" (if submitted) --- the
most recent submission for <assignment> by <user> where <filename>

49
collects/handin-server/handin-server.ss
View File

@ -6,13 +6,13 @@
(lib "date.ss")
(lib "list.ss")
(lib "string.ss")
"private/md5.ss"
"private/lock.ss"
"private/logger.ss"
"private/config.ss"
"private/lock.ss"
"private/md5.ss"
"private/run-status.ss"
"web-status-server.ss")
;; !!! (define log-port (open-output-file "log.ss" 'append))
(install-logger-port)
(define (write+flush port . xs)
@ -29,33 +29,20 @@
[(pair? default) (car default)]
[else (error (alist-name alist) "no value for `~s'" key)]))
(define server-dir (current-directory))
(define config-file (build-path server-dir "config.ss"))
(define (get-config which default)
(if (file-exists? config-file)
(get-preference which (lambda () default) #f config-file)
default))
(define PORT-NUMBER (get-config 'port-number 7979))
(define HTTPS-PORT-NUMBER (get-config 'https-port-number (add1 PORT-NUMBER)))
(define SESSION-TIMEOUT (get-config 'session-timeout 300))
(define SESSION-MEMORY-LIMIT (get-config 'session-memory-limit 40000000))
(define DEFAULT-FILE-NAME (get-config 'default-file-name "handin.scm"))
(define MAX-UPLOAD (get-config 'max-upload 500000))
(define MAX-UPLOAD-KEEP (get-config 'max-upload-keep 9))
(define USER-REGEXP (get-config 'user-regexp #rx"^[a-z][a-z0-9]+$"))
(define USER-DESC (get-config 'user-desc "alphanumeric string"))
(define USERNAME-CASE-SENSITIVE? (get-config 'username-case-sensitive? #f))
(define ALLOW-NEW-USERS? (get-config 'allow-new-users #f))
(define ALLOW-CHANGE-INFO? (get-config 'allow-change-info #f))
(define MASTER-PASSWD (get-config 'master-password #f))
(define EXTRA-FIELDS
(get-config 'extra-fields
'(("Full Name" #f #f)
("ID#" #f #f)
("Email" #rx"^[^@<>\"`',]+@[a-zA-Z0-9_.-]+[.][a-zA-Z]+$"
"a valid email address"))))
(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))
@ -641,7 +628,7 @@
(log-line "server started ------------------------------")
(define stop-status (serve-status HTTPS-PORT-NUMBER get-config))
(define stop-status (serve-status HTTPS-PORT-NUMBER))
(define session-count 0)

50
collects/handin-server/private/config.ss Normal file
View File

@ -0,0 +1,50 @@
(module config mzscheme
(require (lib "file.ss"))
;; This module should be invoked when in the server directory
(provide server-dir)
(define server-dir (current-directory))
(define config-file (path->complete-path "config.ss" server-dir))
(define (get-config* which default)
(if (file-exists? config-file)
(get-preference which (lambda () default) #f config-file)
default))
(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 (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 )]
[(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)]))
(provide get-config)
(define (get-config which)
(let-values ([(default translate) (config-default+translate which)])
(translate (get-config* which default)))))

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

@ -1,5 +1,5 @@
(module logger mzscheme
(require (lib "date.ss"))
(require "config.ss" (lib "date.ss") (lib "port.ss"))
(provide current-session)
(define current-session (make-parameter #f))
@ -17,35 +17,62 @@
(or (current-session) '-)
(date->string (seconds->date (current-seconds)) #t))))
;; Implement a logger by capturing current-error-port and printing a prefix,
;; provide a function to install this port
(define (make-logger-port stderr)
(define prompt? #t)
(define sema (make-semaphore 1))
(make-output-port
'logger-output
stderr
(lambda (buf start end imm? break?)
(dynamic-wind
(lambda () (semaphore-wait sema))
(lambda ()
(if (= start end)
(begin (flush-output stderr) 0)
(let ([nl (regexp-match-positions #rx#"\n" buf start end)])
;; may be problematic if this hangs...
(when prompt? (display (prefix) stderr) (set! prompt? #f))
(if (not nl)
(write-bytes-avail* buf stderr start end)
(let* ([nl (cdar nl)]
[l (write-bytes-avail* buf stderr start nl)])
(when (= l (- nl start))
;; pre-newline part written
(flush-output stderr) (set! prompt? #t))
l)))))
(lambda () (semaphore-post sema))))
(lambda () (close-output-port stderr))))
(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 on the current error port
;; 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 (current-error-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))]
[else #f])))))

28
collects/handin-server/web-status-server.ss
View File

@ -1,25 +1,23 @@
(module web-status-server mzscheme
(require (lib "unitsig.ss")
(lib "web-server-unit.ss" "web-server")
(lib "sig.ss" "web-server")
(lib "configuration.ss" "web-server")
(lib "ssl-tcp-unit.ss" "net")
(lib "tcp-sig.ss" "net")
(lib "tcp-unit.ss" "net")
(lib "file.ss")
(lib "etc.ss"))
(lib "etc.ss")
(lib "web-server-unit.ss" "web-server")
(lib "sig.ss" "web-server")
(lib "configuration.ss" "web-server")
"private/config.ss")
(provide serve-status)
(define (serve-status port-no get-config)
(define WEB-BASE-DIR (get-config 'web-base-dir #f))
(define (serve-status port-no)
(define web-dir
(path->string
(if WEB-BASE-DIR
(build-path (current-directory) WEB-BASE-DIR)
(build-path (this-expression-source-directory) "status-web-root"))))
(or (get-config 'web-base-dir)
(build-path (this-expression-source-directory) "status-web-root"))))
(define config
`((port ,port-no)
@ -46,7 +44,8 @@
(paths
(configuration-root "conf")
(host-root ,web-dir)
(log-file-path ,(path->string (build-path (current-directory) "web-status-log.ss")))
(log-file-path ,(cond [(get-config 'web-log-file) => path->string]
[else #f]))
(file-root "htdocs")
(servlet-root ,web-dir)
(mime-types ,(path->string (build-path (collection-path "web-server")
@ -59,6 +58,13 @@
(let ([file (make-temporary-file)])
(with-output-to-file file (lambda () (write config)) 'truncate)
(begin0 (load-configuration file) (delete-file file))))
#; ; This is not working yet
(define config@
(load-configuration-sexpr config
#:make-servlet-namespace
(make-make-servlet-namespace
#:to-be-copied-module-specs
'((lib "logger.ss" "handin-server" "private")))))
(define-values/invoke-unit/sig web-server^
(compound-unit/sig