improving code, adding an identifier to log messages, closer to new unit code
svn: r5017
This commit is contained in:
Eli Barzilay
parent
675d3818d9
commit
cdabc3a38d
|
|
@ -464,8 +464,9 @@ sub-directories:
|
||||||
(id time-str msg-str)
|
(id time-str msg-str)
|
||||||
[<id>|<time>] <msg>
|
[<id>|<time>] <msg>
|
||||||
where `<id>' is an integer representing the connection (numbered
|
where `<id>' is an integer representing the connection (numbered
|
||||||
consecutively from 1 when the server starts) or "-" for a message
|
consecutively from 1 when the server starts), "-" for a message
|
||||||
without a connection.
|
without a connection, and "wN" for a message from the status
|
||||||
|
servlet.
|
||||||
|
|
||||||
* "[in]active/<assignment>/<user>/<filename>" (if submitted) --- the
|
* "[in]active/<assignment>/<user>/<filename>" (if submitted) --- the
|
||||||
most recent submission for <assignment> by <user> where <filename>
|
most recent submission for <assignment> by <user> where <filename>
|
||||||
|
|
|
||||||
|
|
@ -3,298 +3,272 @@
|
||||||
(lib "list.ss")
|
(lib "list.ss")
|
||||||
(lib "string.ss")
|
(lib "string.ss")
|
||||||
(lib "date.ss")
|
(lib "date.ss")
|
||||||
(lib "unitsig.ss")
|
(lib "servlet.ss" "web-server")
|
||||||
(lib "servlet-sig.ss" "web-server")
|
|
||||||
(lib "response-structs.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 "logger.ss" "handin-server" "private")
|
||||||
(lib "md5.ss" "handin-server" "private")
|
(lib "config.ss" "handin-server" "private"))
|
||||||
(lib "uri-codec.ss" "net"))
|
|
||||||
|
|
||||||
(provide status-servlet)
|
(define active-dir (build-path server-dir "active"))
|
||||||
|
(define inactive-dir (build-path server-dir "inactive"))
|
||||||
(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/inactive-dirs (list active-dir inactive-dir))
|
(define active/inactive-dirs (list active-dir inactive-dir))
|
||||||
|
|
||||||
(define master-password
|
(define master-password (get-config '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 get-user-data
|
(define get-user-data
|
||||||
(let ([users-file (build-path handin-dir "users.ss")])
|
(let ([users-file (build-path server-dir "users.ss")])
|
||||||
(lambda (user)
|
(lambda (user)
|
||||||
(get-preference (string->symbol user) (lambda () #f) #f users-file))))
|
(get-preference (string->symbol user) (lambda () #f) #f users-file))))
|
||||||
|
|
||||||
(define (clean-str s)
|
(define (clean-str s)
|
||||||
(regexp-replace #rx" *$" (regexp-replace #rx"^ *" s "") ""))
|
(regexp-replace #rx" *$" (regexp-replace #rx"^ *" s "") ""))
|
||||||
|
|
||||||
(define (update-status status tag val)
|
(define (aget alist key)
|
||||||
(let loop ([status status])
|
(cond [(assq key alist) => cdr] [else #f]))
|
||||||
(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)
|
(define (make-page title . body)
|
||||||
`(html (head (title ,title))
|
`(html (head (title ,title))
|
||||||
(body ([bgcolor "white"]) (p ((align "center")) ,title) ,@body)))
|
(body ([bgcolor "white"]) (h1 ((align "center")) ,title) ,@body)))
|
||||||
|
|
||||||
(define status-servlet
|
(define handin-prefix-re
|
||||||
(unit/sig ()
|
;; a regexp that turns a full path to a server-dir relative path
|
||||||
(import servlet^)
|
(regexp
|
||||||
|
(string-append
|
||||||
|
"^" (regexp-quote
|
||||||
|
(regexp-replace
|
||||||
|
#rx"/?$"
|
||||||
|
(if (path? server-dir) (path->string server-dir) server-dir)
|
||||||
|
"/")))))
|
||||||
|
|
||||||
(define handin-prefix-re
|
(define (make-k k tag)
|
||||||
;; a regexp that turns a full path to a handin-dir relative path
|
(format "~a~atag=~a" k (if (regexp-match #rx"^[^#]*[?]" k) "&" "?")
|
||||||
(regexp
|
(uri-encode (regexp-replace handin-prefix-re
|
||||||
(string-append
|
(if (path? tag) (path->string tag) tag)
|
||||||
"^" (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))))
|
|
||||||
|
|
||||||
;; `look-for' can be a username as a string (will find "bar+foo" for
|
(define (select-k request)
|
||||||
;; "foo"), or a regexp that should match the whole directory name (used
|
(aget (request-bindings request) 'tag))
|
||||||
;; 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 (handin-link k user hi)
|
;; `look-for' can be a username as a string (will find "bar+foo" for "foo"),
|
||||||
(let* ([dir (find-hi-entry hi user)]
|
;; or a regexp that should match the whole directory name (used with
|
||||||
[l (and dir (with-handlers ([exn:fail? (lambda (x) null)])
|
;; "^solution" below)
|
||||||
(parameterize ([current-directory dir])
|
(define (find-hi-entry hi look-for)
|
||||||
(sort
|
(define (find-submission top)
|
||||||
(filter (lambda (f)
|
(let ([dir (build-path top hi)])
|
||||||
(and (not (equal? f "grade"))
|
(and (directory-exists? dir)
|
||||||
(file-exists? f)))
|
(ormap
|
||||||
(map path->string (directory-list)))
|
(lambda (d)
|
||||||
string<?))))])
|
(let ([d (path->string d)])
|
||||||
(if (pair? l)
|
(and (cond [(string? look-for)
|
||||||
(cdr
|
(member look-for (regexp-split #rx" *[+] *" d))]
|
||||||
(apply
|
[(regexp? look-for) (regexp-match look-for d)]
|
||||||
append
|
[else (error 'find-hi-entry
|
||||||
(map
|
"internal error: ~e" look-for)])
|
||||||
(lambda (i) `((br) ,i))
|
(build-path dir d))))
|
||||||
(map (lambda (f)
|
(directory-list dir)))))
|
||||||
(let ([hi (build-path dir f)])
|
(ormap find-submission active/inactive-dirs))
|
||||||
`(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)
|
(define (handin-link k user hi)
|
||||||
(let ([soln (find-hi-entry hi #rx"^solution")]
|
(let* ([dir (find-hi-entry hi user)]
|
||||||
[none `((i "---"))])
|
[l (and dir (with-handlers ([exn:fail? (lambda (x) null)])
|
||||||
(cond [(not soln) none]
|
(parameterize ([current-directory dir])
|
||||||
[(file-exists? soln)
|
(sort (filter (lambda (f)
|
||||||
`((a ((href ,(make-k k soln))) "Solution"))]
|
(and (not (equal? f "grade"))
|
||||||
[(directory-exists? soln)
|
(file-exists? f)))
|
||||||
(parameterize ([current-directory soln])
|
(map path->string (directory-list)))
|
||||||
(let ([files (sort (map path->string
|
string<?))))])
|
||||||
(filter file-exists?
|
(if (pair? l)
|
||||||
(directory-list)))
|
(cdr (apply append
|
||||||
string<?)])
|
(map (lambda (i) `((br) ,i))
|
||||||
(if (null? files)
|
(map (lambda (f)
|
||||||
none
|
(let ([hi (build-path dir f)])
|
||||||
(apply append
|
`(font ()
|
||||||
(map (lambda (f)
|
(a ([href ,(make-k k hi)]) ,f)
|
||||||
`((a ((href ,(make-k k (build-path soln f))))
|
" ("
|
||||||
(tt ,f))
|
,(date->string
|
||||||
(br)))
|
(seconds->date
|
||||||
files)))))]
|
(file-or-directory-modify-seconds hi))
|
||||||
[else none])))
|
#t)
|
||||||
|
")")))
|
||||||
|
l))))
|
||||||
|
(list (format "No handins accepted so far for user ~s, assignment ~s"
|
||||||
|
user hi)))))
|
||||||
|
|
||||||
(define (handin-grade user hi)
|
(define (solution-link k hi)
|
||||||
(let* ([dir (find-hi-entry hi user)]
|
(let ([soln (find-hi-entry hi #rx"^solution")]
|
||||||
[grade (and dir
|
[none `((i "---"))])
|
||||||
(let ([filename (build-path dir "grade")])
|
(cond [(not soln) none]
|
||||||
(and (file-exists? filename)
|
[(file-exists? soln)
|
||||||
(with-input-from-file filename
|
`((a ((href ,(make-k k soln))) "Solution"))]
|
||||||
(lambda ()
|
[(directory-exists? soln)
|
||||||
(read-string (file-size filename)))))))])
|
(parameterize ([current-directory soln])
|
||||||
(or grade "--")))
|
(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)
|
(define (handin-grade user hi)
|
||||||
(let ([user (get-status status 'user (lambda () "???"))])
|
(let* ([dir (find-hi-entry hi user)]
|
||||||
(log-line "Status access: ~s" user)
|
[grade (and dir
|
||||||
(let ([next
|
(let ([filename (build-path dir "grade")])
|
||||||
(send/suspend
|
(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)
|
(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))))))])
|
[tag (select-k next)])
|
||||||
(let ([tag (select-k next)])
|
(if (string=? tag "allofthem")
|
||||||
(if (string=? tag "allofthem")
|
(all-status-page user)
|
||||||
(all-status-page status)
|
(download user 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 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)
|
(define (download who tag)
|
||||||
(let ([l (sort
|
(define (check path elts)
|
||||||
(map path->string
|
(let loop ([path path] [elts (reverse elts)])
|
||||||
(append (directory-list active-dir)
|
(let*-values ([(base name dir?) (split-path path)]
|
||||||
(with-handlers ([exn:fail? (lambda (x) null)])
|
[(name) (path->string name)]
|
||||||
(directory-list inactive-dir))))
|
[(check) (and (pair? elts) (car elts))])
|
||||||
(lambda (a b)
|
(if (null? elts)
|
||||||
(let ([am (regexp-match re:base a)]
|
;; must be rooted in active/inactive (why build-path instead of
|
||||||
[bm (regexp-match re:base b)])
|
;; using `path'? -- because path will have a trailing slash)
|
||||||
(if (and am bm
|
(member (build-path base name) active/inactive-dirs)
|
||||||
(string=? (cadr am) (cadr bm)))
|
(and (cond [(eq? '* check) #t]
|
||||||
(or (< (string->number (caddr am)) (string->number (caddr bm)))
|
[(regexp? check) (regexp-match check name)]
|
||||||
(string<? a b))
|
[(string? check)
|
||||||
(string<? a b)))))]
|
(or (equal? name check)
|
||||||
[user (get-status status 'user (lambda () "???"))])
|
(member check (regexp-split #rx" *[+] *" name)))]
|
||||||
(log-line "Status access: ~s" user)
|
[else #f])
|
||||||
(let ([next
|
(loop base (cdr elts)))))))
|
||||||
(send/suspend
|
(define file (build-path server-dir tag))
|
||||||
(lambda (k)
|
(with-handlers ([exn:fail? (lambda (exn)
|
||||||
(define (header text)
|
(make-page "Error" "Illegal file access"))])
|
||||||
`(td ((bgcolor "#f0f0f0")) (big (strong ,text))))
|
;; Make sure the user is allowed to read the requested file:
|
||||||
(make-page
|
(or (check file `(* ,who *))
|
||||||
(format "All Handins for ~a" user)
|
(check file `(* #rx"^solution"))
|
||||||
`(table ([bgcolor "#ddddff"] [cellpadding "6"] [align "center"])
|
(check file `(* #rx"^solution" *))
|
||||||
(tr () ,@(map header '(nbsp "Files" "Grade" "Solution")))
|
(error "Boom!"))
|
||||||
,@(map (lambda (hi)
|
(log-line "Status file-get: ~s ~a" who file)
|
||||||
`(tr ([valign "top"])
|
;; Return the downloaded file
|
||||||
,(header hi)
|
(let* ([data (with-input-from-file file
|
||||||
(td ([bgcolor "white"]) ,@(handin-link k user hi))
|
(lambda () (read-bytes (file-size file))))]
|
||||||
(td ([bgcolor "white"] (align "right")) ,(handin-grade user hi))
|
[html? (regexp-match #rx"[.]html?$" (string-foldcase tag))]
|
||||||
(td ([bgcolor "white"]) ,@(solution-link k hi))))
|
[wxme? (regexp-match #rx#"^WXME" data)])
|
||||||
l)))))])
|
(make-response/full 200 "Okay" (current-seconds)
|
||||||
(let ([tag (select-k next)])
|
(cond [html? #"text/html"]
|
||||||
(download status tag)))))
|
[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 (status-page user for-handin)
|
||||||
(define (check path elts)
|
(log-line "Status access: ~s" user)
|
||||||
(let loop ([path path] [elts (reverse elts)])
|
(if for-handin
|
||||||
(let*-values ([(base name dir?) (split-path path)]
|
(one-status-page user for-handin)
|
||||||
[(name) (path->string name)]
|
(all-status-page user)))
|
||||||
[(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 status for-handin)
|
(define (login-page status for-handin errmsg)
|
||||||
(if for-handin
|
(let* ([request
|
||||||
(one-status-page status for-handin)
|
(send/suspend
|
||||||
(all-status-page status)))
|
(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)
|
(define web-counter
|
||||||
(let ([request
|
(let ([sema (make-semaphore 1)]
|
||||||
(send/suspend
|
[count 0])
|
||||||
(lambda (k)
|
(lambda ()
|
||||||
(make-page
|
(dynamic-wind
|
||||||
"Handin Status Login"
|
(lambda () (semaphore-wait sema))
|
||||||
`(form ([action ,k] [method "post"])
|
(lambda () (set! count (add1 count)) (format "w~a" count))
|
||||||
(table
|
(lambda () (semaphore-post sema))))))
|
||||||
((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))])
|
(define (start initial-request)
|
||||||
(login-page null (and a (cdr a)) #f))
|
(parameterize ([current-session (web-counter)])
|
||||||
|
(login-page null (aget (request-bindings initial-request) 'handin) #f)))
|
||||||
|
|
||||||
)))
|
(provide interface-version timeout start)
|
||||||
|
(define interface-version 'v1)
|
||||||
(require status)
|
(define timeout 180)
|
||||||
status-servlet
|
)
|
||||||
|
|
|
||||||
|
|
@ -54,18 +54,15 @@
|
||||||
(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)))
|
||||||
|
|
||||||
#; ; 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@
|
(define config@
|
||||||
(load-configuration-sexpr
|
(load-configuration-sexpr
|
||||||
web-dir config
|
web-dir config
|
||||||
#:make-servlet-namespace
|
#:make-servlet-namespace
|
||||||
(make-make-servlet-namespace
|
(make-make-servlet-namespace
|
||||||
#:to-be-copied-module-specs
|
#: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^
|
(define-values/invoke-unit/sig web-server^
|
||||||
(compound-unit/sig
|
(compound-unit/sig
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user