some reformatting and reorganization
svn: r4828
This commit is contained in:
Eli Barzilay
parent
dffa753378
commit
fd4627095c
|
|
@ -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<?)]
|
||||
[dir (and (pair? dir) (car dir))])
|
||||
string<?)]
|
||||
[dir (and (pair? dir) (car dir))])
|
||||
(when dir
|
||||
(unless (member dir SUCCESS-GOOD)
|
||||
(LOG "*** USING AN UNEXPECTED SUBMISSION DIRECTORY: ~a"
|
||||
(build-path (current-directory) dir)))
|
||||
;; We have a submission directory -- copy all newer things (extra
|
||||
;; things that exist in the main submission directory but not in
|
||||
;; SUCCESS, or things that are newer in the main submission
|
||||
;; directory are kept (but subdirs in SUCCESS will are copied as
|
||||
;; is))
|
||||
(for-each
|
||||
(lambda (f)
|
||||
(define dir/f (build-path dir f))
|
||||
(cond [(not (or (file-exists? f) (directory-exists? f)))
|
||||
;; f is in dir but not in the working directory
|
||||
(copy-directory/files dir/f f)]
|
||||
[(or (<= (file-or-directory-modify-seconds f)
|
||||
(file-or-directory-modify-seconds dir/f))
|
||||
(and (file-exists? f) (file-exists? dir/f)
|
||||
(not (= (file-size f) (file-size dir/f)))))
|
||||
;; f is newer in dir than in the working directory
|
||||
(delete-directory/files f)
|
||||
(copy-directory/files dir/f f)]))
|
||||
(directory-list dir)))))
|
||||
(unless (member dir SUCCESS-GOOD)
|
||||
(LOG "*** USING AN UNEXPECTED SUBMISSION DIRECTORY: ~a"
|
||||
(build-path (current-directory) dir)))
|
||||
;; We have a submission directory -- copy all newer things (extra
|
||||
;; things that exist in the main submission directory but not in
|
||||
;; SUCCESS, or things that are newer in the main submission
|
||||
;; directory are kept (but subdirs in SUCCESS will are copied as
|
||||
;; is))
|
||||
(for-each
|
||||
(lambda (f)
|
||||
(define dir/f (build-path dir f))
|
||||
(cond [(not (or (file-exists? f) (directory-exists? f)))
|
||||
;; f is in dir but not in the working directory
|
||||
(copy-directory/files dir/f f)]
|
||||
[(or (<= (file-or-directory-modify-seconds f)
|
||||
(file-or-directory-modify-seconds dir/f))
|
||||
(and (file-exists? f) (file-exists? dir/f)
|
||||
(not (= (file-size f) (file-size dir/f)))))
|
||||
;; f is newer in dir than in the working directory
|
||||
(delete-directory/files f)
|
||||
(copy-directory/files dir/f f)]))
|
||||
(directory-list dir)))))
|
||||
|
||||
(define cleanup-sema (make-semaphore 1))
|
||||
(define (cleanup-submission dir)
|
||||
|
|
@ -180,11 +179,11 @@
|
|||
(let loop ()
|
||||
(let loop ([n (+ 20 (random 20))]) ; 10-20 minute delay
|
||||
(when (>= 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)))
|
||||
|
|
|
|||
|
|
@ -1,4 +1,3 @@
|
|||
|
||||
(module lock mzscheme
|
||||
(require (lib "list.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)))
|
||||
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)))))
|
||||
(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)))
|
||||
(string<? a b))
|
||||
(string<? a b)))))]
|
||||
[user (get-status status 'user (lambda () "???"))])
|
||||
(let ([next
|
||||
(send/suspend
|
||||
(lambda (k)
|
||||
(string<? a b)))))]
|
||||
[user (get-status status 'user (lambda () "???"))])
|
||||
(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"])
|
||||
(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"])
|
||||
,@(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)))))
|
||||
(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 status tag)
|
||||
(define (check path elts)
|
||||
|
|
@ -222,78 +221,77 @@
|
|||
[else #f])
|
||||
(loop base (cdr elts)))))))
|
||||
(define file (build-path handin-dir tag))
|
||||
(with-handlers ([exn:fail?
|
||||
(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:
|
||||
;; 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!")))
|
||||
;; Return the downloaded file
|
||||
(let* ([data (with-input-from-file 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"]
|
||||
(make-response/full 200 "Okay" (current-seconds)
|
||||
(cond [html? #"text/html"]
|
||||
[wxme? #"application/data"]
|
||||
[else #"text/plain"])
|
||||
`((Content-Length . ,(number->string (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
|
||||
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user