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

some reformatting and reorganization

Browse Source 
svn: r4828
This commit is contained in:
Eli Barzilay 2006-11-12 10:38:59 +00:00
parent dffa753378
commit fd4627095c
5 changed files with 268 additions and 280 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,16 +1,15 @@
#cs
(module handin-server mzscheme (module handin-server mzscheme
(require (lib "thread.ss") (require (lib "thread.ss")
(lib "port.ss") (lib "port.ss")
(lib "mzssl.ss" "openssl") (lib "mzssl.ss" "openssl")
(lib "file.ss") (lib "file.ss")
(lib "date.ss") (lib "date.ss")
(lib "list.ss") (lib "list.ss")
(lib "string.ss") (lib "string.ss")
"md5.ss" "private/md5.ss"
"lock.ss" "private/lock.ss"
"web-status-server.ss" "web-status-server.ss"
"run-status.ss") "run-status.ss")
(define log-port (open-output-file "log.ss" 'append)) (define log-port (open-output-file "log.ss" 'append))
@ -35,11 +34,11 @@
;; Assemble log into into a single string, to make ;; Assemble log into into a single string, to make
;; interleaved log lines unlikely: ;; interleaved log lines unlikely:
(let ([line (let ([line
(format "(~a ~s ~s)\n" (format "(~a ~s ~s)\n"
(current-session) (current-session)
(parameterize ([date-display-format 'iso-8601]) (parameterize ([date-display-format 'iso-8601])
(date->string (seconds->date (current-seconds)) #t)) (date->string (seconds->date (current-seconds)) #t))
(apply format str args))]) (apply format str args))])
(display line log-port) (display line log-port)
(flush-output log-port))) (flush-output log-port)))
@ -78,14 +77,14 @@
;; On startup, check that the users file is not locked: ;; On startup, check that the users file is not locked:
(put-preferences null null (put-preferences null null
(lambda (f) (lambda (f)
(delete-file f) (delete-file f)
(put-preferences null null (put-preferences null null
(lambda (f) (lambda (f)
(error 'handin-server (error 'handin-server
"unable to clean up lock file: ~s" f)) "unable to clean up lock file: ~s" f))
"users.ss")) "users.ss"))
"users.ss") "users.ss")
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -96,11 +95,11 @@
(define (make-success-dir-available n) (define (make-success-dir-available n)
(let ([name (success-dir n)]) (let ([name (success-dir n)])
(when (directory-exists? name) (when (directory-exists? name)
(if (< n MAX-UPLOAD-KEEP) (if (< n MAX-UPLOAD-KEEP)
(begin (begin
(make-success-dir-available (add1 n)) (make-success-dir-available (add1 n))
(rename-file-or-directory name (success-dir (add1 n)))) (rename-file-or-directory name (success-dir (add1 n))))
(delete-directory/files name))))) (delete-directory/files name)))))
(define ATTEMPT-RE (regexp (format "^~a$" ATTEMPT-DIR))) (define ATTEMPT-RE (regexp (format "^~a$" ATTEMPT-DIR)))
(define SUCCESS-RE (regexp (format "^~a$" (success-dir "[0-9]+")))) (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 ;; means that there was a failed submission and the next one will
;; re-create ATTEMPT. ;; re-create ATTEMPT.
(let* ([dirlist (map path->string (directory-list))] (let* ([dirlist (map path->string (directory-list))]
[dir (sort (filter (lambda (d) [dir (sort (filter (lambda (d)
(and (directory-exists? d) (and (directory-exists? d)
(regexp-match SUCCESS-RE d))) (regexp-match SUCCESS-RE d)))
dirlist) dirlist)
string<?)] string<?)]
[dir (and (pair? dir) (car dir))]) [dir (and (pair? dir) (car dir))])
(when dir (when dir
(unless (member dir SUCCESS-GOOD) (unless (member dir SUCCESS-GOOD)
(LOG "*** USING AN UNEXPECTED SUBMISSION DIRECTORY: ~a" (LOG "*** USING AN UNEXPECTED SUBMISSION DIRECTORY: ~a"
(build-path (current-directory) dir))) (build-path (current-directory) dir)))
;; We have a submission directory -- copy all newer things (extra ;; We have a submission directory -- copy all newer things (extra
;; things that exist in the main submission directory but not in ;; things that exist in the main submission directory but not in
;; SUCCESS, or things that are newer in the main submission ;; SUCCESS, or things that are newer in the main submission
;; directory are kept (but subdirs in SUCCESS will are copied as ;; directory are kept (but subdirs in SUCCESS will are copied as
;; is)) ;; is))
(for-each (for-each
(lambda (f) (lambda (f)
(define dir/f (build-path dir f)) (define dir/f (build-path dir f))
(cond [(not (or (file-exists? f) (directory-exists? f))) (cond [(not (or (file-exists? f) (directory-exists? f)))
;; f is in dir but not in the working directory ;; f is in dir but not in the working directory
(copy-directory/files dir/f f)] (copy-directory/files dir/f f)]
[(or (<= (file-or-directory-modify-seconds f) [(or (<= (file-or-directory-modify-seconds f)
(file-or-directory-modify-seconds dir/f)) (file-or-directory-modify-seconds dir/f))
(and (file-exists? f) (file-exists? dir/f) (and (file-exists? f) (file-exists? dir/f)
(not (= (file-size f) (file-size dir/f))))) (not (= (file-size f) (file-size dir/f)))))
;; f is newer in dir than in the working directory ;; f is newer in dir than in the working directory
(delete-directory/files f) (delete-directory/files f)
(copy-directory/files dir/f f)])) (copy-directory/files dir/f f)]))
(directory-list dir))))) (directory-list dir)))))
(define cleanup-sema (make-semaphore 1)) (define cleanup-sema (make-semaphore 1))
(define (cleanup-submission dir) (define (cleanup-submission dir)
@ -181,10 +180,10 @@
(let loop ([n (+ 20 (random 20))]) ; 10-20 minute delay (let loop ([n (+ 20 (random 20))]) ; 10-20 minute delay
(when (>= n 0) (when (>= n 0)
(let ([new (map (lambda (x) (let ([new (map (lambda (x)
(if (directory-exists? x) (if (directory-exists? x)
(directory-list x) (directory-list x)
null)) null))
'("active" "inactive"))]) '("active" "inactive"))])
(if (equal? new last-active/inactive) (if (equal? new last-active/inactive)
(begin (sleep 30) (loop (sub1 n))) (begin (sleep 30) (loop (sub1 n)))
(begin (set! last-active/inactive new) (begin (set! last-active/inactive new)
@ -660,57 +659,57 @@
(define session-count 0) (define session-count 0)
(parameterize ([error-display-handler (parameterize ([error-display-handler
(lambda (msg exn) (lambda (msg exn)
(LOG msg))]) (LOG msg))])
(run-server (run-server
PORT-NUMBER PORT-NUMBER
(lambda (r w) (lambda (r w)
(set! connection-num (add1 connection-num)) (set! connection-num (add1 connection-num))
(when ((current-memory-use) . > . SESSION-MEMORY-LIMIT) (when ((current-memory-use) . > . SESSION-MEMORY-LIMIT)
(collect-garbage)) (collect-garbage))
(parameterize ([current-session (begin (parameterize ([current-session (begin
(set! session-count (add1 session-count)) (set! session-count (add1 session-count))
session-count)]) session-count)])
(let-values ([(here there) (ssl-addresses r)]) (let-values ([(here there) (ssl-addresses r)])
(LOG "connect from ~a" there)) (LOG "connect from ~a" there))
(with-watcher (with-watcher
w w
(lambda (kill-watcher) (lambda (kill-watcher)
(let ([r-safe (make-limited-input-port r 2048)]) (let ([r-safe (make-limited-input-port r 2048)])
(write+flush w 'handin) (write+flush w 'handin)
;; Check protocol: ;; Check protocol:
(with-handlers ([exn:fail? (with-handlers ([exn:fail?
(lambda (exn) (lambda (exn)
(let ([msg (if (exn? exn) (let ([msg (if (exn? exn)
(exn-message exn) (exn-message exn)
(format "~e" exn))]) (format "~e" exn))])
(kill-watcher) (kill-watcher)
(LOG "ERROR: ~a" msg) (LOG "ERROR: ~a" msg)
(write+flush w msg) (write+flush w msg)
;; see note on close-output-port below ;; see note on close-output-port below
(close-output-port w)))]) (close-output-port w)))])
(let ([protocol (read r-safe)]) (let ([protocol (read r-safe)])
(if (eq? protocol 'ver1) (if (eq? protocol 'ver1)
(write+flush w 'ver1) (write+flush w 'ver1)
(error 'handin "unknown protocol: ~s" protocol))) (error 'handin "unknown protocol: ~s" protocol)))
(handle-connection r r-safe w) (handle-connection r r-safe w)
(LOG "normal exit") (LOG "normal exit")
(kill-watcher) (kill-watcher)
;; This close-output-port should not be necessary, and it's ;; This close-output-port should not be necessary, and it's
;; here due to a deficiency in the SLL binding. ;; here due to a deficiency in the SLL binding.
;; The problem is that a custodian shutdown of w is harsher ;; The problem is that a custodian shutdown of w is harsher
;; for SSL output than a normal close. A normal close ;; for SSL output than a normal close. A normal close
;; flushes an internal buffer that's not supposed to exist, while ;; flushes an internal buffer that's not supposed to exist, while
;; the shutdown gives up immediately. ;; the shutdown gives up immediately.
(close-output-port w))))))) (close-output-port w)))))))
#f ; `with-watcher' handles our timeouts #f ; `with-watcher' handles our timeouts
(lambda (exn) (lambda (exn)
(printf "~a\n" (if (exn? exn) (exn-message exn) exn))) (printf "~a\n" (if (exn? exn) (exn-message exn) exn)))
(lambda (port-k cnt reuse?) (lambda (port-k cnt reuse?)
(let ([l (ssl-listen port-k cnt #t)]) (let ([l (ssl-listen port-k cnt #t)])
(ssl-load-certificate-chain! l "server-cert.pem") (ssl-load-certificate-chain! l "server-cert.pem")
(ssl-load-private-key! l "private-key.pem") (ssl-load-private-key! l "private-key.pem")
l)) l))
ssl-close ssl-close
ssl-accept ssl-accept
ssl-accept/enable-break))) ssl-accept/enable-break)))

1
collects/handin-server/lock.ss → collects/handin-server/private/lock.ss
View File

@ -1,4 +1,3 @@
(module lock mzscheme (module lock mzscheme
(require (lib "list.ss")) (require (lib "list.ss"))

0
collects/handin-server/md5.ss → collects/handin-server/private/md5.ss
View File

252
collects/handin-server/status-web-root/servlets/status.ss
View File

@ -1,14 +1,13 @@
(module status mzscheme (module status mzscheme
(require (lib "file.ss") (require (lib "file.ss")
(lib "list.ss") (lib "list.ss")
(lib "string.ss") (lib "string.ss")
(lib "date.ss") (lib "date.ss")
(lib "unitsig.ss") (lib "unitsig.ss")
(lib "servlet-sig.ss" "web-server") (lib "servlet-sig.ss" "web-server")
(lib "response-structs.ss" "web-server") (lib "response-structs.ss" "web-server")
(lib "md5.ss" "handin-server") (lib "md5.ss" "handin-server" "private")
(lib "uri-codec.ss" "net")) (lib "uri-codec.ss" "net"))
(provide status-servlet) (provide status-servlet)
@ -20,8 +19,8 @@
(define master-password (define master-password
(with-handlers ([exn:fail? (lambda (x) #f)]) (with-handlers ([exn:fail? (lambda (x) #f)])
(cadr (assq 'master-password (cadr (assq 'master-password
(with-input-from-file (build-path handin-dir "config.ss") (with-input-from-file (build-path handin-dir "config.ss")
read))))) read)))))
(define get-user-data (define get-user-data
(let ([users-file (build-path handin-dir "users.ss")]) (let ([users-file (build-path handin-dir "users.ss")])
@ -44,7 +43,7 @@
(define (make-page title . body) (define (make-page title . body)
`(html (head (title ,title)) `(html (head (title ,title))
(body ([bgcolor "white"]) (p ((align "center")) ,title) ,@body))) (body ([bgcolor "white"]) (p ((align "center")) ,title) ,@body)))
(define status-servlet (define status-servlet
(unit/sig () (unit/sig ()
@ -60,14 +59,14 @@
(if (path? handin-dir) (path->string handin-dir) handin-dir) (if (path? handin-dir) (path->string handin-dir) handin-dir)
"/"))))) "/")))))
(define (make-k k tag) (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 (uri-encode (regexp-replace
handin-prefix-re handin-prefix-re
(if (path? tag) (path->string tag) tag) (if (path? tag) (path->string tag) tag)
"")))) ""))))
(define (select-k request) (define (select-k request)
(let ([a (assq 'tag (request-bindings request))]) (let ([a (assq 'tag (request-bindings request))])
(and a (cdr a)))) (and a (cdr a))))
;; `look-for' can be a username as a string (will find "bar+foo" for ;; `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 ;; "foo"), or a regexp that should match the whole directory name (used
@ -90,8 +89,8 @@
(ormap find-submission active/inactive-dirs)) (ormap find-submission active/inactive-dirs))
(define (handin-link k user hi) (define (handin-link k user hi)
(let* ([dir (find-hi-entry hi user)] (let* ([dir (find-hi-entry hi user)]
[l (and dir (with-handlers ([exn:fail? (lambda (x) null)]) [l (and dir (with-handlers ([exn:fail? (lambda (x) null)])
(parameterize ([current-directory dir]) (parameterize ([current-directory dir])
(sort (sort
(filter (lambda (f) (filter (lambda (f)
@ -99,27 +98,27 @@
(file-exists? f))) (file-exists? f)))
(map path->string (directory-list))) (map path->string (directory-list)))
string<?))))]) string<?))))])
(if (pair? l) (if (pair? l)
(cdr (cdr
(apply (apply
append append
(map (map
(lambda (i) `((br) ,i)) (lambda (i) `((br) ,i))
(map (lambda (f) (map (lambda (f)
(let ([hi (build-path dir f)]) (let ([hi (build-path dir f)])
`(font () `(font ()
(a ((href ,(make-k k hi))) ,f) (a ((href ,(make-k k hi))) ,f)
" (" " ("
,(date->string ,(date->string
(seconds->date (seconds->date
(file-or-directory-modify-seconds hi)) (file-or-directory-modify-seconds hi))
#t) #t)
")"))) ")")))
l)))) l))))
(list (format "No handins accepted so far for user ~s, assignment ~s" user hi))))) (list (format "No handins accepted so far for user ~s, assignment ~s" user hi)))))
(define (solution-link k hi) (define (solution-link k hi)
(let ([soln (find-hi-entry hi #rx"^solution")] (let ([soln (find-hi-entry hi #rx"^solution")]
[none `((i "---"))]) [none `((i "---"))])
(cond [(not soln) none] (cond [(not soln) none]
[(file-exists? soln) [(file-exists? soln)
@ -141,67 +140,67 @@
[else none]))) [else none])))
(define (handin-grade user hi) (define (handin-grade user hi)
(let* ([dir (find-hi-entry hi user)] (let* ([dir (find-hi-entry hi user)]
[grade (and dir [grade (and dir
(let ([filename (build-path dir "grade")]) (let ([filename (build-path dir "grade")])
(and (file-exists? filename) (and (file-exists? filename)
(with-input-from-file filename (with-input-from-file filename
(lambda () (lambda ()
(read-string (file-size filename)))))))]) (read-string (file-size filename)))))))])
(or grade "--"))) (or grade "--")))
(define (one-status-page status for-handin) (define (one-status-page status for-handin)
(let ([user (get-status status 'user (lambda () "???"))]) (let ([user (get-status status 'user (lambda () "???"))])
(let ([next (let ([next
(send/suspend (send/suspend
(lambda (k) (lambda (k)
(make-page (make-page
(format "User: ~a, Handin: ~a" user for-handin) (format "User: ~a, Handin: ~a" user for-handin)
`(p ,@(handin-link k user for-handin)) `(p ,@(handin-link k user for-handin))
`(p "Grade: " ,(handin-grade user for-handin)) `(p "Grade: " ,(handin-grade user for-handin))
`(p ,@(solution-link k for-handin)) `(p ,@(solution-link k for-handin))
`(p (a ((href ,(make-k k "allofthem"))) `(p (a ((href ,(make-k k "allofthem")))
,(format "All handins for ~a" user))))))]) ,(format "All handins for ~a" user))))))])
(let ([tag (select-k next)]) (let ([tag (select-k next)])
(if (string=? tag "allofthem") (if (string=? tag "allofthem")
(all-status-page status) (all-status-page status)
(download status tag)))))) (download status tag))))))
(define re:base #rx"^([a-zA-Z]*)([0-9]+)") (define re:base #rx"^([a-zA-Z]*)([0-9]+)")
(define (all-status-page status) (define (all-status-page status)
(let ([l (sort (let ([l (sort
(map path->string (map path->string
(append (directory-list active-dir) (append (directory-list active-dir)
(with-handlers ([exn:fail? (lambda (x) null)]) (with-handlers ([exn:fail? (lambda (x) null)])
(directory-list inactive-dir)))) (directory-list inactive-dir))))
(lambda (a b) (lambda (a b)
(let ([am (regexp-match re:base a)] (let ([am (regexp-match re:base a)]
[bm (regexp-match re:base b)]) [bm (regexp-match re:base b)])
(if (and am bm (if (and am bm
(string=? (cadr am) (cadr bm))) (string=? (cadr am) (cadr bm)))
(or (< (string->number (caddr am)) (string->number (caddr bm))) (or (< (string->number (caddr am)) (string->number (caddr bm)))
(string<? a b)) (string<? a b))
(string<? a b)))))] (string<? a b)))))]
[user (get-status status 'user (lambda () "???"))]) [user (get-status status 'user (lambda () "???"))])
(let ([next (let ([next
(send/suspend (send/suspend
(lambda (k) (lambda (k)
(define (header text) (define (header text)
`(td ((bgcolor "#f0f0f0")) (big (strong ,text)))) `(td ((bgcolor "#f0f0f0")) (big (strong ,text))))
(make-page (make-page
(format "All Handins for ~a" user) (format "All Handins for ~a" user)
`(table ([bgcolor "#ddddff"] [cellpadding "6"] [align "center"]) `(table ([bgcolor "#ddddff"] [cellpadding "6"] [align "center"])
(tr () ,@(map header '(nbsp "Files" "Grade" "Solution"))) (tr () ,@(map header '(nbsp "Files" "Grade" "Solution")))
,@(map (lambda (hi) ,@(map (lambda (hi)
`(tr ([valign "top"]) `(tr ([valign "top"])
,(header hi) ,(header hi)
(td ([bgcolor "white"]) ,@(handin-link k user hi)) (td ([bgcolor "white"]) ,@(handin-link k user hi))
(td ([bgcolor "white"] (align "right")) ,(handin-grade user hi)) (td ([bgcolor "white"] (align "right")) ,(handin-grade user hi))
(td ([bgcolor "white"]) ,@(solution-link k hi)))) (td ([bgcolor "white"]) ,@(solution-link k hi))))
l)))))]) l)))))])
(let ([tag (select-k next)]) (let ([tag (select-k next)])
(download status tag))))) (download status tag)))))
(define (download status tag) (define (download status tag)
(define (check path elts) (define (check path elts)
@ -222,78 +221,77 @@
[else #f]) [else #f])
(loop base (cdr elts))))))) (loop base (cdr elts)))))))
(define file (build-path handin-dir tag)) (define file (build-path handin-dir tag))
(with-handlers ([exn:fail? (with-handlers ([exn:fail?
(lambda (exn) (lambda (exn)
(make-page "Error" "Illegal file access"))]) (make-page "Error" "Illegal file access"))])
(let ([who (get-status status 'user (lambda () "???"))]) (let ([who (get-status status 'user (lambda () "???"))])
;; Make sure the user is allowed to read the requested file: ;; Make sure the user is allowed to read the requested file:
(or (check file `(* ,who *)) (or (check file `(* ,who *))
(check file `(* #rx"^solution")) (check file `(* #rx"^solution"))
(check file `(* #rx"^solution" *)) (check file `(* #rx"^solution" *))
(error "Boom!"))) (error "Boom!")))
;; Return the downloaded file ;; Return the downloaded file
(let* ([data (with-input-from-file file (let* ([data (with-input-from-file file
(lambda () (read-bytes (file-size file))))] (lambda () (read-bytes (file-size file))))]
[html? (regexp-match #rx"[.]html?$" (string-foldcase tag))] [html? (regexp-match #rx"[.]html?$" (string-foldcase tag))]
[wxme? (regexp-match #rx#"^WXME" data)]) [wxme? (regexp-match #rx#"^WXME" data)])
(make-response/full 200 "Okay" (current-seconds) (make-response/full 200 "Okay" (current-seconds)
(cond [html? #"text/html"] (cond [html? #"text/html"]
[wxme? #"application/data"] [wxme? #"application/data"]
[else #"text/plain"]) [else #"text/plain"])
`((Content-Length . ,(number->string (bytes-length data))) `((Content-Length . ,(number->string (bytes-length data)))
,@(if wxme? ,@(if wxme?
`((Content-Disposition `((Content-Disposition
. .
,(format "attachment; filename=~s" ,(format "attachment; filename=~s"
(let-values ([(base name dir?) (split-path file)]) (let-values ([(base name dir?) (split-path file)])
(path->string name))))) (path->string name)))))
'())) '()))
(list data))))) (list data)))))
(define (status-page status for-handin) (define (status-page status for-handin)
(if for-handin (if for-handin
(one-status-page status for-handin) (one-status-page status for-handin)
(all-status-page status))) (all-status-page status)))
(define (login-page status for-handin errmsg) (define (login-page status for-handin errmsg)
(let ([request (let ([request
(send/suspend (send/suspend
(lambda (k) (lambda (k)
(make-page (make-page
"Handin Status Login" "Handin Status Login"
`(form ([action ,k] [method "post"]) `(form ([action ,k] [method "post"])
(table (table
((align "center")) ((align "center"))
(tr (td ((colspan "2") (align "center")) (tr (td ((colspan "2") (align "center"))
(font ((color "red")) (font ((color "red"))
,(if errmsg ,(if errmsg
errmsg errmsg
'nbsp)))) 'nbsp))))
(tr (td "Username") (tr (td "Username")
(td (input ([type "text"] [name "user"] [size "20"] [value ""])))) (td (input ([type "text"] [name "user"] [size "20"] [value ""]))))
(tr (td nbsp)) (tr (td nbsp))
(tr (td "Password") (tr (td "Password")
(td (input ([type "password"] [name "passwd"] [size "20"] [value ""])))) (td (input ([type "password"] [name "passwd"] [size "20"] [value ""]))))
(td ((colspan "2") (align "center")) (td ((colspan "2") (align "center"))
(input ([type "submit"] [name "post"] [value "Login"]))))))))]) (input ([type "submit"] [name "post"] [value "Login"]))))))))])
(let ([user (clean-str (cdr (assq 'user (request-bindings request))))] (let ([user (clean-str (cdr (assq 'user (request-bindings request))))]
[passwd (cdr (assq 'passwd (request-bindings request)))]) [passwd (cdr (assq 'passwd (request-bindings request)))])
(let ([user-data (get-user-data user)]) (let ([user-data (get-user-data user)])
(cond (cond
[(and user-data [(and user-data
(string? passwd) (string? passwd)
(let ([pw (md5 passwd)]) (let ([pw (md5 passwd)])
(or (equal? pw (car user-data)) (or (equal? pw (car user-data))
(equal? pw master-password)))) (equal? pw master-password))))
(status-page (update-status status 'user user) for-handin)] (status-page (update-status status 'user user) for-handin)]
[else [else
(login-page status for-handin "Bad username or password")]))))) (login-page status for-handin "Bad username or password")])))))
(let ([a (assq 'handin (request-bindings initial-request))]) (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) (require status)
status-servlet status-servlet

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

@ -1,14 +1,13 @@
(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 "web-server-unit.ss" "web-server")
(lib "sig.ss" "web-server") (lib "sig.ss" "web-server")
(lib "configuration.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"))
(provide serve-status) (provide serve-status)
@ -24,61 +23,54 @@
(define config (define config
`((port ,port-no) `((port ,port-no)
(max-waiting 40) (max-waiting 40)
(initial-connection-timeout 30) (initial-connection-timeout 30)
(default-host-table (default-host-table
(host-table (host-table
(default-indices "index.html") (default-indices "index.html")
(log-format parenthesized-default) (log-format parenthesized-default)
(messages (messages
(servlet-message "servlet-error.html") (servlet-message "servlet-error.html")
(authentication-message "forbidden.html") (authentication-message "forbidden.html")
(servlets-refreshed "servlet-refresh.html") (servlets-refreshed "servlet-refresh.html")
(passwords-refreshed "passwords-refresh.html") (passwords-refreshed "passwords-refresh.html")
(file-not-found-message "not-found.html") (file-not-found-message "not-found.html")
(protocol-message "protocol-error.html") (protocol-message "protocol-error.html")
(collect-garbage "collect-garbage.html")) (collect-garbage "collect-garbage.html"))
(timeouts (timeouts
(default-servlet-timeout 120) (default-servlet-timeout 120)
(password-connection-timeout 300) (password-connection-timeout 300)
(servlet-connection-timeout 86400) (servlet-connection-timeout 86400)
(file-per-byte-connection-timeout 1/20) (file-per-byte-connection-timeout 1/20)
(file-base-connection-timeout 30)) (file-base-connection-timeout 30))
(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 ,(path->string (build-path (current-directory) "web-status-log.ss")))
(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")
"default-web-root" "default-web-root"
"mime.types"))) "mime.types")))
(password-authentication ,(path->string (build-path (current-directory) "web-status-passwords")))))) (password-authentication ,(path->string (build-path (current-directory) "web-status-passwords"))))))
(virtual-host-table))) (virtual-host-table)))
(define config@ (define config@
(let ([file (make-temporary-file)]) (let ([file (make-temporary-file)])
(with-output-to-file file (with-output-to-file file (lambda () (write config)) 'truncate)
(lambda () (begin0 (load-configuration file) (delete-file file))))
(write config))
'truncate)
(begin0
(load-configuration file)
(delete-file file))))
(define-values/invoke-unit/sig web-server^ (define-values/invoke-unit/sig web-server^
(compound-unit/sig (compound-unit/sig
(import) (import)
(link (link [T : net:tcp^ ((make-ssl-tcp@
[T : net:tcp^ ((make-ssl-tcp@ "server-cert.pem" "private-key.pem" #f #f
"server-cert.pem" "private-key.pem" #f #f #f #f #f))]
#f #f #f))] [C : web-config^ (config@)]
[C : web-config^ (config@)] [S : web-server^ (web-server@ T C)])
[S : web-server^ (web-server@ T C)])
(export (open S))) (export (open S)))
#f) #f)
(putenv "HANDIN_SERVER_DIR" (path->string (current-directory))) (putenv "HANDIN_SERVER_DIR" (path->string (current-directory)))
(serve))) (serve)))