From cdabc3a38d59f157f03db93236812f0f42ebdfe8 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Mon, 4 Dec 2006 07:10:25 +0000
Subject: [PATCH] improving code, adding an identifier to log messages, closer
 to new unit code

svn: r5017
---
 collects/handin-server/doc.txt                |   5 +-
 .../status-web-root/servlets/status.ss        | 502 +++++++++---------
 collects/handin-server/web-status-server.ss   |   9 +-
 3 files changed, 244 insertions(+), 272 deletions(-)

diff --git a/collects/handin-server/doc.txt b/collects/handin-server/doc.txt
index 143695259f..7dd8450260 100644
--- a/collects/handin-server/doc.txt
+++ b/collects/handin-server/doc.txt
@@ -464,8 +464,9 @@ sub-directories:
         (id time-str msg-str)
         [<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.
+    consecutively from 1 when the server starts), "-" for a message
+    without a connection, and "wN" for a message from the status
+    servlet.
 
   * "[in]active/<assignment>/<user>/<filename>" (if submitted) --- the
     most recent submission for <assignment> by <user> where <filename>
diff --git a/collects/handin-server/status-web-root/servlets/status.ss b/collects/handin-server/status-web-root/servlets/status.ss
index 698f9670f1..0dc1270701 100644
--- a/collects/handin-server/status-web-root/servlets/status.ss
+++ b/collects/handin-server/status-web-root/servlets/status.ss
@@ -3,298 +3,272 @@
            (lib "list.ss")
            (lib "string.ss")
            (lib "date.ss")
-           (lib "unitsig.ss")
-           (lib "servlet-sig.ss" "web-server")
+           (lib "servlet.ss" "web-server")
            (lib "response-structs.ss" "web-server")
+           (lib "uri-codec.ss" "net")
+           (lib "md5.ss"    "handin-server" "private")
            (lib "logger.ss" "handin-server" "private")
-           (lib "md5.ss" "handin-server" "private")
-           (lib "uri-codec.ss" "net"))
+           (lib "config.ss" "handin-server" "private"))
 
-  (provide status-servlet)
-
-  (define handin-dir   (or (getenv "HANDIN_SERVER_DIR") (current-directory)))
-  (define active-dir   (build-path handin-dir "active"))
-  (define inactive-dir (build-path handin-dir "inactive"))
+  (define active-dir   (build-path server-dir "active"))
+  (define inactive-dir (build-path server-dir "inactive"))
   (define active/inactive-dirs (list active-dir inactive-dir))
 
