From 57b6a925069f6629eb8c45545a338b0e94b41914 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 13 Feb 2006 17:48:42 +0000 Subject: [PATCH] added multi-file submitter svn: r2211 --- collects/handin-client/client-gui.ss | 161 ++++++++++----- collects/handin-client/handin-multi.ss | 276 +++++++++++++++++++++++++ collects/handin-client/info.ss | 8 +- 3 files changed, 397 insertions(+), 48 deletions(-) create mode 100644 collects/handin-client/handin-multi.ss diff --git a/collects/handin-client/client-gui.ss b/collects/handin-client/client-gui.ss index fc13a3688a..906d5884bd 100644 --- a/collects/handin-client/client-gui.ss +++ b/collects/handin-client/client-gui.ss @@ -53,12 +53,18 @@ server port-no (build-path (collection-path this-collection) "server-cert.pem"))) + (provide handin-frame%) (define handin-frame% (class dialog% (inherit show is-shown? center) (super-new [label handin-dialog-name]) - (init-field content open-drscheme-window) + (init-field content on-retrieve) + (define mode + (cond [(and content on-retrieve) #f] + [content 'submit] + [on-retrieve 'retrieve] + [else (error 'handin-frame "bad initial values")])) (define status (new message% [label (format "Making secure connection to ~a..." server)] @@ -95,7 +101,9 @@ [callback (lambda _ (define r? (send retrieve? get-value)) (send ok set-label - (if r? button-label/r button-label/h)))])) + (if r? button-label/r button-label/h)))] + [value (eq? 'retrieve mode)] + [style (if mode '(deleted) '())])) (define (submit-file) (define final-message "Handin successful.") @@ -131,12 +139,14 @@ (lambda () (done-interface) (do-cancel-button) - (string->editor! buf (send (open-drscheme-window) get-editor)))))) + (on-retrieve buf))))) (define ok (new button% - [label ; can change to button-label/r, so use extra spaces - (string-append " " button-label/h " ")] + [label (case mode + [(submit) button-label/h] + [(retrieve) button-label/r] + [else (string-append " " button-label/h " ")])] ; can change [parent button-panel] [style '(border)] [callback @@ -267,12 +277,14 @@ (center) (show #t))) - (define (manage-handin-account) + (provide manage-handin-account) + (define (manage-handin-account parent) (new (class dialog% (inherit show is-shown? center) (super-new [label manage-dialog-name] - [alignment '(left center)]) + [alignment '(left center)] + [parent parent]) (define USER-FIELDS (let ([ef #f]) @@ -287,14 +299,18 @@ [parent this] [stretchable-width #t])) + (define multifile? + (#%info-lookup 'enable-multifile-handin (lambda () #f))) + (define tabs (new tab-panel% [parent this] - [choices '("New User" "Change Info" "Uninstall")] + [choices `("New User" "Change Info" + ,(if multifile? "Un/Install" "Uninstall"))] [callback (lambda (tp e) (send single active-child - (list-ref (list new-user-box old-user-box uninstall-box) + (list-ref (list new-user-box old-user-box un/install-box) (send tabs get-selection))))])) (define single (new panel:single% [parent tabs])) @@ -386,31 +402,68 @@ (do-change/add #t new-username))] [style '(border)])) - (define uninstall-box (new vertical-panel% - [parent single] - [alignment '(center center)])) - (define uninstall-button (new button% - [label (format "Uninstall ~a Handin" handin-name)] - [parent uninstall-box] - [callback - (lambda (b e) - (let ([dir (collection-path this-collection)]) - (with-handlers ([void (lambda (exn) - (report-error - "Uninstall failed." - exn))]) - (delete-directory/files dir) - (set! uninstalled? #t) - (send uninstall-button enable #f) - (message-box - "Uninstall" - (format - "The ~a tool has been uninstalled. ~a~a" - handin-name - "The Handin button and associated menu items" - " will not appear after you restart DrScheme.")))))])) + (define un/install-box + (new vertical-panel% [parent single] [alignment '(center center)])) + (define uninstall-button + (new button% + [label (format "Uninstall ~a Handin" handin-name)] + [parent un/install-box] + [callback + (lambda (b e) + (let ([dir (collection-path this-collection)]) + (with-handlers ([void + (lambda (exn) + (report-error "Uninstall failed." exn))]) + (delete-directory/files dir) + (set! uninstalled? #t) + (send uninstall-button enable #f) + (message-box "Uninstall" + (format "The ~a tool has been uninstalled. ~a~a" + handin-name + "The Handin button and associated menu items will" + " not appear after you restart DrScheme.") + this) + (send this show #f))))])) (send uninstall-button enable (not uninstalled?)) + (define install-standalone-button + (and multifile? + (new button% + [label (format "Install Standalone ~a Handin" handin-name)] + [parent un/install-box] + [callback + (lambda (b e) + (define (launcher sym) + (dynamic-require `(lib "launcher.ss" "launcher") sym)) + (let* ([exe (let-values + ([(dir name dir?) + (split-path + ((launcher 'mred-program-launcher-path) + (format "~a Handin" handin-name)))]) + (path->string name))] + [dir (get-directory + (format "Choose a directory to create the ~s~a" + exe " executable in") + #f)]) + (when (and dir (directory-exists? dir)) + (parameterize ([current-directory dir]) + (when (or (not (file-exists? exe)) + (eq? 'ok + (message-box + "File Exists" + (format + "The ~s executable already exists, ~a" + exe "it will be overwritten") + this '(ok-cancel caution)))) + ((launcher 'make-mred-launcher) + (list "-mvLe-" "handin-multi.ss" this-collection + "(multifile-handin)") + (build-path dir exe)) + (message-box "Standalone Executable" + (format "~s created" exe) + this) + (send this show #f))))))]))) + (define (report-error tag exn) (queue-callback (lambda () @@ -524,7 +577,7 @@ (send new-user-box show #f) (send old-user-box show #f) - (send uninstall-box show #f) + (send un/install-box show #f) (let ([new? (equal? "" (remembered-user))]) (send single active-child (if new? old-user-box new-user-box)) (send single active-child (if new? new-user-box old-user-box)) @@ -605,7 +658,16 @@ (new menu-item% (label (format "Manage ~a Handin Account..." handin-name)) (parent file-menu) - (callback (lambda (m e) (manage-handin-account)))) + (callback (lambda (m e) (manage-handin-account this)))) + (when multifile? + (new menu-item% + (label (format "Submit multiple ~a Files..." handin-name)) + (parent file-menu) + (callback (lambda (m e) + ((dynamic-require + (build-path (collection-path this-collection) + "handin-multi.ss") + 'multifile-handin)))))) (super file-menu:between-open-and-revert file-menu)) (define/override (help-menu:after-about menu) @@ -618,19 +680,24 @@ (super help-menu:after-about menu)) (define button - (new button% - [label (tool-button-label this)] - [parent (get-button-panel)] - [callback (lambda (button evt) - (let ([content (editors->string - (list (get-definitions-text) - (get-interactions-text)))]) - (new handin-frame% - [parent this] - [content content] - [open-drscheme-window - drscheme:unit:open-drscheme-window])))] - [style '(deleted)])) + (new button% + [label (tool-button-label this)] + [parent (get-button-panel)] + [style '(deleted)] + [callback + (lambda (button evt) + (let ([content (editors->string + (list (get-definitions-text) + (get-interactions-text)))]) + (new handin-frame% + [parent this] + [content content] + [on-retrieve + (lambda (buf) + (string->editor! + buf + (send (drscheme:unit:open-drscheme-window) + get-editor)))])))])) (send (get-button-panel) change-children (lambda (l) (cons button l))))) diff --git a/collects/handin-client/handin-multi.ss b/collects/handin-client/handin-multi.ss new file mode 100644 index 0000000000..ec1e7d1530 --- /dev/null +++ b/collects/handin-client/handin-multi.ss @@ -0,0 +1,276 @@ +(module handin-multi mzscheme + (require (lib "class.ss") (lib "list.ss") (lib "string.ss") (lib "port.ss") + (lib "unitsig.ss") (lib "mred.ss" "mred") + (lib "framework.ss" "framework") (lib "external.ss" "browser") + "info.ss" "client-gui.ss" (only "updater.ss" update)) + + (define handin-name (#%info-lookup 'name)) + (define this-collection (#%info-lookup 'collection)) + (define web-address (#%info-lookup 'web-address)) + (define selection-mode (#%info-lookup 'selection-mode)) + (define selection-defaults + (let ([sd (#%info-lookup 'selection-default)]) + (if (string? sd) (list sd) sd))) + (define (make-key sfx) + (string->symbol (format "~a:~a" (string-downcase handin-name) sfx))) + (define last-dir-key (make-key 'handin-last-dir)) + (preferences:set-default last-dir-key "" string?) + (define last-auto-key (make-key 'handin-last-auto)) + (preferences:set-default last-auto-key (car selection-defaults) string?) + (define geometry-key (make-key 'handin-geometry)) + (preferences:set-default geometry-key #f void) + + ;; ========================================================================== + (define magic #"<<>>") + (define (pack-files files) + (let/ec return + (parameterize ([current-output-port (open-output-bytes)]) + (printf "~a\n" magic) + (for-each + (lambda (file) + (let ([size (and (file-exists? file) (file-size file))]) + (unless size (return #f)) + (let ([buf (with-input-from-file file + (lambda () (read-bytes size)))]) + (unless (equal? size (bytes-length buf)) (return #f)) + (write (list file buf)) (newline)))) + files) + (flush-output) + (get-output-bytes (current-output-port))))) + (define ((unpack-files parent) buf) + (let/ec return + (define (error* msg) + (message-box "Retrieve Error" msg parent) + (return #f)) + (parameterize ([current-input-port (open-input-bytes buf)]) + (unless (equal? magic (read-bytes (bytes-length magic))) + (error* "Error in retrieved content: bad format")) + (let ([files + (let loop ([files '()]) + (let ([f (with-handlers ([void void]) (read))]) + (if (eof-object? f) + (reverse! files) (loop (cons f files)))))] + [overwrite-all? #f]) + (define (write? file) + (define (del) (delete-file file) #t) + (cond + [(not (file-exists? file)) #t] + [overwrite-all? (del)] + [else (case (message-box/custom + "Retrieve" + (format "~s already exists, overwrite?" file) + "&Yes" "&No" "Yes to &All" parent + '(default=2 caution) 4) + [(1) (del)] + [(2) #f] + [(3) (set! overwrite-all? #t) (del)] + [(4) (error* "Aborting...")])])) + (unless (and (list? files) + (andmap (lambda (x) + (and (list? x) (= 2 (length x)) + (string? (car x)) (bytes? (cadr x)))) + files)) + (error* "Error in retrieved content: bad format")) + (for-each (lambda (file) + (let ([file (car file)] [buf (cadr file)]) + (when (write? file) + (with-output-to-file file + (lambda () (display buf) (flush-output)))))) + files) + (message-box "Retrieve" "Retrieval done" parent))))) + + ;; ========================================================================== + (define multifile-dialog% + (class frame% + ;; ---------------------------------------------------------------------- + (let ([g (preferences:get geometry-key)]) + (super-new [label (format "~a Handin" handin-name)] + [stretchable-width #t] [stretchable-height #t] + [width (and g (car g))] [height (and g (cadr g))] + [x (and g (caddr g))] [y (and g (cadddr g))])) + (define main-pane (new horizontal-pane% [parent this])) + (define buttons-pane + (new vertical-pane% [parent main-pane] [stretchable-width #f])) + (define files-pane + (new vertical-pane% [parent main-pane])) + + ;; ---------------------------------------------------------------------- + (define (close) + (preferences:set geometry-key + (list (send this get-width) (send this get-height) + (send this get-x) (send this get-y))) + (preferences:save) + (send this show #f)) + + ;; ---------------------------------------------------------------------- + (new button% [parent buttons-pane] + [label (make-object bitmap% + (build-path (collection-path this-collection) + "icon.png"))] + [callback (lambda _ (send-url web-address))]) + (new pane% [parent buttons-pane]) + (let ([button (lambda (label callback) + (new button% [label label] [parent buttons-pane] + [stretchable-width #t] [callback callback]))]) + (button "&Submit" (lambda _ (do-submit))) + (button "&Retrieve" (lambda _ (do-retrieve))) + (button "A&ccount" (lambda _ (manage-handin-account this))) + (button "&Update" (lambda _ (update this #t))) + (button "C&lose" (lambda _ (close)))) + + ;; ---------------------------------------------------------------------- + (define files-list + (new list-box% [label "&Files:"] [parent files-pane] + [style `(,selection-mode vertical-label)] [enabled #f] + [choices '("Drag something here," "or click below")] + [min-height 100] [stretchable-width #t] [stretchable-height #t])) + (define auto-select + (new combo-field% [label "&Auto:"] [parent files-pane] + [init-value (preferences:get last-auto-key)] + [choices selection-defaults] + [callback (lambda (t e) + (when (eq? (send e get-event-type) 'text-field-enter) + (preferences:set last-auto-key (send t get-value)) + (do-auto-select #t)))])) + (define directory-pane + (new horizontal-pane% [parent files-pane] + [stretchable-width #t] [stretchable-height #f])) + (define choose-dir-button + (new button% [label "&Directory:"] [parent directory-pane] + [callback (lambda _ (choose-dir))])) + (define current-working-directory + (new text-field% [label #f] [parent directory-pane] [init-value ""] + [callback (lambda (t e) + (when (eq? (send e get-event-type) 'text-field-enter) + (set-dir (send t get-value)) + (send t focus)))])) + (let ([ldir (preferences:get last-dir-key)]) + ;; don't use init-value since it can get very long + (send current-working-directory set-value ldir) + (unless (equal? "" ldir) (current-directory ldir))) + + ;; ---------------------------------------------------------------------- + (define dir-selected? #f) + (define (->string x) + (cond [(string? x) x] + [(path? x) (path->string x)] + [(bytes? x) (bytes->string/utf-8 x)] + [(symbol? x) (symbol->string x)] + [else (error '->string "bad input: ~e" x)])) + (define (get-files) + (if (send files-list is-enabled?) + (map (lambda (i) (send files-list get-string i)) + (send files-list get-selections)) + '())) + (define (set-dir dir) + (let* ([dir (and dir (->string dir))] + [dir (and dir (not (equal? "" dir)) (directory-exists? dir) + (->string (simplify-path (path->complete-path + (build-path dir 'same)))))] + [selected (if (equal? dir (->string (current-directory))) + (get-files) '())]) + (when dir + (current-directory dir) + (set! dir-selected? #t) + (let ([t current-working-directory]) + (send t set-value dir) + (send (send t get-editor) select-all)) + (preferences:set last-dir-key dir) + (send files-list clear) + (for-each (lambda (f) + (when (file-exists? f) + (send files-list append f) + (when (member f selected) + (send files-list select + (sub1 (send files-list get-number)))))) + (mergesort (map ->string (directory-list)) stringstring name)) + => (lambda (i) (send files-list select i #t))]))])) + (define/override (on-subwindow-char w e) + (define (next) (super on-subwindow-char w e)) + (case (send e get-key-code) + [(escape) (close)] + [(f5) (refresh-dir)] + ;; [(#\space) (if (eq? w files-list) + ;; (printf ">>> ~s\n" (send files-list get-selection)) + ;; (next))] + [else (next)])) + + ;; ---------------------------------------------------------------------- + (define (do-submit) + (let ([files (get-files)]) + (if (pair? files) + (let ([content (pack-files files)]) + (if content + (new handin-frame% [parent this] [on-retrieve #f] + [content content]) + (message-box "Handin" "Error when packing files" this))) + (message-box "Handin" "No files" this)))) + (define (do-retrieve) + (if dir-selected? + (new handin-frame% [parent this] [content #f] + [on-retrieve (unpack-files this)]) + (message-box "Handin" "No directory selected" this))) + + ;; ---------------------------------------------------------------------- + (send this accept-drop-files #t) + (send choose-dir-button focus) + (send this show #t) + (update this))) + + (provide multifile-handin) + (define (multifile-handin) (new multifile-dialog%)) + + ) diff --git a/collects/handin-client/info.ss b/collects/handin-client/info.ss index 8950bafe7b..6282d9bc1d 100644 --- a/collects/handin-client/info.ss +++ b/collects/handin-client/info.ss @@ -17,4 +17,10 @@ (define tool-icons (list (list "icon.png" collection))) (define tools '(("client-gui.ss"))) (define tool-names (list name)) - (define requires '(("mred") ("openssl")))) + (define requires '(("mred") ("openssl"))) + + ;; Multi-file submission section (see handin-server/doc.txt for details) + (define enable-multifile-handin #f) ; enable multi-file? + (define selection-mode 'extended) ; mode for file choose, usually 'extended + (define selection-default ; suffixes to auto-choose (a string or string-list) + '("*.scm;*.ss" "*.scm;*.ss;*.txt")))