handin server: add support for HTTPS uploads (when enabled)
This commit is contained in:
parent
8b38c8e933
commit
e361acae0b
|
@ -64,6 +64,9 @@
|
|||
(define (path p) (path->complete-path p server-dir))
|
||||
(define (path/false p) (and p (path p)))
|
||||
(define (path-list l) (map path l))
|
||||
(define (maybe-strs l) (and l
|
||||
(pair? l)
|
||||
(map string->bytes/utf-8 l)))
|
||||
|
||||
(define (config-default+translate which)
|
||||
(case which
|
||||
|
@ -82,6 +85,7 @@
|
|||
[(username-case-sensitive) (values #f id )]
|
||||
[(allow-new-users) (values #f id )]
|
||||
[(allow-change-info) (values #f id )]
|
||||
[(allow-web-upload) (values #f maybe-strs )]
|
||||
[(master-password) (values #f id )]
|
||||
[(log-output) (values #t id )]
|
||||
[(log-file) (values "log" path/false )]
|
||||
|
|
|
@ -57,6 +57,13 @@ This directory contains the following files and sub-directories:
|
|||
Racket with the (default) exact garbage collector and memory
|
||||
accounting); the default is 40000000.}
|
||||
|
||||
@item{@indexed-racket[allow-web-upload] --- either @racket[#f] (to
|
||||
disable upload via the HTTPS status server) or a non-empty list of
|
||||
suffix strings (to enable uploads for active assignments and force
|
||||
the uploaded file to have one of the suffixes); the default is
|
||||
@racket[#f]. The suffix strings should include a @litchar{.}, as
|
||||
in @racket[".rkt"].}
|
||||
|
||||
@item{@indexed-racket[default-file-name] --- the default filename
|
||||
that will be saved with the submission contents. The default is
|
||||
@filepath{handin.rkt}.}
|
||||
|
|
|
@ -35,9 +35,14 @@
|
|||
(define (relativize-path p)
|
||||
(path->string (find-relative-path (normalize-path server-dir) p)))
|
||||
|
||||
(define (make-k k tag)
|
||||
(format "~a~atag=~a" k (if (regexp-match? #rx"^[^#]*[?]" k) "&" "?")
|
||||
(uri-encode tag)))
|
||||
(define (make-k k tag #:mode [mode "download"])
|
||||
(let ([sep (if (regexp-match? #rx"^[^#]*[?]" k) "&" "?")])
|
||||
(format "~a~atag=~a~amode=~a"
|
||||
k
|
||||
sep
|
||||
(uri-encode tag)
|
||||
";"
|
||||
(uri-encode mode))))
|
||||
|
||||
;; `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 with "^solution"
|
||||
|
@ -56,7 +61,7 @@
|
|||
(build-path dir d))))
|
||||
(directory-list dir)))))
|
||||
|
||||
(define (handin-link k user hi)
|
||||
(define (handin-link k user hi upload-suffixes)
|
||||
(let* ([dir (find-handin-entry hi user)]
|
||||
[l (and dir (with-handlers ([exn:fail? (lambda (x) null)])
|
||||
(parameterize ([current-directory dir])
|
||||
|
@ -65,20 +70,28 @@
|
|||
(file-exists? f)))
|
||||
(map path->string (directory-list)))
|
||||
string<?))))])
|
||||
(if (pair? l)
|
||||
(cdr (append-map
|
||||
(lambda (f)
|
||||
(let ([hi (build-path dir f)])
|
||||
`((br)
|
||||
(a ([href ,(make-k k (relativize-path 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)))))
|
||||
(append
|
||||
(if (pair? l)
|
||||
(cdr (append-map
|
||||
(lambda (f)
|
||||
(let ([hi (build-path dir f)])
|
||||
`((br)
|
||||
(a ([href ,(make-k k (relativize-path 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 upload-suffixes
|
||||
(let ([dir (or dir
|
||||
(build-path (assignment<->dir hi) user))])
|
||||
(list '(br)
|
||||
`(a ([href ,(make-k k (relativize-path dir) #:mode "upload")])
|
||||
"Upload...")))
|
||||
null))))
|
||||
|
||||
(define (solution-link k hi)
|
||||
(let ([soln (and (member (assignment<->dir hi) (get-conf 'inactive-dirs))
|
||||
|
@ -117,27 +130,25 @@
|
|||
(let* ([next (send/suspend
|
||||
(lambda (k)
|
||||
(make-page (format "User: ~a, Handin: ~a" user for-handin)
|
||||
`(p ,@(handin-link k user for-handin))
|
||||
`(p ,@(handin-link k user for-handin #f))
|
||||
`(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))))))]
|
||||
[tag (aget (request-bindings next) 'tag)])
|
||||
(if (string=? tag "allofthem")
|
||||
(all-status-page user)
|
||||
(download user tag))))
|
||||
,(format "All handins for ~a" user))))))])
|
||||
(handle-status-request user next null)))
|
||||
|
||||
(define (all-status-page user)
|
||||
(define (cell . texts) `(td ([bgcolor "white"]) ,@texts))
|
||||
(define (rcell . texts) `(td ([bgcolor "white"] [align "right"]) ,@texts))
|
||||
(define (header . texts) `(td ([bgcolor "#f0f0f0"]) (big (strong ,@texts))))
|
||||
(define ((row k active?) dir)
|
||||
(define ((row k active? upload-suffixes) dir)
|
||||
(let ([hi (assignment<->dir dir)])
|
||||
`(tr ([valign "top"])
|
||||
,(apply header hi (if active? `((br) (small (small "[active]"))) '()))
|
||||
,(apply cell (handin-link k user hi))
|
||||
,(apply cell (handin-link k user hi upload-suffixes))
|
||||
,(rcell (handin-grade user hi))
|
||||
,(apply cell (solution-link k hi)))))
|
||||
(define upload-suffixes (get-conf 'allow-web-upload))
|
||||
(let* ([next
|
||||
(send/suspend
|
||||
(lambda (k)
|
||||
|
@ -145,22 +156,35 @@
|
|||
(format "All Handins for ~a" user)
|
||||
`(table ([bgcolor "#ddddff"] [cellpadding "6"] [align "center"])
|
||||
(tr () ,@(map header '(nbsp "Files" "Grade" "Solution")))
|
||||
,@(append (map (row k #t) (get-conf 'active-dirs))
|
||||
(map (row k #f) (get-conf 'inactive-dirs)))))))]
|
||||
[tag (aget (request-bindings next) 'tag)])
|
||||
(download user tag)))
|
||||
,@(append (map (row k #t upload-suffixes) (get-conf 'active-dirs))
|
||||
(map (row k #f #f) (get-conf 'inactive-dirs)))))))])
|
||||
(handle-status-request user next upload-suffixes)))
|
||||
|
||||
(define (download who tag)
|
||||
(define (check path elts allow-active?)
|
||||
(let loop ([path path] [elts (reverse elts)])
|
||||
(let*-values ([(base name dir?) (split-path path)]
|
||||
[(name) (path->string name)]
|
||||
[(check) (and (pair? elts) (car elts))])
|
||||
(if (null? elts)
|
||||
(define (handle-status-request user next upload-suffixes)
|
||||
(let* ([mode (aget (request-bindings next) 'mode)]
|
||||
[tag (aget (request-bindings next) 'tag)])
|
||||
(cond
|
||||
[(string=? mode "download")
|
||||
(download user tag)]
|
||||
[(string=? mode "upload")
|
||||
(upload user tag upload-suffixes)]
|
||||
[else
|
||||
(error 'status "unknown mode: ~s" mode)])))
|
||||
|
||||
(define (check path elts allow-active? allow-inactive?)
|
||||
(let loop ([path path] [elts (reverse elts)])
|
||||
(let*-values ([(base name dir?) (split-path path)]
|
||||
[(name) (path->string name)]
|
||||
[(check) (and (pair? elts) (car elts))])
|
||||
(if (null? elts)
|
||||
;; must be rooted in a submission directory (why build-path instead
|
||||
;; of using `path'? -- because path will have a trailing slash)
|
||||
(member (build-path base name)
|
||||
(get-conf (if allow-active? 'all-dirs 'inactive-dirs)))
|
||||
(cond
|
||||
[(and allow-active? allow-inactive?) (get-conf 'all-dirs)]
|
||||
[allow-inactive? (get-conf 'inactive-dirs)]
|
||||
[allow-active? (get-conf 'active-dirs)]
|
||||
[else null]))
|
||||
(and (cond [(eq? '* check) #t]
|
||||
[(regexp? check) (regexp-match? check name)]
|
||||
[(string? check)
|
||||
|
@ -168,15 +192,17 @@
|
|||
(member check (regexp-split #rx" *[+] *" name)))]
|
||||
[else #f])
|
||||
(loop base (cdr elts)))))))
|
||||
|
||||
(define (download who tag)
|
||||
(define file (build-path server-dir tag))
|
||||
(with-handlers ([exn:fail?
|
||||
(lambda (exn)
|
||||
(log-line "Status exception: ~a" (exn-message exn))
|
||||
(make-page "Error" "Illegal file access"))])
|
||||
;; Make sure the user is allowed to read the requested file:
|
||||
(or (check file `(,who *) #t)
|
||||
(check file `(#rx"^solution") #f)
|
||||
(check file `(#rx"^solution" *) #f)
|
||||
(or (check file `(,who *) #t #t)
|
||||
(check file `(#rx"^solution") #f #t)
|
||||
(check file `(#rx"^solution" *) #f #t)
|
||||
(error 'download "bad file access for ~s: ~a" who file))
|
||||
(log-line "Status file-get: ~s ~a" who file)
|
||||
(hook 'status-file-get `([username ,(string->symbol who)] [file ,file]))
|
||||
|
@ -202,6 +228,52 @@
|
|||
(path->string name))))))
|
||||
(list data)))))
|
||||
|
||||
(define (upload who tag suffixes)
|
||||
(define next
|
||||
(send/suspend
|
||||
(lambda (k)
|
||||
(make-page
|
||||
"Handin Upload"
|
||||
`(form ([action ,k] [method "post"] [enctype "multipart/form-data"])
|
||||
(table ([align "center"])
|
||||
(tr (td "File:")
|
||||
(td (input ([type "file"] [name "file"]))))
|
||||
(tr (td ([colspan "2"] [align "center"])
|
||||
(input ([type "submit"] [name "post"]
|
||||
[value "Upload"]))))))
|
||||
`(p "The uploaded file will replace any existing file with the same name.")
|
||||
`(p "Allowed file extensions:"
|
||||
,@(for/list ([s (in-list suffixes)]
|
||||
[n (in-naturals)])
|
||||
`(span " " (tt ,(bytes->string/utf-8 s))))
|
||||
". "
|
||||
"If the uploaded file has no extension or a different extension, "
|
||||
(tt ,(bytes->string/utf-8 (first suffixes))) " is added automatically.")))))
|
||||
(let ([fb (for/first ([b (in-list (request-bindings/raw next))]
|
||||
#:when (binding:file? b))
|
||||
b)])
|
||||
(if (and fb
|
||||
(not (equal? #"" (binding:file-filename fb))))
|
||||
(let* ([fn (binding:file-filename fb)]
|
||||
[base-fn (if (for/or ([suffix (in-list suffixes)])
|
||||
(regexp-match? (bytes-append (regexp-quote suffix) #"$") fn))
|
||||
(bytes->path fn)
|
||||
(path-add-suffix (bytes->path fn)
|
||||
(if (null? suffixes)
|
||||
#".txt"
|
||||
(car suffixes))))]
|
||||
[hw-dir (build-path server-dir tag)]
|
||||
[fn (build-path hw-dir (file-name-from-path base-fn))])
|
||||
(unless (check fn `(,who *) #t #f)
|
||||
(error 'download "bad upload access for ~s: ~a" who fn))
|
||||
(make-directory* hw-dir)
|
||||
(with-output-to-file
|
||||
fn
|
||||
#:exists 'truncate/replace
|
||||
(lambda () (display (binding:file-content fb))))
|
||||
(all-status-page who))
|
||||
(error "no file provided"))))
|
||||
|
||||
(define (status-page user for-handin)
|
||||
(log-line "Status access: ~s" user)
|
||||
(hook 'status-login `([username ,(string->symbol user)]))
|
||||
|
|
Loading…
Reference in New Issue
Block a user