From fd4627095c47c6f3a3d712cd3edb5d7ef0f6e83c Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 12 Nov 2006 10:38:59 +0000 Subject: [PATCH] some reformatting and reorganization svn: r4828 --- collects/handin-server/handin-server.ss | 197 +++++++------- collects/handin-server/{ => private}/lock.ss | 1 - collects/handin-server/{ => private}/md5.ss | 0 .../status-web-root/servlets/status.ss | 252 +++++++++--------- collects/handin-server/web-status-server.ss | 98 ++++--- 5 files changed, 268 insertions(+), 280 deletions(-) rename collects/handin-server/{ => private}/lock.ss (99%) rename collects/handin-server/{ => private}/md5.ss (100%) diff --git a/collects/handin-server/handin-server.ss b/collects/handin-server/handin-server.ss index e5fdb80be9..20191abe5b 100644 --- a/collects/handin-server/handin-server.ss +++ b/collects/handin-server/handin-server.ss @@ -1,16 +1,15 @@ -#cs (module handin-server mzscheme (require (lib "thread.ss") - (lib "port.ss") - (lib "mzssl.ss" "openssl") - (lib "file.ss") - (lib "date.ss") - (lib "list.ss") - (lib "string.ss") - "md5.ss" - "lock.ss" - "web-status-server.ss" - "run-status.ss") + (lib "port.ss") + (lib "mzssl.ss" "openssl") + (lib "file.ss") + (lib "date.ss") + (lib "list.ss") + (lib "string.ss") + "private/md5.ss" + "private/lock.ss" + "web-status-server.ss" + "run-status.ss") (define log-port (open-output-file "log.ss" 'append)) @@ -35,11 +34,11 @@ ;; Assemble log into into a single string, to make ;; interleaved log lines unlikely: (let ([line - (format "(~a ~s ~s)\n" - (current-session) - (parameterize ([date-display-format 'iso-8601]) - (date->string (seconds->date (current-seconds)) #t)) - (apply format str args))]) + (format "(~a ~s ~s)\n" + (current-session) + (parameterize ([date-display-format 'iso-8601]) + (date->string (seconds->date (current-seconds)) #t)) + (apply format str args))]) (display line log-port) (flush-output log-port))) @@ -77,15 +76,15 @@ (define orig-custodian (current-custodian)) ;; On startup, check that the users file is not locked: - (put-preferences null null - (lambda (f) - (delete-file f) - (put-preferences null null - (lambda (f) - (error 'handin-server - "unable to clean up lock file: ~s" f)) - "users.ss")) - "users.ss") + (put-preferences null null + (lambda (f) + (delete-file f) + (put-preferences null null + (lambda (f) + (error 'handin-server + "unable to clean up lock file: ~s" f)) + "users.ss")) + "users.ss") ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -96,11 +95,11 @@ (define (make-success-dir-available n) (let ([name (success-dir n)]) (when (directory-exists? name) - (if (< n MAX-UPLOAD-KEEP) - (begin - (make-success-dir-available (add1 n)) - (rename-file-or-directory name (success-dir (add1 n)))) - (delete-directory/files name))))) + (if (< n MAX-UPLOAD-KEEP) + (begin + (make-success-dir-available (add1 n)) + (rename-file-or-directory name (success-dir (add1 n)))) + (delete-directory/files name))))) (define ATTEMPT-RE (regexp (format "^~a$" ATTEMPT-DIR))) (define SUCCESS-RE (regexp (format "^~a$" (success-dir "[0-9]+")))) @@ -111,35 +110,35 @@ ;; means that there was a failed submission and the next one will ;; re-create ATTEMPT. (let* ([dirlist (map path->string (directory-list))] - [dir (sort (filter (lambda (d) + [dir (sort (filter (lambda (d) (and (directory-exists? d) (regexp-match SUCCESS-RE d))) dirlist) - string= n 0) - (let ([new (map (lambda (x) - (if (directory-exists? x) - (directory-list x) - null)) - '("active" "inactive"))]) + (let ([new (map (lambda (x) + (if (directory-exists? x) + (directory-list x) + null)) + '("active" "inactive"))]) (if (equal? new last-active/inactive) (begin (sleep 30) (loop (sub1 n))) (begin (set! last-active/inactive new) @@ -660,57 +659,57 @@ (define session-count 0) (parameterize ([error-display-handler - (lambda (msg exn) - (LOG msg))]) + (lambda (msg exn) + (LOG msg))]) (run-server PORT-NUMBER (lambda (r w) (set! connection-num (add1 connection-num)) (when ((current-memory-use) . > . SESSION-MEMORY-LIMIT) - (collect-garbage)) + (collect-garbage)) (parameterize ([current-session (begin - (set! session-count (add1 session-count)) - session-count)]) - (let-values ([(here there) (ssl-addresses r)]) - (LOG "connect from ~a" there)) - (with-watcher - w - (lambda (kill-watcher) - (let ([r-safe (make-limited-input-port r 2048)]) - (write+flush w 'handin) - ;; Check protocol: - (with-handlers ([exn:fail? - (lambda (exn) - (let ([msg (if (exn? exn) - (exn-message exn) - (format "~e" exn))]) - (kill-watcher) - (LOG "ERROR: ~a" msg) - (write+flush w msg) - ;; see note on close-output-port below - (close-output-port w)))]) + (set! session-count (add1 session-count)) + session-count)]) + (let-values ([(here there) (ssl-addresses r)]) + (LOG "connect from ~a" there)) + (with-watcher + w + (lambda (kill-watcher) + (let ([r-safe (make-limited-input-port r 2048)]) + (write+flush w 'handin) + ;; Check protocol: + (with-handlers ([exn:fail? + (lambda (exn) + (let ([msg (if (exn? exn) + (exn-message exn) + (format "~e" exn))]) + (kill-watcher) + (LOG "ERROR: ~a" msg) + (write+flush w msg) + ;; see note on close-output-port below + (close-output-port w)))]) (let ([protocol (read r-safe)]) - (if (eq? protocol 'ver1) - (write+flush w 'ver1) - (error 'handin "unknown protocol: ~s" protocol))) - (handle-connection r r-safe w) - (LOG "normal exit") - (kill-watcher) - ;; This close-output-port should not be necessary, and it's - ;; here due to a deficiency in the SLL binding. - ;; The problem is that a custodian shutdown of w is harsher - ;; for SSL output than a normal close. A normal close - ;; flushes an internal buffer that's not supposed to exist, while - ;; the shutdown gives up immediately. - (close-output-port w))))))) + (if (eq? protocol 'ver1) + (write+flush w 'ver1) + (error 'handin "unknown protocol: ~s" protocol))) + (handle-connection r r-safe w) + (LOG "normal exit") + (kill-watcher) + ;; This close-output-port should not be necessary, and it's + ;; here due to a deficiency in the SLL binding. + ;; The problem is that a custodian shutdown of w is harsher + ;; for SSL output than a normal close. A normal close + ;; flushes an internal buffer that's not supposed to exist, while + ;; the shutdown gives up immediately. + (close-output-port w))))))) #f ; `with-watcher' handles our timeouts (lambda (exn) (printf "~a\n" (if (exn? exn) (exn-message exn) exn))) (lambda (port-k cnt reuse?) (let ([l (ssl-listen port-k cnt #t)]) - (ssl-load-certificate-chain! l "server-cert.pem") - (ssl-load-private-key! l "private-key.pem") - l)) + (ssl-load-certificate-chain! l "server-cert.pem") + (ssl-load-private-key! l "private-key.pem") + l)) ssl-close ssl-accept ssl-accept/enable-break))) diff --git a/collects/handin-server/lock.ss b/collects/handin-server/private/lock.ss similarity index 99% rename from collects/handin-server/lock.ss rename to collects/handin-server/private/lock.ss index 739d395e86..ce890b49ac 100644 --- a/collects/handin-server/lock.ss +++ b/collects/handin-server/private/lock.ss @@ -1,4 +1,3 @@ - (module lock mzscheme (require (lib "list.ss")) diff --git a/collects/handin-server/md5.ss b/collects/handin-server/private/md5.ss similarity index 100% rename from collects/handin-server/md5.ss rename to collects/handin-server/private/md5.ss diff --git a/collects/handin-server/status-web-root/servlets/status.ss b/collects/handin-server/status-web-root/servlets/status.ss index 2f4885f776..3896837060 100644 --- a/collects/handin-server/status-web-root/servlets/status.ss +++ b/collects/handin-server/status-web-root/servlets/status.ss @@ -1,14 +1,13 @@ - (module status mzscheme (require (lib "file.ss") - (lib "list.ss") - (lib "string.ss") - (lib "date.ss") - (lib "unitsig.ss") - (lib "servlet-sig.ss" "web-server") - (lib "response-structs.ss" "web-server") - (lib "md5.ss" "handin-server") - (lib "uri-codec.ss" "net")) + (lib "list.ss") + (lib "string.ss") + (lib "date.ss") + (lib "unitsig.ss") + (lib "servlet-sig.ss" "web-server") + (lib "response-structs.ss" "web-server") + (lib "md5.ss" "handin-server" "private") + (lib "uri-codec.ss" "net")) (provide status-servlet) @@ -20,8 +19,8 @@ (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))))) + (with-input-from-file (build-path handin-dir "config.ss") + read))))) (define get-user-data (let ([users-file (build-path handin-dir "users.ss")]) @@ -44,7 +43,7 @@ (define (make-page title . body) `(html (head (title ,title)) - (body ([bgcolor "white"]) (p ((align "center")) ,title) ,@body))) + (body ([bgcolor "white"]) (p ((align "center")) ,title) ,@body))) (define status-servlet (unit/sig () @@ -60,14 +59,14 @@ (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) "&" "?") + (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)))) + (let ([a (assq 'tag (request-bindings request))]) + (and a (cdr a)))) ;; `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 @@ -90,8 +89,8 @@ (ormap find-submission active/inactive-dirs)) (define (handin-link k user hi) - (let* ([dir (find-hi-entry hi user)] - [l (and dir (with-handlers ([exn:fail? (lambda (x) null)]) + (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) @@ -99,27 +98,27 @@ (file-exists? f))) (map path->string (directory-list))) stringstring - (seconds->date - (file-or-directory-modify-seconds hi)) - #t) - ")"))) - l)))) - (list (format "No handins accepted so far for user ~s, assignment ~s" user hi))))) + (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 (solution-link k hi) - (let ([soln (find-hi-entry hi #rx"^solution")] + (let ([soln (find-hi-entry hi #rx"^solution")] [none `((i "---"))]) (cond [(not soln) none] [(file-exists? soln) @@ -141,67 +140,67 @@ [else none]))) (define (handin-grade user hi) - (let* ([dir (find-hi-entry hi user)] - [grade (and dir + (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 "--"))) + (or grade "--"))) (define (one-status-page status for-handin) - (let ([user (get-status status 'user (lambda () "???"))]) - (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)))))) + (let ([user (get-status status 'user (lambda () "???"))]) + (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)))))) (define re:base #rx"^([a-zA-Z]*)([0-9]+)") (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))) + (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))) (stringstring (bytes-length data))) - ,@(if wxme? + `((Content-Length . ,(number->string (bytes-length data))) + ,@(if wxme? `((Content-Disposition . ,(format "attachment; filename=~s" (let-values ([(base name dir?) (split-path file)]) (path->string name))))) '())) - (list data))))) + (list data))))) (define (status-page status for-handin) - (if for-handin - (one-status-page status for-handin) - (all-status-page status))) + (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")) - ,(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")]))))) + (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")]))))) (let ([a (assq 'handin (request-bindings initial-request))]) - (login-page null (and a (cdr a)) #f)) + (login-page null (and a (cdr a)) #f)) ))) (require status) status-servlet - diff --git a/collects/handin-server/web-status-server.ss b/collects/handin-server/web-status-server.ss index 9ff3ff0545..cf03f9c7cf 100644 --- a/collects/handin-server/web-status-server.ss +++ b/collects/handin-server/web-status-server.ss @@ -1,14 +1,13 @@ - (module web-status-server mzscheme (require (lib "unitsig.ss") - (lib "web-server-unit.ss" "web-server") - (lib "sig.ss" "web-server") + (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 "ssl-tcp-unit.ss" "net") + (lib "tcp-sig.ss" "net") + (lib "tcp-unit.ss" "net") + (lib "file.ss") + (lib "etc.ss")) (provide serve-status) @@ -24,61 +23,54 @@ (define config `((port ,port-no) - (max-waiting 40) - (initial-connection-timeout 30) - (default-host-table - (host-table - (default-indices "index.html") - (log-format parenthesized-default) - (messages - (servlet-message "servlet-error.html") - (authentication-message "forbidden.html") - (servlets-refreshed "servlet-refresh.html") - (passwords-refreshed "passwords-refresh.html") - (file-not-found-message "not-found.html") - (protocol-message "protocol-error.html") - (collect-garbage "collect-garbage.html")) - (timeouts - (default-servlet-timeout 120) - (password-connection-timeout 300) - (servlet-connection-timeout 86400) - (file-per-byte-connection-timeout 1/20) - (file-base-connection-timeout 30)) - (paths - (configuration-root "conf") - (host-root ,web-dir) - (log-file-path ,(path->string (build-path (current-directory) "web-status-log.ss"))) - (file-root "htdocs") - (servlet-root ,web-dir) - (mime-types ,(path->string (build-path (collection-path "web-server") - "default-web-root" - "mime.types"))) - (password-authentication ,(path->string (build-path (current-directory) "web-status-passwords")))))) - (virtual-host-table))) + (max-waiting 40) + (initial-connection-timeout 30) + (default-host-table + (host-table + (default-indices "index.html") + (log-format parenthesized-default) + (messages + (servlet-message "servlet-error.html") + (authentication-message "forbidden.html") + (servlets-refreshed "servlet-refresh.html") + (passwords-refreshed "passwords-refresh.html") + (file-not-found-message "not-found.html") + (protocol-message "protocol-error.html") + (collect-garbage "collect-garbage.html")) + (timeouts + (default-servlet-timeout 120) + (password-connection-timeout 300) + (servlet-connection-timeout 86400) + (file-per-byte-connection-timeout 1/20) + (file-base-connection-timeout 30)) + (paths + (configuration-root "conf") + (host-root ,web-dir) + (log-file-path ,(path->string (build-path (current-directory) "web-status-log.ss"))) + (file-root "htdocs") + (servlet-root ,web-dir) + (mime-types ,(path->string (build-path (collection-path "web-server") + "default-web-root" + "mime.types"))) + (password-authentication ,(path->string (build-path (current-directory) "web-status-passwords")))))) + (virtual-host-table))) (define config@ (let ([file (make-temporary-file)]) - (with-output-to-file file - (lambda () - (write config)) - 'truncate) - (begin0 - (load-configuration file) - (delete-file file)))) + (with-output-to-file file (lambda () (write config)) 'truncate) + (begin0 (load-configuration file) (delete-file file)))) (define-values/invoke-unit/sig web-server^ (compound-unit/sig (import) - (link - [T : net:tcp^ ((make-ssl-tcp@ - "server-cert.pem" "private-key.pem" #f #f - #f #f #f))] - [C : web-config^ (config@)] - [S : web-server^ (web-server@ T C)]) + (link [T : net:tcp^ ((make-ssl-tcp@ + "server-cert.pem" "private-key.pem" #f #f + #f #f #f))] + [C : web-config^ (config@)] + [S : web-server^ (web-server@ T C)]) (export (open S))) #f) (putenv "HANDIN_SERVER_DIR" (path->string (current-directory))) (serve))) -