269 lines
8.0 KiB
Scheme
269 lines
8.0 KiB
Scheme
|
|
(module status mzscheme
|
|
(require (lib "file.ss")
|
|
(lib "list.ss")
|
|
(lib "date.ss")
|
|
(lib "unitsig.ss")
|
|
(lib "servlet-sig.ss" "web-server")
|
|
(lib "md5.ss" "handin-server"))
|
|
|
|
(provide status-servlet)
|
|
|
|
(define TOPICS-PER-PAGE 25)
|
|
|
|
(define handin-dir (current-directory))
|
|
(define active-dir (build-path handin-dir "active"))
|
|
(define inactive-dir (build-path handin-dir "inactive"))
|
|
|
|
(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 (clean-str s)
|
|
(regexp-replace
|
|
" *$"
|
|
(regexp-replace "^ *" 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 (make-page title . body)
|
|
`(html (head (title ,title))
|
|
(body ([bgcolor "white"])
|
|
(p ((align "center"))
|
|
,title)
|
|
,@body)))
|
|
|
|
(define status-servlet
|
|
(unit/sig ()
|
|
(import servlet^)
|
|
|
|
(define (make-k k tag)
|
|
(format "~a~atag=~a" k
|
|
(if (regexp-match #rx"^[^#]*[?]" k)
|
|
"&"
|
|
"?")
|
|
tag))
|
|
(define (select-k request)
|
|
(let ([a (assq 'tag (request-bindings request))])
|
|
(and a (cdr a))))
|
|
(define (link-tag k tag label)
|
|
`(a ((href ,(make-k k tag)))
|
|
,label))
|
|
|
|
(define (handin-link k user hi)
|
|
(let* ([dir (build-path (if (directory-exists? (build-path "active" hi))
|
|
"active"
|
|
"inactive")
|
|
hi
|
|
user)]
|
|
[l (with-handlers ([exn:fail? (lambda (x) null)])
|
|
(parameterize ([current-directory dir])
|
|
(filter (lambda (f)
|
|
(and (file-exists? f) (not (equal? f "grade"))))
|
|
(directory-list))))])
|
|
(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-dir (build-path (if (directory-exists? (build-path "active" hi))
|
|
"active"
|
|
"inactive")
|
|
hi
|
|
"solution")]
|
|
[soln (let ([f (build-path soln-dir (format "~asol.scm" hi))])
|
|
(if (or (file-exists? f)
|
|
(not (directory-exists? soln-dir)))
|
|
f
|
|
(let ([l (directory-list soln-dir)])
|
|
(if (= 1 (length l))
|
|
(build-path soln-dir (car l))
|
|
f))))])
|
|
(if (file-exists? soln)
|
|
`((a ((href ,(make-k k soln)))
|
|
"Solution"))
|
|
`((i "Solution not available")))))
|
|
|
|
(define (handin-grade user hi)
|
|
(let* ([dir (build-path (if (directory-exists? (build-path "active" hi))
|
|
"active"
|
|
"inactive")
|
|
hi
|
|
user)]
|
|
[grade (let ([filename (build-path dir "grade")])
|
|
(and (file-exists? filename)
|
|
(with-input-from-file filename
|
|
(lambda () (read-string (file-size filename))))))])
|
|
(if grade
|
|
grade
|
|
"no grade so far")))
|
|
|
|
(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))))))
|
|
|
|
(define re:base "^([a-zA-Z]*)([0-9]+)")
|
|
|
|
(define (all-status-page status)
|
|
(let ([l (quicksort
|
|
(append (directory-list "active")
|
|
(with-handlers ([exn:fail? (lambda (x) null)])
|
|
(directory-list "inactive")))
|
|
(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)))
|
|
(< (string->number (caddr am)) (string->number (caddr bm)))
|
|
(string<? a b)))))]
|
|
[user (get-status status 'user (lambda () "???"))])
|
|
(let ([next
|
|
(send/suspend
|
|
(lambda (k)
|
|
(make-page
|
|
(format "All Handins for ~a" user)
|
|
`(table
|
|
((bgcolor "#ddddff"))
|
|
,@(map (lambda (hi)
|
|
`(tr (td ((bgcolor "white")) ,hi)
|
|
(td ((bgcolor "white")) ,@(handin-link k user hi))
|
|
(td ((bgcolor "white")) ,(handin-grade user hi))
|
|
(td ((bgcolor "white")) ,@(solution-link k hi))))
|
|
l)))))])
|
|
(let ([tag (select-k next)])
|
|
(download status tag)))))
|
|
|
|
(define (download status tag)
|
|
;; Make sure the user is allowed to read the requested file:
|
|
(with-handlers ([exn:fail?
|
|
(lambda (exn)
|
|
(make-page "Error" "Illegal file access"))])
|
|
(let ([who (get-status status 'user (lambda () "???"))])
|
|
(let-values ([(base name dir?) (split-path tag)])
|
|
;; Any file name is ok...
|
|
(unless (string? name) (error "bad"))
|
|
(let-values ([(base name dir?) (split-path base)])
|
|
;; Directory must be user or "solution"
|
|
(unless (or (string=? name who)
|
|
(string=? name "solution"))
|
|
(error "bad"))
|
|
;; Any dir name is ok...
|
|
(let-values ([(base name dir?) (split-path base)])
|
|
(unless (string? name) (error "bad"))
|
|
;; Base must be active or inactive
|
|
(let-values ([(base name dir?) (split-path base)])
|
|
(unless (or (string=? name "active")
|
|
(string=? name "inactive"))
|
|
(error "bad"))
|
|
;; No more to path
|
|
(unless (eq? base 'relative)
|
|
(error "bad")))))))
|
|
;; Return the downloaded file
|
|
(let ([data (with-input-from-file tag
|
|
(lambda ()
|
|
(read-string (file-size tag))))])
|
|
(make-response/full 200 "Okay"
|
|
(current-seconds)
|
|
"application/data"
|
|
`((Content-length . ,(string-length data))
|
|
(Content-disposition
|
|
.
|
|
,(format "attachment; filename=~s"
|
|
(let-values ([(base name dir?) (split-path tag)])
|
|
name))))
|
|
(list data)))))
|
|
|
|
(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"))
|
|
,(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-preference (string->symbol user)
|
|
(lambda () #f)
|
|
#f
|
|
"users.ss")])
|
|
(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))
|
|
|
|
)))
|
|
|
|
(require status)
|
|
status-servlet
|
|
|