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

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

@ -231,13 +231,25 @@ sub-directories:
allows login as any user; the default is #f, which disables allows login as any user; the default is #f, which disables
the password 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 'web-base-dir : if #f (the default), the built-in web server
will use the "status-web-root" in this collection for its will use the "status-web-root" in this collection for its
configuration; to have complete control over the built in configuration; to have complete control over the built in
server, you can copy and edit "status-web-root" to the server, you can copy and edit "status-web-root", and add this
directory you're running the handin server server from, and configuration entry with the name of your new copy (relative
add this configuration entry with the name of your new copy to the handin server directory, or absolute)
(relative to the handin server directory)
'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 'extra-fields : a list that describes extra string fields of
information for student records; each element in this list is 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 To specify only pre/post-checker, use #f for the one you want to
omit. omit.
* "log.ss" (created if not present, appended otherwise) --- records * "log" (or any other name that the 'log-file configuration option
connections and actions, where each entry is of the form 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) (id time-str msg-str)
and `id' is an integer representing the connection (numbered [<id>|<time>] <msg>
consecutively from 1 when the server starts) or 0 for a message where `<id>' is an integer representing the connection (numbered
for server without a connection. consecutively from 1 when the server starts) or "-" for a message
without a connection.
* "web-status-log.ss" (created if not present, appended otherwise)
--- records accesses of the HTTPS status web server.
* "[in]active/<assignment>/<user>/<filename>" (if submitted) --- the * "[in]active/<assignment>/<user>/<filename>" (if submitted) --- the
most recent submission for <assignment> by <user> where <filename> 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 "date.ss")
(lib "list.ss") (lib "list.ss")
(lib "string.ss") (lib "string.ss")
"private/md5.ss"
"private/lock.ss"
"private/logger.ss" "private/logger.ss"
"private/config.ss"
"private/lock.ss"
"private/md5.ss"
"private/run-status.ss" "private/run-status.ss"
"web-status-server.ss") "web-status-server.ss")
;; !!! (define log-port (open-output-file "log.ss" 'append))
(install-logger-port) (install-logger-port)
(define (write+flush port . xs) (define (write+flush port . xs)
@ -29,33 +29,20 @@
[(pair? default) (car default)] [(pair? default) (car default)]
[else (error (alist-name alist) "no value for `~s'" key)])) [else (error (alist-name alist) "no value for `~s'" key)]))
(define server-dir (current-directory)) (define PORT-NUMBER (get-config 'port-number))
(define config-file (build-path server-dir "config.ss")) (define HTTPS-PORT-NUMBER (get-config 'https-port-number))
(define SESSION-TIMEOUT (get-config 'session-timeout))
(define (get-config which default) (define SESSION-MEMORY-LIMIT (get-config 'session-memory-limit))
(if (file-exists? config-file) (define DEFAULT-FILE-NAME (get-config 'default-file-name))
(get-preference which (lambda () default) #f config-file) (define MAX-UPLOAD (get-config 'max-upload))
default)) (define MAX-UPLOAD-KEEP (get-config 'max-upload-keep))
(define USER-REGEXP (get-config 'user-regexp))
(define PORT-NUMBER (get-config 'port-number 7979)) (define USER-DESC (get-config 'user-desc))
(define HTTPS-PORT-NUMBER (get-config 'https-port-number (add1 PORT-NUMBER))) (define USERNAME-CASE-SENSITIVE? (get-config 'username-case-sensitive?))
(define SESSION-TIMEOUT (get-config 'session-timeout 300)) (define ALLOW-NEW-USERS? (get-config 'allow-new-users))
(define SESSION-MEMORY-LIMIT (get-config 'session-memory-limit 40000000)) (define ALLOW-CHANGE-INFO? (get-config 'allow-change-info))
(define DEFAULT-FILE-NAME (get-config 'default-file-name "handin.scm")) (define MASTER-PASSWD (get-config 'master-password))
(define MAX-UPLOAD (get-config 'max-upload 500000)) (define EXTRA-FIELDS (get-config 'extra-fields))
(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"))))
;; separate user-controlled fields, and hidden fields ;; separate user-controlled fields, and hidden fields
(define USER-FIELDS (define USER-FIELDS
(filter (lambda (f) (not (eq? '- (cadr f)))) EXTRA-FIELDS)) (filter (lambda (f) (not (eq? '- (cadr f)))) EXTRA-FIELDS))
@ -641,7 +628,7 @@
(log-line "server started ------------------------------") (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) (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)))))

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

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

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

@ -1,24 +1,22 @@
(module web-status-server mzscheme (module web-status-server mzscheme
(require (lib "unitsig.ss") (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 "ssl-tcp-unit.ss" "net")
(lib "tcp-sig.ss" "net") (lib "tcp-sig.ss" "net")
(lib "tcp-unit.ss" "net") (lib "tcp-unit.ss" "net")
(lib "file.ss") (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) (provide serve-status)
(define (serve-status port-no get-config) (define (serve-status port-no)
(define WEB-BASE-DIR (get-config 'web-base-dir #f))
(define web-dir (define web-dir
(path->string (path->string
(if WEB-BASE-DIR (or (get-config 'web-base-dir)
(build-path (current-directory) WEB-BASE-DIR)
(build-path (this-expression-source-directory) "status-web-root")))) (build-path (this-expression-source-directory) "status-web-root"))))
(define config (define config
@ -46,7 +44,8 @@
(paths (paths
(configuration-root "conf") (configuration-root "conf")
(host-root ,web-dir) (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") (file-root "htdocs")
(servlet-root ,web-dir) (servlet-root ,web-dir)
(mime-types ,(path->string (build-path (collection-path "web-server") (mime-types ,(path->string (build-path (collection-path "web-server")
@ -59,6 +58,13 @@
(let ([file (make-temporary-file)]) (let ([file (make-temporary-file)])
(with-output-to-file file (lambda () (write config)) 'truncate) (with-output-to-file file (lambda () (write config)) 'truncate)
(begin0 (load-configuration file) (delete-file file)))) (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^ (define-values/invoke-unit/sig web-server^
(compound-unit/sig (compound-unit/sig