-  (define master-password
-    (with-handlers ([exn:fail? (lambda (x) #f)])
-      (cadr (assq 'master-password
-                  (with-input-from-file (build-path handin-dir "config.ss")
-                    read)))))
+  (define master-password (get-config 'master-password))
 
   (define get-user-data
-    (let ([users-file (build-path handin-dir "users.ss")])
+    (let ([users-file (build-path server-dir "users.ss")])
       (lambda (user)
         (get-preference (string->symbol user) (lambda () #f) #f users-file))))
 
   (define (clean-str s)
     (regexp-replace #rx" *$" (regexp-replace #rx"^ *" s "") ""))
 
-  (define (update-status status tag val)
-    (let loop ([status status])
-      (cond
-       [(null? status) (list (cons tag val))]
-       [(eq? (caar status) tag) (cons (cons tag val) (cdr status))]
-       [else (cons (car status) (loop (cdr status)))])))
-
-  (define (get-status status tag default)
-    (let ([a (assq tag status)])
-      (if a (cdr a) default)))
+  (define (aget alist key)
+    (cond [(assq key alist) => cdr] [else #f]))
 
   (define (make-page title . body)
     `(html (head (title ,title))
-           (body ([bgcolor "white"]) (p ((align "center")) ,title) ,@body)))
+           (body ([bgcolor "white"]) (h1 ((align "center")) ,title) ,@body)))
 
-  (define status-servlet
-    (unit/sig ()
-      (import servlet^)
+  (define handin-prefix-re
+    ;; a regexp that turns a full path to a server-dir relative path
+    (regexp
+     (string-append
+      "^" (regexp-quote
+           (regexp-replace
+            #rx"/?$"
+            (if (path? server-dir) (path->string server-dir) server-dir)
+            "/")))))
 
-      (define handin-prefix-re
-        ;; a regexp that turns a full path to a handin-dir relative path
-        (regexp
-         (string-append
-          "^" (regexp-quote
-               (regexp-replace
-                #rx"/?$"
-                (if (path? handin-dir) (path->string handin-dir) handin-dir)
-                "/")))))
-      (define (make-k k tag)
-        (format "~a~atag=~a" k (if (regexp-match #rx"^[^#]*[?]" k) "&" "?")
-                (uri-encode (regexp-replace
-                             handin-prefix-re
-                             (if (path? tag) (path->string tag) tag)
-                             ""))))
-      (define (select-k request)
-        (let ([a (assq 'tag (request-bindings request))])
-          (and a (cdr a))))
+  (define (make-k k tag)
+    (format "~a~atag=~a" k (if (regexp-match #rx"^[^#]*[?]" k) "&" "?")
+            (uri-encode (regexp-replace handin-prefix-re
+                                        (if (path? tag) (path->string tag) tag)
+                                        ""))))
 
-      ;; `look-for' can be a username as a string (will find "bar+foo" for
-      ;; "foo"), or a regexp that should match the whole directory name (used
-      ;; with "^solution" below)
-      (define (find-hi-entry hi look-for)
-        (define (find-submission top)
-          (let ([dir (build-path top hi)])
-            (and (directory-exists? dir)
-                 (ormap
-                  (lambda (d)
-                    (let ([d (path->string d)])
-                      (and (cond [(string? look-for)
-                                  (member look-for
-                                          (regexp-split #rx" *[+] *" d))]
-                                 [(regexp? look-for) (regexp-match look-for d)]
-                                 [else (error 'find-hi-entry
-                                              "internal error: ~e" look-for)])
-                           (build-path dir d))))
-                  (directory-list dir)))))
-        (ormap find-submission active/inactive-dirs))
+  (define (select-k request)
+    (aget (request-bindings request) 'tag))
 
-      (define (handin-link k user hi)
-        (let* ([dir (find-hi-entry hi user)]
-               [l (and dir (with-handlers ([exn:fail? (lambda (x) null)])
-                             (parameterize ([current-directory dir])
-                               (sort
-                                (filter (lambda (f)
-                                          (and (not (equal? f "grade"))
-                                               (file-exists? f)))
-                                        (map path->string (directory-list)))
-                                string<?))))])
-          (if (pair? l)
-              (cdr
-               (apply
-                append
-                (map
-                 (lambda (i) `((br) ,i))
-                 (map (lambda (f)
-                         (let ([hi (build-path dir f)])
-                           `(font ()
-                             (a ((href ,(make-k k hi))) ,f)
-                             " ("
-                             ,(date->string
-                               (seconds->date
-                                (file-or-directory-modify-seconds hi))
-                               #t)
-                             ")")))
-                      l))))
-              (list (format "No handins accepted so far for user ~s, assignment ~s" user hi)))))
+  ;; `look-for' can be a username as a string (will find "bar+foo" for "foo"),
+  ;; or a regexp that should match the whole directory name (used with
+  ;; "^solution" below)
+  (define (find-hi-entry hi look-for)
+    (define (find-submission top)
+      (let ([dir (build-path top hi)])
+        (and (directory-exists? dir)
+             (ormap
+              (lambda (d)
+                (let ([d (path->string d)])
+                  (and (cond [(string? look-for)
+                              (member look-for (regexp-split #rx" *[+] *" d))]
+                             [(regexp? look-for) (regexp-match look-for d)]
+                             [else (error 'find-hi-entry
+                                          "internal error: ~e" look-for)])
+                       (build-path dir d))))
+              (directory-list dir)))))
+    (ormap find-submission active/inactive-dirs))
 
-      (define (solution-link k hi)
-        (let ([soln (find-hi-entry hi #rx"^solution")]
-              [none `((i "---"))])
-          (cond [(not soln) none]
-                [(file-exists? soln)
-                 `((a ((href ,(make-k k soln))) "Solution"))]
-                [(directory-exists? soln)
-                 (parameterize ([current-directory soln])
-                   (let ([files (sort (map path->string
-                                           (filter file-exists?
-                                                   (directory-list)))
-                                      string<?)])
-                     (if (null? files)
-                       none
-                       (apply append
-                              (map (lambda (f)
-                                     `((a ((href ,(make-k k (build-path soln f))))
-                                          (tt ,f))
-                                       (br)))
-                                   files)))))]
-                [else none])))
+  (define (handin-link k user hi)
+    (let* ([dir (find-hi-entry hi user)]
+           [l (and dir (with-handlers ([exn:fail? (lambda (x) null)])
+                         (parameterize ([current-directory dir])
+                           (sort (filter (lambda (f)
+                                           (and (not (equal? f "grade"))
+                                                (file-exists? f)))
+                                         (map path->string (directory-list)))
+                                 string<?))))])
+      (if (pair? l)
+        (cdr (apply append
+                    (map (lambda (i) `((br) ,i))
+                         (map (lambda (f)
+                                (let ([hi (build-path dir f)])
+                                  `(font ()
+                                     (a ([href ,(make-k k hi)]) ,f)
+                                     " ("
+                                     ,(date->string
+                                       (seconds->date
+                                        (file-or-directory-modify-seconds hi))
+                                       #t)
+                                     ")")))
+                              l))))
+        (list (format "No handins accepted so far for user ~s, assignment ~s"
+                      user hi)))))
 
-      (define (handin-grade user hi)
-        (let* ([dir (find-hi-entry hi user)]
-               [grade (and dir
-                           (let ([filename (build-path dir "grade")])
-                             (and (file-exists? filename)
-                                  (with-input-from-file filename
-                                    (lambda ()
-                                      (read-string (file-size filename)))))))])
-          (or grade "--")))
+  (define (solution-link k hi)
+    (let ([soln (find-hi-entry hi #rx"^solution")]
+          [none `((i "---"))])
+      (cond [(not soln) none]
+            [(file-exists? soln)
+             `((a ((href ,(make-k k soln))) "Solution"))]
+            [(directory-exists? soln)
+             (parameterize ([current-directory soln])
+               (let ([files (sort (map path->string
+                                       (filter file-exists? (directory-list)))
+                                  string<?)])
+                 (if (null? files)
+                   none
+                   (apply append
+                          (map (lambda (f)
+                                 `((a ([href ,(make-k k (build-path soln f))])
+                                     (tt ,f))
+                                   (br)))
+                               files)))))]
+            [else none])))
 
-      (define (one-status-page status for-handin)
-        (let ([user (get-status status 'user (lambda () "???"))])
-          (log-line "Status access: ~s" user)
-          (let ([next
-                 (send/suspend
+  (define (handin-grade user hi)
+    (let* ([dir (find-hi-entry hi user)]
+           [grade (and dir
+                       (let ([filename (build-path dir "grade")])
+                         (and (file-exists? filename)
+                              (with-input-from-file filename
+                                (lambda ()
+                                  (read-string (file-size filename)))))))])
+      (or grade "--")))
+
+  (define (one-status-page user for-handin)
+    (let* ([next (send/suspend
                   (lambda (k)
-                    (make-page
-                     (format "User: ~a, Handin: ~a" user for-handin)
-                     `(p ,@(handin-link k user for-handin))
-                     `(p "Grade: " ,(handin-grade user for-handin))
-                     `(p ,@(solution-link k for-handin))
-                     `(p (a ((href ,(make-k k "allofthem")))
-                            ,(format "All handins for ~a" user))))))])
-            (let ([tag (select-k next)])
-              (if (string=? tag "allofthem")
-                  (all-status-page status)
-                  (download status tag))))))
+                    (make-page (format "User: ~a, Handin: ~a" user for-handin)
+                      `(p ,@(handin-link k user for-handin))
+                      `(p "Grade: " ,(handin-grade user for-handin))
+                      `(p ,@(solution-link k for-handin))
+                      `(p (a ([href ,(make-k k "allofthem")])
+                            ,(format "All handins for ~a" user))))))]
+           [tag (select-k next)])
+      (if (string=? tag "allofthem")
+        (all-status-page user)
+        (download user tag))))
 
-      (define re:base #rx"^([a-zA-Z]*)([0-9]+)")
+  (define re:base #rx"^([a-zA-Z]*)([0-9]+)")
+  (define (all-status-page user)
+    (let* ([l (sort
+               (map path->string
+                    (append (directory-list active-dir)
+                            (with-handlers ([exn:fail? (lambda (x) null)])
+                              (directory-list inactive-dir))))
+               (lambda (a b)
+                 (let ([am (regexp-match re:base a)]
+                       [bm (regexp-match re:base b)])
+                   (if (and am bm
+                            (string=? (cadr am) (cadr bm)))
+                     (or (< (string->number (caddr am))
+                            (string->number (caddr bm)))
+                         (string<? a b))
+                     (string<? a b)))))]
+           [next
+            (send/suspend
+             (lambda (k)
+               (define (header text)
+                 `(td ((bgcolor "#f0f0f0")) (big (strong ,text))))
+               (make-page
+                (format "All Handins for ~a" user)
+                `(table ([bgcolor "#ddddff"] [cellpadding "6"] [align "center"])
+                   (tr () ,@(map header '(nbsp "Files" "Grade" "Solution")))
+                   ,@(map (lambda (hi)
+                            `(tr ([valign "top"])
+                               ,(header hi)
+                               (td ([bgcolor "white"]) ,@(handin-link k user hi))
+                               (td ([bgcolor "white"] (align "right")) ,(handin-grade user hi))
+                               (td ([bgcolor "white"]) ,@(solution-link k hi))))
+                          l)))))]
+           [tag (select-k next)])
+      (download user tag)))
 
-      (define (all-status-page status)
-        (let ([l (sort
-                  (map path->string
-                       (append (directory-list active-dir)
-                               (with-handlers ([exn:fail? (lambda (x) null)])
-                                 (directory-list inactive-dir))))
-                  (lambda (a b)
-                    (let ([am (regexp-match re:base a)]
-                          [bm (regexp-match re:base b)])
-                      (if (and am bm
-                               (string=? (cadr am) (cadr bm)))
-                          (or (< (string->number (caddr am)) (string->number (caddr bm)))
-                              (string<? a b))
-                          (string<? a b)))))]
-              [user (get-status status 'user (lambda () "???"))])
-          (log-line "Status access: ~s" user)
-          (let ([next
-                 (send/suspend
-                  (lambda (k)
-                    (define (header text)
-                      `(td ((bgcolor "#f0f0f0")) (big (strong ,text))))
-                    (make-page
-                     (format "All Handins for ~a" user)
-                     `(table ([bgcolor "#ddddff"] [cellpadding "6"] [align "center"])
-                       (tr () ,@(map header '(nbsp "Files" "Grade" "Solution")))
-                       ,@(map (lambda (hi)
-                                `(tr ([valign "top"])
-                                   ,(header hi)
-                                   (td ([bgcolor "white"]) ,@(handin-link k user hi))
-                                   (td ([bgcolor "white"] (align "right")) ,(handin-grade user hi))
-                                   (td ([bgcolor "white"]) ,@(solution-link k hi))))
-                              l)))))])
-            (let ([tag (select-k next)])
-              (download status tag)))))
+  (define (download who tag)
+    (define (check path elts)
+      (let loop ([path path] [elts (reverse elts)])
+        (let*-values ([(base name dir?) (split-path path)]
+                      [(name) (path->string name)]
+                      [(check) (and (pair? elts) (car elts))])
+          (if (null? elts)
+            ;; must be rooted in active/inactive (why build-path instead of
+            ;; using `path'? -- because path will have a trailing slash)
+            (member (build-path base name) active/inactive-dirs)
+            (and (cond [(eq? '* check) #t]
+                       [(regexp? check) (regexp-match check name)]
+                       [(string? check)
+                        (or (equal? name check)
+                            (member check (regexp-split #rx" *[+] *" name)))]
+                       [else #f])
+                 (loop base (cdr elts)))))))
+    (define file (build-path server-dir tag))
+    (with-handlers ([exn:fail? (lambda (exn)
+                                 (make-page "Error" "Illegal file access"))])
+      ;; Make sure the user is allowed to read the requested file:
+      (or (check file `(* ,who *))
+          (check file `(* #rx"^solution"))
+          (check file `(* #rx"^solution" *))
+          (error "Boom!"))
+      (log-line "Status file-get: ~s ~a" who file)
+      ;; Return the downloaded file
+      (let* ([data (with-input-from-file file
+                     (lambda () (read-bytes (file-size file))))]
+             [html? (regexp-match #rx"[.]html?$" (string-foldcase tag))]
+             [wxme? (regexp-match #rx#"^WXME" data)])
+        (make-response/full 200 "Okay" (current-seconds)
+          (cond [html? #"text/html"]
+                [wxme? #"application/data"]
+                [else  #"text/plain"])
+          `([Content-Length . ,(number->string (bytes-length data))]
+            [Content-Disposition
+             . ,(format "~a; filename=~s"
+                        (if wxme? "attachment" "inline")
+                        (let-values ([(base name dir?) (split-path file)])
+                          (path->string name)))])
+          (list data)))))
 
-      (define (download status tag)
-        (define (check path elts)
-          (let loop ([path path] [elts (reverse elts)])
-            (let*-values ([(base name dir?) (split-path path)]
-                          [(name) (path->string name)]
-                          [(check) (and (pair? elts) (car elts))])
-              (if (null? elts)
-                ;; must be rooted in active/inactive (why build-path instead of
-                ;; using `path'? -- because path will have a trailing slash)
-                (member (build-path base name) active/inactive-dirs)
-                (and (cond [(eq? '* check) #t]
-                           [(regexp? check) (regexp-match check name)]
-                           [(string? check)
-                            (or (equal? name check)
-                                (member check
-                                        (regexp-split #rx" *[+] *" name)))]
-                           [else #f])
-                     (loop base (cdr elts)))))))
-        (define file (build-path handin-dir tag))
-        (with-handlers ([exn:fail?
-                         (lambda (exn)
-                           (make-page "Error" "Illegal file access"))])
-          (let ([who (get-status status 'user (lambda () "???"))])
-            ;; Make sure the user is allowed to read the requested file:
-            (or (check file `(* ,who *))
-                (check file `(* #rx"^solution"))
-                (check file `(* #rx"^solution" *))
-                (error "Boom!"))
-            (log-line "Status file-get: ~s ~a" who file))
-          ;; Return the downloaded file
-          (let* ([data (with-input-from-file file
-                         (lambda () (read-bytes (file-size file))))]
-                 [html? (regexp-match #rx"[.]html?$" (string-foldcase tag))]
-                 [wxme? (regexp-match #rx#"^WXME" data)])
-            (make-response/full 200 "Okay" (current-seconds)
-              (cond [html? #"text/html"]
-                    [wxme? #"application/data"]
-                    [else  #"text/plain"])
-              `((Content-Length . ,(number->string (bytes-length data)))
-                (Content-Disposition
-                 . ,(format "~a; filename=~s"
-                            (if wxme? "attachment" "inline")
-                            (let-values ([(base name dir?)
-                                          (split-path file)])
-                              (path->string name)))))
-              (list data)))))
+  (define (status-page user for-handin)
+    (log-line "Status access: ~s" user)
+    (if for-handin
+      (one-status-page user for-handin)
+      (all-status-page user)))
 
-      (define (status-page status for-handin)
-        (if for-handin
-            (one-status-page status for-handin)
-            (all-status-page status)))
+  (define (login-page status for-handin errmsg)
+    (let* ([request
+            (send/suspend
+             (lambda (k)
+               (make-page
+                "Handin Status Login"
+                `(form ([action ,k] [method "post"])
+                   (table ([align "center"])
+                     (tr (td ([colspan "2"] [align "center"])
+                           (font ([color "red"]) ,(or errmsg 'nbsp))))
+                     (tr (td "Username")
+                         (td (input ([type "text"] [name "user"] [size "20"]
+                                     [value ""]))))
+                     (tr (td nbsp))
+                     (tr (td "Password")
+                         (td (input ([type "password"] [name "passwd"]
+                                     [size "20"] [value ""]))))
+                     (tr (td ([colspan "2"] [align "center"])
+                           (input ([type "submit"] [name "post"]
+                                   [value "Login"])))))))))]
+           [user      (clean-str (aget (request-bindings request) 'user))]
+           [passwd    (aget (request-bindings request) 'passwd)]
+           [user-data (get-user-data user)])
+      (cond [(and user-data
+                  (string? passwd)
+                  (let ([pw (md5 passwd)])
+                    (or (equal? pw (car user-data))
+                        (equal? pw master-password))))
+             (status-page user for-handin)]
+            [else (login-page status for-handin "Bad username or password")])))
 
-      (define (login-page status for-handin errmsg)
-        (let ([request
-               (send/suspend
-                (lambda (k)
-                  (make-page
-                   "Handin Status Login"
-                   `(form ([action ,k] [method "post"])
-                          (table
-                           ((align "center"))
-                           (tr (td ((colspan "2") (align "center"))
-                                   (font ((color "red"))
-                                         ,(if errmsg
-                                              errmsg
-                                              'nbsp))))
-                           (tr (td "Username")
-                               (td (input ([type "text"] [name "user"] [size "20"] [value ""]))))
-                           (tr (td nbsp))
-                           (tr (td "Password")
-                               (td (input ([type "password"] [name "passwd"] [size "20"] [value ""]))))
-                           (td ((colspan "2") (align "center"))
-                               (input ([type "submit"] [name "post"] [value "Login"]))))))))])
-          (let ([user (clean-str (cdr (assq 'user (request-bindings request))))]
-                [passwd (cdr (assq 'passwd (request-bindings request)))])
-            (let ([user-data (get-user-data user)])
-              (cond
-               [(and user-data
-                     (string? passwd)
-                     (let ([pw (md5 passwd)])
-                       (or (equal? pw (car user-data))
-                           (equal? pw master-password))))
-                (status-page (update-status status 'user user) for-handin)]
-               [else
-                (login-page status for-handin "Bad username or password")])))))
+  (define web-counter
+    (let ([sema (make-semaphore 1)]
+          [count 0])
+      (lambda ()
+        (dynamic-wind
+          (lambda () (semaphore-wait sema))
+          (lambda () (set! count (add1 count)) (format "w~a" count))
+          (lambda () (semaphore-post sema))))))
 
-      (let ([a (assq 'handin (request-bindings initial-request))])
-        (login-page null (and a (cdr a)) #f))
+  (define (start initial-request)
+    (parameterize ([current-session (web-counter)])
+      (login-page null (aget (request-bindings initial-request) 'handin) #f)))
 
-      )))
-
-(require status)
-status-servlet
+  (provide interface-version timeout start)
+  (define interface-version 'v1)
+  (define timeout 180)
+  )
diff --git a/collects/handin-server/web-status-server.ss b/collects/handin-server/web-status-server.ss
index caa58805d5..86a71674a4 100644
--- a/collects/handin-server/web-status-server.ss
+++ b/collects/handin-server/web-status-server.ss
@@ -54,18 +54,15 @@
             (password-authentication ,(path->string (build-path (current-directory) "web-status-passwords"))))))
         (virtual-host-table)))
 
-    #; ; old version
-    (define config@
-      (let ([file (make-temporary-file)])
-        (with-output-to-file file (lambda () (write config)) 'truncate)
-        (begin0 (load-configuration file) (delete-file file))))
     (define config@
       (load-configuration-sexpr
        web-dir config
        #:make-servlet-namespace
        (make-make-servlet-namespace
         #:to-be-copied-module-specs
-        '((lib "logger.ss" "handin-server" "private")))))
+        '((lib "logger.ss" "handin-server" "private")
+          (lib "config.ss" "handin-server" "private")
+          (lib "md5.ss"    "handin-server" "private")))))
 
     (define-values/invoke-unit/sig web-server^
       (compound-unit/sig