From 3b9770c76a1dc78d31bd255dac7e9b81ae49d1ab Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Mon, 20 Nov 2006 09:07:07 +0000
Subject: [PATCH] * New log facility is actually working * New configuration
 options to set output log, log file, and web log file * Centralized dealing
 with configuration options (including conversions and   defaults)

svn: r4890
---
 collects/handin-server/doc.txt              | 38 ++++++---
 collects/handin-server/handin-server.ss     | 49 +++++-------
 collects/handin-server/private/config.ss    | 50 ++++++++++++
 collects/handin-server/private/logger.ss    | 87 ++++++++++++++-------
 collects/handin-server/web-status-server.ss | 28 ++++---
 5 files changed, 167 insertions(+), 85 deletions(-)
 create mode 100644 collects/handin-server/private/config.ss

diff --git a/collects/handin-server/doc.txt b/collects/handin-server/doc.txt
index ca07d44a34..143695259f 100644
--- a/collects/handin-server/doc.txt
+++ b/collects/handin-server/doc.txt
@@ -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>
diff --git a/collects/handin-server/handin-server.ss b/collects/handin-server/handin-server.ss
index 640913bd3f..30e674c16a 100644
--- a/collects/handin-server/handin-server.ss
+++ b/collects/handin-server/handin-server.ss
@@ -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)
 
diff --git a/collects/handin-server/private/config.ss b/collects/handin-server/private/config.ss
new file mode 100644
index 0000000000..ae8727ebf8
--- /dev/null
+++ b/collects/handin-server/private/config.ss
@@ -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)))))
diff --git a/collects/handin-server/private/logger.ss b/collects/handin-server/private/logger.ss
index 931166fd5b..2e26983bcd 100644
--- a/collects/handin-server/private/logger.ss
+++ b/collects/handin-server/private/logger.ss
@@ -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])))))
diff --git a/collects/handin-server/web-status-server.ss b/collects/handin-server/web-status-server.ss
index cf03f9c7cf..d7d4d14a60 100644
--- a/collects/handin-server/web-status-server.ss
+++ b/collects/handin-server/web-status-server.ss
@@ -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