From e361acae0bdc34ef6004f0df8c440db8eff4dcfe Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 30 Oct 2011 08:49:20 -0600 Subject: [PATCH] handin server: add support for HTTPS uploads (when enabled) --- collects/handin-server/private/config.rkt | 4 + .../scribblings/server-setup.scrbl | 7 + collects/handin-server/web-status-server.rkt | 154 +++++++++++++----- 3 files changed, 124 insertions(+), 41 deletions(-) diff --git a/collects/handin-server/private/config.rkt b/collects/handin-server/private/config.rkt index 5fe37e662d..8b91308101 100644 --- a/collects/handin-server/private/config.rkt +++ b/collects/handin-server/private/config.rkt @@ -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 )] diff --git a/collects/handin-server/scribblings/server-setup.scrbl b/collects/handin-server/scribblings/server-setup.scrbl index 9e8831c83d..1824420876 100644 --- a/collects/handin-server/scribblings/server-setup.scrbl +++ b/collects/handin-server/scribblings/server-setup.scrbl @@ -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}.} diff --git a/collects/handin-server/web-status-server.rkt b/collects/handin-server/web-status-server.rkt index 683e46d95e..0e23564998 100644 --- a/collects/handin-server/web-status-server.rkt +++ b/collects/handin-server/web-status-server.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))) stringstring - (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)]))