From c7dc9e73f309830890ebe1b8b9a877fca6562d70 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 12 Sep 2008 07:50:12 +0000 Subject: [PATCH 01/10] Welcome to a new PLT day. svn: r11672 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index c9d8b64812..c527c1b5b1 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "11sep2008") +#lang scheme/base (provide stamp) (define stamp "12sep2008") From a3930ea08846d9eef84bb3763b7a78f8c0341195 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 12 Sep 2008 13:22:31 +0000 Subject: [PATCH 02/10] improved reader documentation svn: r11673 --- collects/scribblings/scribble/reader.scrbl | 200 ++++++++++++++++----- 1 file changed, 152 insertions(+), 48 deletions(-) diff --git a/collects/scribblings/scribble/reader.scrbl b/collects/scribblings/scribble/reader.scrbl index 52327362bc..c940a8947c 100644 --- a/collects/scribblings/scribble/reader.scrbl +++ b/collects/scribblings/scribble/reader.scrbl @@ -20,20 +20,28 @@ You can use the reader via MzScheme's @schemefont{#reader} form: @schemeblock[ #, @schemefont|{ - #reader(lib "reader.ss" "scribble")@{This is free-form text!} + #reader scribble/reader @foo{This is free-form text!} }|] -Note that the reader will only read @"@"-forms as S-expressions. The -meaning of these S-expressions depends on the rest of your own code. +Note that the Scribble reader reads @"@"-forms as S-expressions. This +means that it is up to you to give meanings for these expressions in +the usual way: use Scheme functions, define your functions, or require +functions. For example, typing the above into MzScheme is likely +going to produce a ``reference to undefined identifier'' error --- you +can use @scheme[string-append] instead, or you can define @scheme[foo] +as a function (with variable arity). -A PLT Scheme manual more likely starts with +A common use of the Scribble @"@"-reader is when using Scribble as a +documentation system for producing manuals. In this case, the manual +text is likely to start with @schememod[scribble/doc] -which installs a reader, wraps the file content afterward into a -MzScheme module, and parses the body into a document using -@schememodname[scribble/decode]. See @secref["docreader"] for more -information. +which installs the @"@" reader starting in ``text mode'', wraps the +file content afterward into a MzScheme module where many useful Scheme +and documentation related functions are available, and parses the body +into a document using @schememodname[scribble/decode]. See +@secref["docreader"] for more information. Another way to use the reader is to use the @scheme[use-at-readtable] function to switch the current readtable to a readtable that parses @@ -44,6 +52,8 @@ function to switch the current readtable to a readtable that parses @;-------------------------------------------------------------------- @section{Concrete Syntax} +@subsection{The Scribble Syntax at a Glance} + Informally, the concrete syntax of @"@"-forms is @schemeblock[ @@ -55,50 +65,136 @@ Informally, the concrete syntax of @"@"-forms is where all three parts after @litchar["@"] are optional, but at least one should be present. (Note that spaces are not allowed between the -three parts.) @litchar["@"] is set as a non-terminating reader macro, -so it can be used as usual in Scheme identifiers unless you want to -use it as a first character of an identifier; in this case you need to -quote with a backslash (@schemefont["\\@foo"]) or quote the whole -identifier with bars (@schemefont["|@foo|"]). +three parts.) Roughly, a form matching the above grammar is read as @schemeblock[ - #, @schemefont|!{ - (define |@foo| '\@bar@baz) -}!|] - -Of course, @litchar["@"] is not treated specially in Scheme strings, -character constants, etc. - -Roughly, a form matching the above grammar is read as - -@schemeblock[ - (#, @nonterm{cmd} - #, @kleenestar{@nonterm{datum}} - #, @kleenestar{@nonterm{parsed-body}}) + (#, @nonterm{cmd} #, @kleenestar{@nonterm{datum}} #, @kleenestar{@nonterm{parsed-body}}) ] where @nonterm{parsed-body} is the translation of each @nonterm{text-body} in the input. Thus, the initial @nonterm{cmd} determines the Scheme code that the input is translated into. The -common case is when @nonterm{cmd} is a Scheme identifier, which -generates a plain Scheme form. - -A @nonterm{text-body} is made of text, newlines, and nested -@"@"-forms. Note that the syntax for @"@"-forms is the same in a -@nonterm{text-body} context as in a Scheme context. A -@nonterm{text-body} that isn't an @"@"-form is converted to a string -expression for its @nonterm{parsed-body}, and newlines are converted -to @scheme["\n"] expressions. +common case is when @nonterm{cmd} is a Scheme identifier, which reads +as a plain Scheme form, with datum arguments and/or string arguments. + +@scribble-examples|==={ + @foo{blah blah blah} + @foo{blah "blah" (`blah'?)} + @foo[1 2]{3 4} + @foo[1 2 3 4] + @foo[#:width 2]{blah blah} + @foo{blah blah + yada yada} + @foo{ + blah blah + yada yada + } +}===| + +(Note that these examples show how an input syntax is read as Scheme +syntax, not what it evaluates to.) + +As seen in the last example, multiple lines and the newlines that +separate them are parsed to multiple Scheme strings. More generally, +a @nonterm{text-body} is made of text, newlines, and nested +@"@"-forms, where the syntax for @"@"-forms is the same whether it's +in a @nonterm{text-body} context as in a Scheme context. A +@nonterm{text-body} that isn't an @"@"-form is converted to a string +expression for its @nonterm{parsed-body}; newlines and following +indentations are converted to @scheme["\n"] and all-space string +expressions. @scribble-examples|==={ - @foo{bar baz - blah} - @foo{bar @baz[3] - blah} @foo{bar @baz{3} blah} - @foo{bar @baz[2 3]{4 5} + @foo{@b{@u[3] @u{4}} blah} + @C{while (*(p++)) + *p = '\n';} +}===| + +The command part of an @"@"-form is optional as well, which is read as +a list, usually a function application, but also useful when quoted +with the usual Scheme @scheme[quote]: + +@scribble-examples|==={ + @{blah blah} + @{blah @[3]} + '@{foo + bar + baz} +}===| + +But we can also drop the datum and text parts, which leaves us with +only the command --- which is read as is, not within a parenthesized +form. This is not useful when reading Scheme code, but it can be used +inside a text block to escape a Scheme identifier. A vertical bar +(@litchar{|}) can be used to delimit the escaped identifier when +needed. + +@scribble-examples|==={ + @foo + @{blah @foo blah} + @{blah @foo: blah} + @{blah @|foo|: blah} +}===| + +Actually, the command part can be any Scheme expression, which is +particularly useful with such escapes since they can be used with any +expression. + +@scribble-examples|==={ + @foo{(+ 1 2) -> @(+ 1 2)!} + @foo{A @"string" escape} +}===| + +Note that an escaped Scheme string is merged with the surrounding text +as a special case. This is useful if you want to use the special +characters in your string (but note that escaping braces is not +necessary if they are balanced). + +@scribble-examples|==={ + @foo{eli@"@"barzilay.org} + @foo{A @"{" begins a block} + @C{while (*(p++)) { + *p = '\n'; + }} +}===| + +In some cases a @"@"-rich text can become cumbersome to quote. For +this, the braces have an alternative syntax --- a block of text can +begin with a ``@litchar["|{"]'' and terminated accordingly with a +``@litchar["}|"]''. Furthermore, any nested @"@" forms must begin +with a ``@litchar["|@"]''. + +@scribble-examples|==={ + @foo|{bar}@{baz}| + @foo|{bar |@x{X} baz}| + @foo|{bar |@x|{@}| baz}| +}===| + +In cases when even this is not convenient enough, punctuation +characters can be added between the @litchar{|} and the braces and the +@"@" in nested forms. (The punctuation is mirrored for parentheses +and @litchar{<>}s.) With this, the Scribble syntax can be used as a +here-string replacement. + +@scribble-examples|==={ + @foo|--{bar}@|{baz}--| + @foo|<<{bar}@|{baz}>>| +}===| + +The flip side of this is: how can an @"@" sign be used in Scheme code? +This is almost never an issue, because Scheme strings and characters +are still read the same, and because @litchar["@"] is set as a +non-terminating reader macro so it can be used in Scheme identifiers +as usual except when it is the first character of an identifier. In +the last case, you need to quote the identifier like other +non-standard characters --- with a backslash or with vertical bars: + +@scribble-examples|==={ + (define \@email "foo@bar.com") + (define |@atchar| #\@) }===| Note that spaces are not allowed before a @litchar{[} or a @@ -109,9 +205,13 @@ code). (More on using braces in body texts below.) @foo{bar @baz[2 3] {4 5}} }===| -When the above @"@"-forms appear in a Scheme expression context, the -lexical environment must provide bindings for @scheme[foo] (as a procedure or -a macro). +Finally, remember that the Scribble is just an alternate for +S-expressions --- identifiers still get their meaning, as in any +Scheme code, through the lexical context in which they appear. +Specifically, when the above @"@"-form appears in a Scheme expression +context, the lexical environment must provide bindings for +@scheme[foo] as a procedure or a macro; it can be defined, required, +or bound locally (with @scheme[let], for example). @; FIXME: unfortunate code duplication @interaction[ @@ -132,12 +232,16 @@ a macro). @text{@it{Note}: @bf{This is @ul{not} a pipe}.})) ] -If you want to see the expression that is actually being read, you can -use Scheme's @scheme[quote]. +When you first experiment with the Scribble syntax, it is often useful +to use Scheme's @scheme[quote] to inspect how some concrete syntax is +being read. -@scribble-examples|==={ - '@foo{bar} -}===| +@; FIXME: unfortunate code duplication +@interaction[ +(eval:alts + #,(tt "'@foo{bar}") + '@foo{bar}) +] @;-------------------------------------------------------------------- @subsection{The Command Part} From ef92bf90f4da00c256c4c8e625fe002792812bd3 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 12 Sep 2008 13:23:52 +0000 Subject: [PATCH 03/10] svn: r11674 --- collects/scribblings/scribble/reader.scrbl | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/collects/scribblings/scribble/reader.scrbl b/collects/scribblings/scribble/reader.scrbl index c940a8947c..0b4babd035 100644 --- a/collects/scribblings/scribble/reader.scrbl +++ b/collects/scribblings/scribble/reader.scrbl @@ -188,9 +188,9 @@ The flip side of this is: how can an @"@" sign be used in Scheme code? This is almost never an issue, because Scheme strings and characters are still read the same, and because @litchar["@"] is set as a non-terminating reader macro so it can be used in Scheme identifiers -as usual except when it is the first character of an identifier. In -the last case, you need to quote the identifier like other -non-standard characters --- with a backslash or with vertical bars: +as usual, except when it is the first character of an identifier. In +this case, you need to quote the identifier like other non-standard +characters --- with a backslash or with vertical bars: @scribble-examples|==={ (define \@email "foo@bar.com") From 4f1b8294137f995934b38c4392249e63c68bcd19 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 12 Sep 2008 14:49:22 +0000 Subject: [PATCH 04/10] switch to #lang, reindent, minor fix (when -> if), merge stuff with csu660 version svn: r11675 --- collects/handin-client/client-gui.ss | 1551 +++++++++++++------------- 1 file changed, 778 insertions(+), 773 deletions(-) diff --git a/collects/handin-client/client-gui.ss b/collects/handin-client/client-gui.ss index 2219381a8b..c4d6c16845 100644 --- a/collects/handin-client/client-gui.ss +++ b/collects/handin-client/client-gui.ss @@ -1,811 +1,816 @@ -(module client-gui scheme/base - (require mzlib/class mzlib/unit mzlib/file mrlib/switchable-button - mrlib/bitmap-label net/sendurl mred drscheme/tool framework - "info.ss" "client.ss" "this-collection.ss") +#lang scheme/base - (provide tool@) +(require mzlib/class mzlib/unit mzlib/file mred net/sendurl + mrlib/switchable-button mrlib/bitmap-label drscheme/tool framework + "info.ss" "client.ss" "this-collection.ss") - (define uninstalled? #f) +(provide tool@) - (define server:port (#%info-lookup 'server:port (lambda () #f))) - (define-values (server port-no) - (if server:port - (let ([m (regexp-match #rx"^([^:]+):([0-9]+)$" server:port)]) - (unless m - (error 'handin-client - "Bad configuration ~s, expecting \"server:port\"" - server:port)) - (values (cadr m) (string->number (caddr m)))) - (values #f #f))) +(define uninstalled? #f) - (define handin-name (#%info-lookup 'name)) - (define web-menu-name (#%info-lookup 'web-menu-name (lambda () #f))) - (define web-address (#%info-lookup 'web-address (lambda () #f))) +(define server:port (#%info-lookup 'server:port (lambda () #f))) +(define-values (server port-no) + (if server:port + (let ([m (regexp-match #rx"^([^:]+):([0-9]+)$" server:port)]) + (unless m + (error 'handin-client + "Bad configuration ~s, expecting \"server:port\"" + server:port)) + (values (cadr m) (string->number (caddr m)))) + (values #f #f))) - (define password-keep-minutes - (#%info-lookup 'password-keep-minutes (lambda () #f))) +(define handin-name (#%info-lookup 'name)) +(define web-menu-name (#%info-lookup 'web-menu-name (lambda () #f))) +(define web-address (#%info-lookup 'web-address (lambda () #f))) - (define handin-dialog-name (string-append handin-name " Handin")) - (define button-label/h (string-append handin-name " Handin")) - (define button-label/r (string-append handin-name " Retrieve")) - (define manage-dialog-name (string-append handin-name " Handin Account")) +(define password-keep-minutes + (#%info-lookup 'password-keep-minutes (lambda () #f))) - (define updater? - (#%info-lookup 'enable-auto-update (lambda () #f))) - (define multifile? - (#%info-lookup 'enable-multifile-handin (lambda () #f))) +(define handin-dialog-name (string-append handin-name " Handin")) +(define button-label/h (string-append handin-name " Handin")) +(define button-label/r (string-append handin-name " Retrieve")) +(define manage-dialog-name (string-append handin-name " Handin Account")) - (define preference-key (make-my-key 'submit:username)) +(define updater? + (#%info-lookup 'enable-auto-update (lambda () #f))) +(define multifile? + (#%info-lookup 'enable-multifile-handin (lambda () #f))) - (preferences:set-default preference-key "" string?) - (define (remembered-user) - (preferences:get preference-key)) - (define (remember-user user) - (preferences:set preference-key user)) +(define preference-key (make-my-key 'submit:username)) - (define (connect) (handin-connect server port-no)) +(preferences:set-default preference-key "" string?) +(define (remembered-user) + (preferences:get preference-key)) +(define (remember-user user) + (preferences:set preference-key user)) - ;; parameter-like procedure that keeps the password cached for a few minutes - (define cached-password - (let ([passwd #f] - [timer #f]) - (define protect - (let ([s (make-semaphore 1)]) - (lambda (thunk) - (dynamic-wind (lambda () (semaphore-wait s)) - thunk - (lambda () (semaphore-post s)))))) - (case-lambda - [() passwd] - [(new) - (protect (lambda () - (when (and password-keep-minutes - (not (equal? 0 password-keep-minutes)) - (not (equal? passwd new))) - (when timer (kill-thread timer)) - (set! passwd new) - (set! timer (thread - (lambda () - (sleep (* 60 password-keep-minutes)) - (protect (lambda () - (set! passwd #f) - (set! timer #f)))))))))]))) - ;; a password entry box that uses the one cached above - (define cached-passwd% - (class text-field% - (define cached (cached-password)) - ;; use this instead of a cached password -- to avoid copy/pastes - ;; of a password, and to hide its length - (define fake-value "CACHED PASSWD") - (define/override (get-value) - (or cached (super get-value))) - (define/override (on-focus on?) - (if on? - ;; got focus -- clear out bogus contents, if any - (when cached (send this set-value "") (set! cached #f)) - ;; lost focus -- remember a new password, or restore it - (let ([p (super get-value)]) - (cond [(and p (not (string=? "" p))) - ;; don't behave as if we have a cache: don't clear - ;; the value now, or if we get the focus later - (set! cached #f) - (cached-password p)] - [(cached-password) - => (lambda (p) - (set! cached p) - (send this set-value fake-value))])))) - (super-new [init-value (if cached fake-value "")] - [style '(single password)]))) +(define (connect) (handin-connect server port-no)) - (provide handin-frame%) - (define handin-frame% - (class dialog% - (inherit show is-shown? center) - (super-new [label handin-dialog-name]) +;; parameter-like procedure that keeps the password cached for a few minutes +(define cached-password + (let ([passwd #f] + [timer #f]) + (define protect + (let ([s (make-semaphore 1)]) + (lambda (thunk) + (dynamic-wind (lambda () (semaphore-wait s)) + thunk + (lambda () (semaphore-post s)))))) + (case-lambda + [() passwd] + [(new) + (protect (lambda () + (when (and password-keep-minutes + (not (equal? 0 password-keep-minutes)) + (not (equal? passwd new))) + (when timer (kill-thread timer)) + (set! passwd new) + (set! timer (thread + (lambda () + (sleep (* 60 password-keep-minutes)) + (protect (lambda () + (set! passwd #f) + (set! timer #f)))))))))]))) +;; a password entry box that uses the one cached above +(define cached-passwd% + (class text-field% + (define cached (cached-password)) + ;; use this instead of a cached password -- to avoid copy/pastes + ;; of a password, and to hide its length + (define fake-value "CACHED PASSWD") + (define/override (get-value) + (or cached (super get-value))) + (define/override (on-focus on?) + (if on? + ;; got focus -- clear out bogus contents, if any + (when cached (send this set-value "") (set! cached #f)) + ;; lost focus -- remember a new password, or restore it + (let ([p (super get-value)]) + (cond [(and p (not (string=? "" p))) + ;; don't behave as if we have a cache: don't clear + ;; the value now, or if we get the focus later + (set! cached #f) + (cached-password p)] + [(cached-password) + => (lambda (p) + (set! cached p) + (send this set-value fake-value))])))) + (super-new [init-value (if cached fake-value "")] + [style '(single password)]))) - (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")])) +(provide handin-frame%) +(define handin-frame% + (class dialog% + (inherit show is-shown? center) + (super-new [label handin-dialog-name]) - (define status (new message% - [label (format "Making secure connection to ~a..." server)] - [parent this] - [stretchable-width #t])) - (define username (new text-field% - [label "Username:"] - [init-value (remembered-user)] - [parent this] - [callback (lambda (t e) (activate-ok))] - [stretchable-width #t])) - (define passwd (new cached-passwd% - [label "Password:"] - [parent this] - [callback (lambda (t e) (activate-ok))] - [stretchable-width #t])) - (define assignment (new choice% - [label "Assignment:"] - [choices null] - [parent this] - [callback void] - [stretchable-width #t])) + (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 button-panel (new horizontal-pane% - [parent this] - [stretchable-height #f])) - (make-object vertical-pane% button-panel) ; spacer + (define status + (new message% + [label (format "Making secure connection to ~a..." server)] + [parent this] + [stretchable-width #t])) + (define username + (new text-field% + [label "Username:"] + [init-value (remembered-user)] + [parent this] + [callback (lambda (t e) (activate-ok))] + [stretchable-width #t])) + (define passwd + (new cached-passwd% + [label "Password:"] + [parent this] + [callback (lambda (t e) (activate-ok))] + [stretchable-width #t])) + (define assignment + (new choice% + [label "Assignment:"] + [choices null] + [parent this] + [callback void] + [stretchable-width #t])) - (define retrieve? - (new check-box% - [label "Retrieve"] - [parent button-panel] - [callback (lambda _ - (define r? (send retrieve? get-value)) - (send ok set-label - (if r? button-label/r button-label/h)))] - [value (eq? 'retrieve mode)] - [style (if mode '(deleted) '())])) + (define button-panel + (new horizontal-pane% + [parent this] + [stretchable-height #f])) - (define (submit-file) - (define final-message "Handin successful.") - (submit-assignment - connection - (send username get-value) - (send passwd get-value) - (send assignment get-string (send assignment get-selection)) - content - ;; on-commit - (lambda () - (semaphore-wait commit-lock) - (send status set-label "Committing...") - (set! committing? #t) - (semaphore-post commit-lock)) - ;; message/message-final/message-box handlers - (lambda (msg) (send status set-label msg)) - (lambda (msg) (set! final-message msg)) - (lambda (msg styles) (message-box "Handin" msg this styles))) + (make-object vertical-pane% button-panel) ; spacer + + (define retrieve? + (new check-box% + [label "Retrieve"] + [parent button-panel] + [callback (lambda _ + (define r? (send retrieve? get-value)) + (send ok set-label + (if r? button-label/r button-label/h)))] + [value (eq? 'retrieve mode)] + [style (if mode '(deleted) '())])) + + (define (submit-file) + (define final-message "Handin successful.") + (submit-assignment + connection + (send username get-value) + (send passwd get-value) + (send assignment get-string (send assignment get-selection)) + content + ;; on-commit + (lambda () + (semaphore-wait commit-lock) + (send status set-label "Committing...") + (set! committing? #t) + (semaphore-post commit-lock)) + ;; message/message-final/message-box handlers + (lambda (msg) (send status set-label msg)) + (lambda (msg) (set! final-message msg)) + (lambda (msg styles) (message-box "Handin" msg this styles))) + (queue-callback + (lambda () + (when abort-commit-dialog (send abort-commit-dialog show #f)) + (send status set-label final-message) + (set! committing? #f) + (done-interface)))) + (define (retrieve-file) + (let ([buf (retrieve-assignment + connection + (send username get-value) + (send passwd get-value) + (send assignment get-string (send assignment get-selection)))]) (queue-callback (lambda () - (when abort-commit-dialog (send abort-commit-dialog show #f)) - (send status set-label final-message) - (set! committing? #f) - (done-interface)))) - (define (retrieve-file) - (let ([buf (retrieve-assignment - connection - (send username get-value) - (send passwd get-value) - (send assignment get-string (send assignment get-selection)))]) - (queue-callback - (lambda () - (done-interface) - (do-cancel-button) - (on-retrieve buf))))) + (done-interface) + (do-cancel-button) + (on-retrieve buf))))) - (define ok - (new button% - [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 - (lambda (b e) - (disable-interface) - (send status set-label "Handing in...") - (parameterize ([current-custodian comm-cust]) - (thread - (lambda () - (remember-user (send username get-value)) - (with-handlers ([void (lambda (exn) - (report-error "Handin failed." exn))]) - (if (send retrieve? get-value) - (retrieve-file) - (submit-file)))))))])) + (define ok + (new button% + [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 + (lambda (b e) + (disable-interface) + (send status set-label "Handing in...") + (parameterize ([current-custodian comm-cust]) + (thread + (lambda () + (remember-user (send username get-value)) + (with-handlers ([void (lambda (exn) + (report-error "Handin failed." exn))]) + (if (send retrieve? get-value) + (retrieve-file) + (submit-file)))))))])) - (define ok-can-enable? #f) - (define (activate-ok) - (send ok enable (and ok-can-enable? - (not (string=? "" (send username get-value))) - (not (string=? "" (send passwd get-value)))))) + (define ok-can-enable? #f) + (define (activate-ok) + (send ok enable (and ok-can-enable? + (not (string=? "" (send username get-value))) + (not (string=? "" (send passwd get-value)))))) - (define cancel (new button% - [label "Cancel"] - [parent button-panel] - [callback (lambda (b e) (do-cancel-button))])) - (define (do-cancel-button) - (let ([go? (begin - (semaphore-wait commit-lock) - (if committing? - (begin - (semaphore-post commit-lock) - (send abort-commit-dialog show #t) - continue-abort?) - #t))]) - (when go? - (custodian-shutdown-all comm-cust) - (show #f)))) + (define cancel + (new button% + [label "Cancel"] + [parent button-panel] + [callback (lambda (b e) (do-cancel-button))])) + (define (do-cancel-button) + (let ([go? (begin + (semaphore-wait commit-lock) + (if committing? + (begin + (semaphore-post commit-lock) + (send abort-commit-dialog show #t) + continue-abort?) + #t))]) + (when go? + (custodian-shutdown-all comm-cust) + (show #f)))) - (define continue-abort? #f) - (define abort-commit-dialog - (let ([d (make-object dialog% "Commit in Progress")]) - (make-object message% "The commit action is in progress." d) - (make-object message% "Cancelling now may or may not work." d) - (make-object message% "Cancel anyway?" d) - (let ([b (new horizontal-panel% - [parent d] - [stretchable-height #f] - [alignment '(center center)])]) - (make-object button% "Continue Commit" d (lambda (b e) (send d show #f))) - (make-object button% "Try to Cancel" d (lambda (b e) - (set! continue-abort? #t) - (send d show #f)))))) - - (define interface-widgets - (list ok username passwd assignment retrieve?)) - (define (disable-interface) - (for-each (lambda (x) (send x enable #f)) interface-widgets)) - (define (enable-interface) - (for-each (lambda (x) (send x enable #t)) interface-widgets)) - (define (done-interface) - (send cancel set-label "Close") - (send cancel focus)) - - (define (report-error tag exn) - (queue-callback - (lambda () - (let* ([msg (if (exn? exn) - (let ([s (exn-message exn)]) - (if (string? s) - s - (format "~e" s))) - (format "~e" exn))] - [retry? (regexp-match #rx"bad username or password for" msg)]) - (custodian-shutdown-all comm-cust) - (set! committing? #f) - (disable-interface) - (send status set-label tag) - (when (is-shown?) - (message-box "Server Error" msg this) - (if retry? - (begin (init-comm) (semaphore-post go-sema) (enable-interface)) - (done-interface))))))) - - (define go-sema #f) - (define commit-lock #f) - (define committing? #f) - - (define connection #f) - - (define comm-cust #f) - (define (init-comm) - (set! go-sema (make-semaphore 1)) - (set! commit-lock (make-semaphore 1)) - (set! comm-cust (make-custodian)) - (parameterize ([current-custodian comm-cust]) - (thread - (lambda () - (let/ec escape - (with-handlers ([void - (lambda (exn) - (report-error "Connection failed." exn) - (escape))]) - (semaphore-wait go-sema) - (let* ([h (connect)] - [l (retrieve-active-assignments h)]) - (when (null? l) - (handin-disconnect h) - (error 'handin "there are no active assignments")) - (set! connection h) - (for-each (lambda (assign) (send assignment append assign)) - l) - (send assignment enable #t) - (set! ok-can-enable? #t) - (activate-ok) - (send status set-label - (format "Connected securely for ~a." handin-name))))))))) - - (define/augment (on-close) - (inner (void) on-close) - (do-cancel-button)) - - (init-comm) - - (send (cond [(string=? "" (send username get-value)) username] - [(string=? "" (send passwd get-value)) passwd] - [else ok]) - focus) - (send ok enable #f) ; disable after focus possibly sent to it - (send assignment enable #f) - - (center) - (show #t))) - - (provide manage-handin-dialog%) - (define manage-handin-dialog% - (class dialog% (init [parent #f]) - - (inherit show is-shown? center) - (super-new [label manage-dialog-name] - [alignment '(left center)] - [parent parent]) - - (define user-fields (get-user-fields parent)) - - (define status - (new message% - [label (if user-fields - (format "Manage ~a handin account at ~a." - handin-name server) - "No connection to server!")] - [parent this] - [stretchable-width #t])) - - (define tabs - (let* ([names (list (if multifile? "Un/Install" "Uninstall"))] - [names (if user-fields - `("New User" "Change Info" ,@names) names)] - [callback (lambda _ - (send single active-child - (if user-fields - (case (send tabs get-selection) - [(0) new-user-box] - [(1) old-user-box] - [(2) un/install-box] - [else (error "internal error")]) - un/install-box)))]) - (new tab-panel% [parent this] [choices names] [callback callback]))) - - (define single (new panel:single% [parent tabs])) - - (define (mk-txt label parent activate-ok) - (new text-field% - [label label] - [parent parent] - [callback (lambda (t e) (activate-ok))] - [stretchable-width #t])) - - (define (mk-passwd label parent activate-ok) - (new text-field% - [label label] - [parent parent] - [callback (lambda (t e) (activate-ok))] - [style '(single password)] - [stretchable-width #t])) - - (define (non-empty? . ts) - (andmap (lambda (t) (not (string=? "" (send t get-value)))) ts)) - - (define (same-value t1 t2) - (string=? (send t1 get-value) (send t2 get-value))) - - (define (activate-change) - (define an-extra-non-empty? (ormap non-empty? change-user-fields)) - (send retrieve-old-info-button enable - (non-empty? old-username old-passwd)) - (send change-button enable - (and (same-value new-passwd new-passwd2) - (non-empty? old-username old-passwd) - (or (non-empty? new-passwd) an-extra-non-empty?))) - (send change-button set-label - (if an-extra-non-empty? "Change Info" "Set Password"))) - - (define old-user-box (new vertical-panel% - [parent single] [alignment '(center center)])) - (define old-username (mk-txt "Username:" old-user-box activate-change)) - (send old-username set-value (remembered-user)) - - (define old-passwd - (new cached-passwd% - [label "Old Password:"] - [parent old-user-box] - [callback (lambda (t e) (activate-change))] - [stretchable-width #t])) - (define change-user-fields - (map (lambda (f) - (mk-txt (string-append f ":") old-user-box activate-change)) - (or user-fields '()))) - (define new-passwd - (mk-passwd "New Password:" old-user-box activate-change)) - (define new-passwd2 - (mk-passwd "New Password again:" old-user-box activate-change)) - - (define-values (retrieve-old-info-button change-button) - (let ([p (new horizontal-pane% - [parent old-user-box] + (define continue-abort? #f) + (define abort-commit-dialog + (let ([d (make-object dialog% "Commit in Progress")]) + (make-object message% "The commit action is in progress." d) + (make-object message% "Cancelling now may or may not work." d) + (make-object message% "Cancel anyway?" d) + (let ([b (new horizontal-panel% + [parent d] [stretchable-height #f] [alignment '(center center)])]) - (make-object vertical-pane% p) - (values - (begin0 (new button% - [label "Get Current Info"] [parent p] - [callback (lambda (b e) (do-retrieve old-username))]) - (make-object vertical-pane% p)) - (begin0 (new button% - [label "Set Password"] [parent p] [style '(border)] - [callback (lambda (b e) - (do-change/add #f old-username))]) - (make-object vertical-pane% p))))) + (make-object button% "Continue Commit" d + (lambda (b e) (send d show #f))) + (make-object button% "Try to Cancel" d + (lambda (b e) + (set! continue-abort? #t) (send d show #f)))))) - (define (activate-new) - (send new-button enable - (and (apply non-empty? new-username add-passwd add-passwd2 - add-user-fields) - (same-value add-passwd add-passwd2)))) - (define new-user-box (new vertical-panel% - [parent single] [alignment '(center center)])) - (define new-username (mk-txt "Username:" new-user-box activate-new)) - (send new-username set-value (remembered-user)) - (define add-user-fields - (map (lambda (f) - (mk-txt (string-append f ":") new-user-box activate-new)) - (or user-fields '()))) - (define add-passwd - (mk-passwd "Password:" new-user-box activate-new)) - (define add-passwd2 - (mk-passwd "Password again:" new-user-box activate-new)) - (define new-button (new button% - [label "Add User"] [parent new-user-box] - [callback (lambda (b e) - (do-change/add #t new-username))] - [style '(border)])) + (define interface-widgets + (list ok username passwd assignment retrieve?)) + (define (disable-interface) + (for-each (lambda (x) (send x enable #f)) interface-widgets)) + (define (enable-interface) + (for-each (lambda (x) (send x enable #t)) interface-widgets)) + (define (done-interface) + (send cancel set-label "Close") + (send cancel focus)) - (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) - (with-handlers ([void (lambda (exn) - (report-error "Uninstall failed." exn))]) - (delete-directory/files (in-this-collection)) - (set! uninstalled? #t) - (send uninstall-button enable #f) - (message-box "Uninstall" + (define (report-error tag exn) + (queue-callback + (lambda () + (let* ([msg (if (exn? exn) + (let ([s (exn-message exn)]) + (if (string? s) + s + (format "~e" s))) + (format "~e" exn))] + [retry? (regexp-match #rx"bad username or password for" msg)]) + (custodian-shutdown-all comm-cust) + (set! committing? #f) + (disable-interface) + (send status set-label tag) + (when (is-shown?) + (message-box "Server Error" msg this) + (if retry? + (begin (init-comm) (semaphore-post go-sema) (enable-interface)) + (done-interface))))))) + + (define go-sema #f) + (define commit-lock #f) + (define committing? #f) + + (define connection #f) + + (define comm-cust #f) + (define (init-comm) + (set! go-sema (make-semaphore 1)) + (set! commit-lock (make-semaphore 1)) + (set! comm-cust (make-custodian)) + (parameterize ([current-custodian comm-cust]) + (thread + (lambda () + (let/ec escape + (with-handlers ([void + (lambda (exn) + (report-error "Connection failed." exn) + (escape))]) + (semaphore-wait go-sema) + (let* ([h (connect)] + [l (retrieve-active-assignments h)]) + (when (null? l) + (handin-disconnect h) + (error 'handin "there are no active assignments")) + (set! connection h) + (for-each (lambda (assign) (send assignment append assign)) + l) + (send assignment enable #t) + (set! ok-can-enable? #t) + (activate-ok) + (send status set-label + (format "Connected securely for ~a." handin-name))))))))) + + (define/augment (on-close) + (inner (void) on-close) + (do-cancel-button)) + + (init-comm) + + (send (cond [(string=? "" (send username get-value)) username] + [(string=? "" (send passwd get-value)) passwd] + [else ok]) + focus) + (send ok enable #f) ; disable after focus possibly sent to it + (send assignment enable #f) + + (center) + (show #t))) + +(provide manage-handin-dialog%) +(define manage-handin-dialog% + (class dialog% (init [parent #f]) + + (inherit show is-shown? center) + (super-new [label manage-dialog-name] + [alignment '(left center)] + [parent parent]) + + (define user-fields (get-user-fields parent)) + + (define status + (new message% + [label (if user-fields + (format "Manage ~a handin account at ~a." + handin-name server) + "No connection to server!")] + [parent this] + [stretchable-width #t])) + + (define tabs + (let* ([names (list (if multifile? "Un/Install" "Uninstall"))] + [names (if user-fields + `("New User" "Change Info" ,@names) names)] + [callback (lambda _ + (send single active-child + (if user-fields + (case (send tabs get-selection) + [(0) new-user-box] + [(1) old-user-box] + [(2) un/install-box] + [else (error "internal error")]) + un/install-box)))]) + (new tab-panel% [parent this] [choices names] [callback callback]))) + + (define single (new panel:single% [parent tabs])) + + (define (mk-txt label parent activate-ok) + (new text-field% + [label label] + [parent parent] + [callback (lambda (t e) (activate-ok))] + [stretchable-width #t])) + + (define (mk-passwd label parent activate-ok) + (new text-field% + [label label] + [parent parent] + [callback (lambda (t e) (activate-ok))] + [style '(single password)] + [stretchable-width #t])) + + (define (non-empty? . ts) + (andmap (lambda (t) (not (string=? "" (send t get-value)))) ts)) + + (define (same-value t1 t2) + (string=? (send t1 get-value) (send t2 get-value))) + + (define (activate-change) + (define an-extra-non-empty? (ormap non-empty? change-user-fields)) + (send retrieve-old-info-button enable + (non-empty? old-username old-passwd)) + (send change-button enable + (and (same-value new-passwd new-passwd2) + (non-empty? old-username old-passwd) + (or (non-empty? new-passwd) an-extra-non-empty?))) + (send change-button set-label + (if an-extra-non-empty? "Change Info" "Set Password"))) + + (define old-user-box (new vertical-panel% + [parent single] [alignment '(center center)])) + (define old-username (mk-txt "Username:" old-user-box activate-change)) + (send old-username set-value (remembered-user)) + + (define old-passwd + (new cached-passwd% + [label "Old Password:"] + [parent old-user-box] + [callback (lambda (t e) (activate-change))] + [stretchable-width #t])) + (define change-user-fields + (map (lambda (f) + (mk-txt (string-append f ":") old-user-box activate-change)) + (or user-fields '()))) + (define new-passwd + (mk-passwd "New Password:" old-user-box activate-change)) + (define new-passwd2 + (mk-passwd "New Password again:" old-user-box activate-change)) + + (define-values (retrieve-old-info-button change-button) + (let ([p (new horizontal-pane% + [parent old-user-box] + [stretchable-height #f] + [alignment '(center center)])]) + (make-object vertical-pane% p) + (values + (begin0 (new button% + [label "Get Current Info"] [parent p] + [callback (lambda (b e) (do-retrieve old-username))]) + (make-object vertical-pane% p)) + (begin0 (new button% + [label "Set Password"] [parent p] [style '(border)] + [callback (lambda (b e) + (do-change/add #f old-username))]) + (make-object vertical-pane% p))))) + + (define (activate-new) + (send new-button enable + (and (apply non-empty? new-username add-passwd add-passwd2 + add-user-fields) + (same-value add-passwd add-passwd2)))) + (define new-user-box (new vertical-panel% + [parent single] [alignment '(center center)])) + (define new-username (mk-txt "Username:" new-user-box activate-new)) + (send new-username set-value (remembered-user)) + (define add-user-fields + (map (lambda (f) + (mk-txt (string-append f ":") new-user-box activate-new)) + (or user-fields '()))) + (define add-passwd + (mk-passwd "Password:" new-user-box activate-new)) + (define add-passwd2 + (mk-passwd "Password again:" new-user-box activate-new)) + (define new-button (new button% + [label "Add User"] [parent new-user-box] + [callback (lambda (b e) + (do-change/add #t new-username))] + [style '(border)])) + + (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) + (with-handlers ([void (lambda (exn) + (report-error "Uninstall failed." exn))]) + (delete-directory/files (in-this-collection)) + (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?)) + (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 `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-name - "(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 () - (custodian-shutdown-all comm-cust) - (send status set-label tag) - (when (is-shown?) - (message-box - "Server Error" - (when (exn? exn) - (let ([s (exn-message exn)]) - (if (string? s) s (format "~e" s)))) - this) - (set! comm-cust (make-custodian)))))) - - (define comm-cust (make-custodian)) - (define/augment (on-close) - (inner (void) on-close) - (custodian-shutdown-all comm-cust)) - - (define button-panel - (new horizontal-pane% [parent this] [stretchable-height #f])) - (make-object vertical-pane% button-panel) ; spacer - (define cancel - (new button% - [label "Cancel"] [parent button-panel] - [callback (lambda (b e) - (custodian-shutdown-all comm-cust) - (show #f))])) - - ;; Too-long fields can't damage the server, but they might result in - ;; confusing errors due to safety cut-offs on the server side. - (define (check-length field size name k) - (when ((string-length (send field get-value)) . > . size) - (message-box "Error" - (format "The ~a must be no longer than ~a characters." - name size)) - (k (void)))) - - (define (do-change/add new? username) - (let/ec k - (check-length username 50 "Username" k) - (let* ([pw1 (if new? new-passwd add-passwd)] - [pw2 (if new? new-passwd2 add-passwd2)] - [l1 (regexp-replace #rx" *:$" (send pw1 get-label) "")] - [l2 (regexp-replace #rx" *:$" (send pw2 get-label) "")]) - (check-length pw1 50 l1 k) - ;; not really needed, but leave just in case - (unless (string=? (send pw1 get-value) (send pw2 get-value)) - (message-box "Password Error" - (format "The \"~a\" and \"~a\" passwords are not the same." - l1 l2)) - (k (void)))) - (for-each (lambda (t f) (check-length t 100 f k)) - (if new? add-user-fields change-user-fields) - (or user-fields '())) - (send tabs enable #f) - (parameterize ([current-custodian comm-cust]) - (thread - (lambda () - (with-handlers ([void (lambda (exn) - (send tabs enable #t) - (report-error - (format "~a failed." - (if new? "Creation" "Update")) - exn))]) - (remember-user (send username get-value)) - (send status set-label "Making secure connection...") - (let ([h (connect)]) - (define (run proc . fields) - (apply proc h - (let loop ([x fields]) - (if (list? x) (map loop x) (send x get-value))))) - (send status set-label - (if new? "Creating user..." "Updating server...")) - (if new? - (run submit-addition username add-passwd add-user-fields) - (run submit-info-change username old-passwd new-passwd - change-user-fields))) - (send status set-label "Success.") - (send cancel set-label "Close"))))))) - - (define (do-retrieve username) - (let/ec k - (send tabs enable #f) - (parameterize ([current-custodian comm-cust]) - (thread - (lambda () - (with-handlers ([void (lambda (exn) - (send tabs enable #t) - (report-error "Retrieve failed." exn))]) - (remember-user (send username get-value)) - (send status set-label "Making secure connection...") - (let ([h (connect)]) - (define (run proc . fields) - (apply proc h - (let loop ([x fields]) - (if (list? x) (map loop x) (send x get-value))))) - (send status set-label "Retrieving information...") - (let ([vals (run retrieve-user-info username old-passwd)]) - (send status set-label "Success, you can now edit fields.") - (send tabs enable #t) - (for-each (lambda (f val) (send f set-value val)) - change-user-fields vals) - (activate-change))))))))) - - (send new-user-box show #f) - (send old-user-box show #f) - (send un/install-box show #f) - (let ([new? (equal? "" (remembered-user))]) - (if user-fields - (send* single (active-child (if new? old-user-box new-user-box)) - (active-child (if new? new-user-box old-user-box))) - (send single active-child un/install-box)) - (send tabs set-selection (if user-fields (if new? 0 1) 0))) - (activate-new) - (activate-change) - (center) - (show #t))) - - ;; A simple dialog during connection, with an option to cancel (used - ;; by `get-user-fields' below, since its value is needed to - ;; construct the above dialog). - (define connection-dialog% - (class dialog% (init receiver [parent #f]) - (inherit show is-shown? center) - (super-new [label manage-dialog-name] - [alignment '(right center)] - [parent parent]) - (define status - (new message% [label "Connecting to server..."] - [parent this] - [stretchable-width #t])) - (define comm-cust (make-custodian)) - (define/augment (on-close) - (inner (void) on-close) - (custodian-shutdown-all comm-cust)) - (define button - (new button% [label "Cancel"] [parent this] - [callback (lambda (b e) - (custodian-shutdown-all comm-cust) - (show #f))] - [style '(border)])) - (send button focus) - (parameterize ([current-custodian comm-cust]) - (thread - (lambda () - (unless (with-handlers ([void (lambda (_) #f)]) - (receiver (connect)) #t) - (begin (send status set-label "Connection failure!") - ;; (send button enable #f) - (sleep 5))) - (queue-callback (lambda () (show #f)))))) - (center) - (show #t))) - - (define cached-user-fields #f) - (define (get-user-fields parent) - (unless cached-user-fields - (new connection-dialog% - [receiver (lambda (h) - (set! cached-user-fields (retrieve-user-fields h)))] - [parent parent])) - cached-user-fields) - - (define (scale-by-half file) - (let* ([bm (make-object bitmap% file 'unknown/mask)] - [w (send bm get-width)] - [h (send bm get-height)] - [bm2 (make-object bitmap% (quotient w 2) (quotient h 2))] - [mbm2 (and (send bm get-loaded-mask) - (make-object bitmap% (quotient w 2) (quotient h 2)))] - [mdc (make-object bitmap-dc% bm2)]) - (send mdc draw-bitmap-section-smooth bm - 0 0 (quotient w 2) (quotient h 2) - 0 0 w h) - (send mdc set-bitmap #f) - (when mbm2 - (send mdc set-bitmap mbm2) - (send mdc draw-bitmap-section-smooth (send bm get-loaded-mask) - 0 0 (quotient w 2) (quotient h 2) - 0 0 w h) - (send mdc set-bitmap #f) - (send bm2 set-loaded-mask mbm2)) - bm2)) - - (define handin-icon (scale-by-half (in-this-collection "icon.png"))) - - (define (editors->string editors) - (let* ([base (make-object editor-stream-out-bytes-base%)] - [stream (make-object editor-stream-out% base)]) - (write-editor-version stream base) - (write-editor-global-header stream) - (for-each (lambda (ed) - (send ed write-to-file stream)) - editors) - (write-editor-global-footer stream) - (send base get-bytes))) - - (define (string->editor! str defs) - (let* ([base (make-object editor-stream-in-bytes-base% str)] - [stream (make-object editor-stream-in% base)]) - (read-editor-version stream base #t) - (read-editor-global-header stream) - (send defs read-from-file stream) - (read-editor-global-footer stream))) - - (define tool@ - (unit - (import drscheme:tool^) - (export drscheme:tool-exports^) - - (define phase1 void) - (define phase2 - (if updater? - (dynamic-require `(lib "updater.ss" ,this-collection-name) 'bg-update) - void)) - - (define tool-button-label (bitmap-label-maker button-label/h handin-icon)) - - (define (make-new-unit-frame% super%) - (class super% - (inherit get-button-panel - get-definitions-text - get-interactions-text) - (super-instantiate ()) - - (define/override (file-menu:between-open-and-revert file-menu) - ;; super adds a separator, add this and another sep after that - (super file-menu:between-open-and-revert file-menu) - (new menu-item% - [label (format "Manage ~a Handin Account..." handin-name)] - [parent file-menu] - [callback (lambda (m e) - (new manage-handin-dialog% [parent this]))]) - (when multifile? - (new menu-item% - [label (format "Submit multiple ~a Files..." handin-name)] - [parent file-menu] - [callback (lambda (m e) - ((dynamic-require - `(lib "handin-multi.ss" ,this-collection-name) - 'multifile-handin)))])) - (when updater? - (new menu-item% - [label (format "Update ~a plugin..." handin-name)] - [parent file-menu] + (define install-standalone-button + (and multifile? + (new button% + [label (format "Install Standalone ~a Handin" handin-name)] + [parent un/install-box] [callback - (lambda (m e) - ((dynamic-require `(lib "updater.ss" ,this-collection-name) - 'update) - #f #t))])) ; no parent - (new separator-menu-item% [parent file-menu])) + (lambda (b e) + (define (launcher sym) + (dynamic-require `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-name + "(multifile-handin)") + (build-path dir exe)) + (message-box "Standalone Executable" + (format "~s created" exe) + this) + (send this show #f))))))]))) - (define/override (help-menu:after-about menu) - (when web-menu-name - (new menu-item% - (label web-menu-name) - (parent menu) - (callback (lambda (item evt) - (send-url web-address))))) - (super help-menu:after-about menu)) + (define (report-error tag exn) + (queue-callback + (lambda () + (custodian-shutdown-all comm-cust) + (send status set-label tag) + (when (is-shown?) + (message-box + "Server Error" + (if (exn? exn) + (let ([s (exn-message exn)]) (if (string? s) s (format "~e" s))) + (format "~e" exn)) + this) + (set! comm-cust (make-custodian)))))) - (define client-panel - (new vertical-pane% (parent (get-button-panel)))) - - (define client-button - (new switchable-button% - [label button-label/h] - [bitmap handin-icon] - [parent client-panel] + (define comm-cust (make-custodian)) + (define/augment (on-close) + (inner (void) on-close) + (custodian-shutdown-all comm-cust)) + + (define button-panel + (new horizontal-pane% [parent this] [stretchable-height #f])) + (make-object vertical-pane% button-panel) ; spacer + (define cancel + (new button% + [label "Cancel"] [parent button-panel] + [callback (lambda (b e) + (custodian-shutdown-all comm-cust) + (show #f))])) + + ;; Too-long fields can't damage the server, but they might result in + ;; confusing errors due to safety cut-offs on the server side. + (define (check-length field size name k) + (when ((string-length (send field get-value)) . > . size) + (message-box "Error" + (format "The ~a must be no longer than ~a characters." + name size)) + (k (void)))) + + (define (do-change/add new? username) + (let/ec k + (check-length username 50 "Username" k) + (let* ([pw1 (if new? new-passwd add-passwd)] + [pw2 (if new? new-passwd2 add-passwd2)] + [l1 (regexp-replace #rx" *:$" (send pw1 get-label) "")] + [l2 (regexp-replace #rx" *:$" (send pw2 get-label) "")]) + (check-length pw1 50 l1 k) + ;; not really needed, but leave just in case + (unless (string=? (send pw1 get-value) (send pw2 get-value)) + (message-box + "Password Error" + (format "The \"~a\" and \"~a\" passwords are not the same." l1 l2)) + (k (void)))) + (for-each (lambda (t f) (check-length t 100 f k)) + (if new? add-user-fields change-user-fields) + (or user-fields '())) + (send tabs enable #f) + (parameterize ([current-custodian comm-cust]) + (thread + (lambda () + (with-handlers ([void (lambda (exn) + (send tabs enable #t) + (report-error + (format "~a failed." + (if new? "Creation" "Update")) + exn))]) + (remember-user (send username get-value)) + (send status set-label "Making secure connection...") + (let ([h (connect)]) + (define (run proc . fields) + (apply proc h + (let loop ([x fields]) + (if (list? x) (map loop x) (send x get-value))))) + (send status set-label + (if new? "Creating user..." "Updating server...")) + (if new? + (run submit-addition username add-passwd add-user-fields) + (run submit-info-change username old-passwd new-passwd + change-user-fields))) + (send status set-label "Success.") + (send cancel set-label "Close"))))))) + + (define (do-retrieve username) + (let/ec k + (send tabs enable #f) + (parameterize ([current-custodian comm-cust]) + (thread + (lambda () + (with-handlers ([void (lambda (exn) + (send tabs enable #t) + (report-error "Retrieve failed." exn))]) + (remember-user (send username get-value)) + (send status set-label "Making secure connection...") + (let ([h (connect)]) + (define (run proc . fields) + (apply proc h + (let loop ([x fields]) + (if (list? x) (map loop x) (send x get-value))))) + (send status set-label "Retrieving information...") + (let ([vals (run retrieve-user-info username old-passwd)]) + (send status set-label "Success, you can now edit fields.") + (send tabs enable #t) + (for-each (lambda (f val) (send f set-value val)) + change-user-fields vals) + (activate-change))))))))) + + (send new-user-box show #f) + (send old-user-box show #f) + (send un/install-box show #f) + (let ([new? (equal? "" (remembered-user))]) + (if user-fields + (send* single (active-child (if new? old-user-box new-user-box)) + (active-child (if new? new-user-box old-user-box))) + (send single active-child un/install-box)) + (send tabs set-selection (if user-fields (if new? 0 1) 0))) + (activate-new) + (activate-change) + (center) + (show #t))) + +;; A simple dialog during connection, with an option to cancel (used +;; by `get-user-fields' below, since its value is needed to +;; construct the above dialog). +(define connection-dialog% + (class dialog% (init receiver [parent #f]) + (inherit show is-shown? center) + (super-new [label manage-dialog-name] + [alignment '(right center)] + [parent parent]) + (define status + (new message% [label "Connecting to server..."] + [parent this] + [stretchable-width #t])) + (define comm-cust (make-custodian)) + (define/augment (on-close) + (inner (void) on-close) + (custodian-shutdown-all comm-cust)) + (define button + (new button% [label "Cancel"] [parent this] + [callback (lambda (b e) + (custodian-shutdown-all comm-cust) + (show #f))] + [style '(border)])) + (send button focus) + (parameterize ([current-custodian comm-cust]) + (thread + (lambda () + (unless (with-handlers ([void (lambda (_) #f)]) + (receiver (connect)) #t) + (begin (send status set-label "Connection failure!") + ;; (send button enable #f) + (sleep 5))) + (queue-callback (lambda () (show #f)))))) + (center) + (show #t))) + +(define cached-user-fields #f) +(define (get-user-fields parent) + (unless cached-user-fields + (new connection-dialog% + [receiver (lambda (h) + (set! cached-user-fields (retrieve-user-fields h)))] + [parent parent])) + cached-user-fields) + +(define (scale-by-half file) + (let* ([bm (make-object bitmap% file 'unknown/mask)] + [w (send bm get-width)] + [h (send bm get-height)] + [bm2 (make-object bitmap% (quotient w 2) (quotient h 2))] + [mbm2 (and (send bm get-loaded-mask) + (make-object bitmap% (quotient w 2) (quotient h 2)))] + [mdc (make-object bitmap-dc% bm2)]) + (send mdc draw-bitmap-section-smooth bm + 0 0 (quotient w 2) (quotient h 2) + 0 0 w h) + (send mdc set-bitmap #f) + (when mbm2 + (send mdc set-bitmap mbm2) + (send mdc draw-bitmap-section-smooth (send bm get-loaded-mask) + 0 0 (quotient w 2) (quotient h 2) + 0 0 w h) + (send mdc set-bitmap #f) + (send bm2 set-loaded-mask mbm2)) + bm2)) + +(define handin-icon (scale-by-half (in-this-collection "icon.png"))) + +(define (editors->string editors) + (let* ([base (make-object editor-stream-out-bytes-base%)] + [stream (make-object editor-stream-out% base)]) + (write-editor-version stream base) + (write-editor-global-header stream) + (for-each (lambda (ed) (send ed write-to-file stream)) editors) + (write-editor-global-footer stream) + (send base get-bytes))) + +(define (string->editor! str defs) + (let* ([base (make-object editor-stream-in-bytes-base% str)] + [stream (make-object editor-stream-in% base)]) + (read-editor-version stream base #t) + (read-editor-global-header stream) + (send defs read-from-file stream) + (read-editor-global-footer stream))) + +(define tool@ + (unit + (import drscheme:tool^) + (export drscheme:tool-exports^) + + (define phase1 void) + (define phase2 + (if updater? + (dynamic-require `(lib "updater.ss" ,this-collection-name) 'bg-update) + void)) + + (define tool-button-label (bitmap-label-maker button-label/h handin-icon)) + + (define (make-new-unit-frame% super%) + (class super% + (inherit get-button-panel + get-definitions-text + get-interactions-text) + (super-instantiate ()) + + (define/override (file-menu:between-open-and-revert file-menu) + ;; super adds a separator, add this and another sep after that + (super file-menu:between-open-and-revert file-menu) + (new menu-item% + [label (format "Manage ~a Handin Account..." handin-name)] + [parent file-menu] + [callback (lambda (m e) + (new manage-handin-dialog% [parent this]))]) + (when multifile? + (new menu-item% + [label (format "Submit multiple ~a Files..." handin-name)] + [parent file-menu] + [callback (lambda (m e) + ((dynamic-require + `(lib "handin-multi.ss" ,this-collection-name) + 'multifile-handin)))])) + (when updater? + (new menu-item% + [label (format "Update ~a plugin..." handin-name)] + [parent file-menu] [callback - (lambda (button) - (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)))])))])) - - (inherit register-toolbar-button) - (register-toolbar-button client-button) - - (send (get-button-panel) change-children - (lambda (_) - (cons client-panel - (remq client-panel _)))))) + (lambda (m e) + ((dynamic-require `(lib "updater.ss" ,this-collection-name) + 'update) + #f #t))])) ; no parent + (new separator-menu-item% [parent file-menu])) - (when (and server port-no) - (drscheme:get/extend:extend-unit-frame make-new-unit-frame% #f))))) + (define/override (help-menu:after-about menu) + (when web-menu-name + (new menu-item% + [label web-menu-name] + [parent menu] + [callback (lambda (item evt) (send-url web-address))])) + (super help-menu:after-about menu)) + + (define client-panel + (new vertical-pane% (parent (get-button-panel)))) + + (define client-button + (new switchable-button% + [label button-label/h] + [bitmap handin-icon] + [parent client-panel] + [callback + (lambda (button) + (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)))])))])) + + (inherit register-toolbar-button) + (register-toolbar-button client-button) + + (send (get-button-panel) change-children + (lambda (l) (cons client-panel (remq client-panel l)))))) + + (when (and server port-no) + (drscheme:get/extend:extend-unit-frame make-new-unit-frame% #f)))) From 854d52d98792e7904709e5dd651b8bcf41d1cc62 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 12 Sep 2008 14:56:10 +0000 Subject: [PATCH 05/10] mzlib/* -> scheme/*, for-each -> for svn: r11677 --- collects/handin-client/client-gui.ss | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/collects/handin-client/client-gui.ss b/collects/handin-client/client-gui.ss index c4d6c16845..dbe054e00b 100644 --- a/collects/handin-client/client-gui.ss +++ b/collects/handin-client/client-gui.ss @@ -1,6 +1,6 @@ #lang scheme/base -(require mzlib/class mzlib/unit mzlib/file mred net/sendurl +(require scheme/class scheme/unit scheme/file mred net/sendurl mrlib/switchable-button mrlib/bitmap-label drscheme/tool framework "info.ss" "client.ss" "this-collection.ss") @@ -256,9 +256,9 @@ (define interface-widgets (list ok username passwd assignment retrieve?)) (define (disable-interface) - (for-each (lambda (x) (send x enable #f)) interface-widgets)) + (for ([x interface-widgets]) (send x enable #f))) (define (enable-interface) - (for-each (lambda (x) (send x enable #t)) interface-widgets)) + (for ([x interface-widgets]) (send x enable #t) )) (define (done-interface) (send cancel set-label "Close") (send cancel focus)) @@ -309,8 +309,7 @@ (handin-disconnect h) (error 'handin "there are no active assignments")) (set! connection h) - (for-each (lambda (assign) (send assignment append assign)) - l) + (for ([assign l]) (send assignment append assign)) (send assignment enable #t) (set! ok-can-enable? #t) (activate-ok) @@ -576,9 +575,9 @@ "Password Error" (format "The \"~a\" and \"~a\" passwords are not the same." l1 l2)) (k (void)))) - (for-each (lambda (t f) (check-length t 100 f k)) - (if new? add-user-fields change-user-fields) - (or user-fields '())) + (for ([t (if new? add-user-fields change-user-fields)] + [f (or user-fields '())]) + (check-length t 100 f k)) (send tabs enable #f) (parameterize ([current-custodian comm-cust]) (thread @@ -625,8 +624,9 @@ (let ([vals (run retrieve-user-info username old-passwd)]) (send status set-label "Success, you can now edit fields.") (send tabs enable #t) - (for-each (lambda (f val) (send f set-value val)) - change-user-fields vals) + (for ([f change-user-fields] + [val vals]) + (send f set-value val)) (activate-change))))))))) (send new-user-box show #f) @@ -716,7 +716,7 @@ [stream (make-object editor-stream-out% base)]) (write-editor-version stream base) (write-editor-global-header stream) - (for-each (lambda (ed) (send ed write-to-file stream)) editors) + (for ([ed editors]) (send ed write-to-file stream)) (write-editor-global-footer stream) (send base get-bytes))) From 41a4f4b2ae09ce035a9317edf5ff56cee7cd7aef Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 12 Sep 2008 15:03:54 +0000 Subject: [PATCH 06/10] macro -> function svn: r11678 --- collects/syntax/module-reader.ss | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/syntax/module-reader.ss b/collects/syntax/module-reader.ss index fbb5f1717b..200296745e 100644 --- a/collects/syntax/module-reader.ss +++ b/collects/syntax/module-reader.ss @@ -63,8 +63,8 @@ w1 #t modpath src line col pos)) #t))))))))])) -(define-syntax-rule (wrap-internal lib port read whole? wrapper stx? - modpath src line col pos) +(define (wrap-internal lib port read whole? wrapper stx? + modpath src line col pos) (let* ([body (lambda () (if whole? (read port) From 5675f4574c043355a6a7700c169bda2929aad941 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 12 Sep 2008 15:18:00 +0000 Subject: [PATCH 07/10] more v4-updates svn: r11679 --- collects/handin-client/client.ss | 311 +++++++------ collects/handin-client/handin-multi.ss | 532 +++++++++++----------- collects/handin-client/this-collection.ss | 58 +-- collects/handin-client/updater.ss | 137 +++--- 4 files changed, 516 insertions(+), 522 deletions(-) diff --git a/collects/handin-client/client.ss b/collects/handin-client/client.ss index 245995565a..680c138e36 100644 --- a/collects/handin-client/client.ss +++ b/collects/handin-client/client.ss @@ -1,171 +1,170 @@ -(module client mzscheme - (require openssl/mzssl "this-collection.ss") +#lang scheme/base - (provide handin-connect - handin-disconnect - retrieve-user-fields - retrieve-active-assignments - submit-assignment - retrieve-assignment - submit-addition - submit-info-change - retrieve-user-info) +(require openssl/mzssl "this-collection.ss") - (define-struct handin (r w)) +(provide handin-connect + handin-disconnect + retrieve-user-fields + retrieve-active-assignments + submit-assignment + retrieve-assignment + submit-addition + submit-info-change + retrieve-user-info) - ;; errors to the user: no need for a "foo: " prefix - (define (error* fmt . args) - (error (apply format fmt args))) +(define-struct handin (r w)) - (define (write+flush port . xs) - (for-each (lambda (x) (write x port) (newline port)) xs) - (flush-output port)) +;; errors to the user: no need for a "foo: " prefix +(define (error* fmt . args) + (error (apply format fmt args))) - (define (close-handin-ports h) - (close-input-port (handin-r h)) - (close-output-port (handin-w h))) +(define (write+flush port . xs) + (for ([x xs]) (write x port) (newline port)) + (flush-output port)) - (define (wait-for-ok r who . reader) - (let ([v (if (pair? reader) ((car reader)) (read r))]) - (unless (eq? v 'ok) (error* "~a error: ~a" who v)))) +(define (close-handin-ports h) + (close-input-port (handin-r h)) + (close-output-port (handin-w h))) - ;; ssl connection, makes a readable error message if no connection - (define (connect-to server port) - (define pem (in-this-collection "server-cert.pem")) - (define ctx (ssl-make-client-context)) - (ssl-set-verify! ctx #t) - (ssl-load-verify-root-certificates! ctx pem) - (with-handlers - ([exn:fail:network? - (lambda (e) - (let* ([msg - "handin-connect: could not connect to the server (~a:~a)"] - [msg (format msg server port)] - #; ; un-comment to get the full message too - [msg (string-append msg " (" (exn-message e) ")")]) - (raise (make-exn:fail:network msg (exn-continuation-marks e)))))]) - (ssl-connect server port ctx))) +(define (wait-for-ok r who . reader) + (let ([v (if (pair? reader) ((car reader)) (read r))]) + (unless (eq? v 'ok) (error* "~a error: ~a" who v)))) - (define (handin-connect server port) - (let-values ([(r w) (connect-to server port)]) - ;; Sanity check: server sends "handin", first: - (let ([s (read-bytes 6 r)]) - (unless (equal? #"handin" s) - (error 'handin-connect "bad handshake from server: ~e" s))) - ;; Tell server protocol = 'ver1: - (write+flush w 'ver1) - ;; One more sanity check: server recognizes protocol: - (let ([s (read r)]) - (unless (eq? s 'ver1) - (error 'handin-connect "bad protocol from server: ~e" s))) - ;; Return connection: - (make-handin r w))) +;; ssl connection, makes a readable error message if no connection +(define (connect-to server port) + (define pem (in-this-collection "server-cert.pem")) + (define ctx (ssl-make-client-context)) + (ssl-set-verify! ctx #t) + (ssl-load-verify-root-certificates! ctx pem) + (with-handlers + ([exn:fail:network? + (lambda (e) + (let* ([msg + "handin-connect: could not connect to the server (~a:~a)"] + [msg (format msg server port)] + #; ; un-comment to get the full message too + [msg (string-append msg " (" (exn-message e) ")")]) + (raise (make-exn:fail:network msg (exn-continuation-marks e)))))]) + (ssl-connect server port ctx))) - (define (handin-disconnect h) - (write+flush (handin-w h) 'bye) - (close-handin-ports h)) +(define (handin-connect server port) + (let-values ([(r w) (connect-to server port)]) + ;; Sanity check: server sends "handin", first: + (let ([s (read-bytes 6 r)]) + (unless (equal? #"handin" s) + (error 'handin-connect "bad handshake from server: ~e" s))) + ;; Tell server protocol = 'ver1: + (write+flush w 'ver1) + ;; One more sanity check: server recognizes protocol: + (let ([s (read r)]) + (unless (eq? s 'ver1) + (error 'handin-connect "bad protocol from server: ~e" s))) + ;; Return connection: + (make-handin r w))) - (define (retrieve-user-fields h) - (let ([r (handin-r h)] [w (handin-w h)]) - (write+flush w 'get-user-fields 'bye) +(define (handin-disconnect h) + (write+flush (handin-w h) 'bye) + (close-handin-ports h)) + +(define (retrieve-user-fields h) + (let ([r (handin-r h)] [w (handin-w h)]) + (write+flush w 'get-user-fields 'bye) + (let ([v (read r)]) + (unless (and (list? v) (andmap string? v)) + (error* "failed to get user-fields list from server")) + (wait-for-ok r "get-user-fields") + (close-handin-ports h) + v))) + +(define (retrieve-active-assignments h) + (let ([r (handin-r h)] [w (handin-w h)]) + (write+flush w 'get-active-assignments) + (let ([v (read r)]) + (unless (and (list? v) (andmap string? v)) + (error* "failed to get active-assignment list from server")) + v))) + +(define (submit-assignment h username passwd assignment content + on-commit message message-final message-box) + (let ([r (handin-r h)] [w (handin-w h)]) + (define (read/message) (let ([v (read r)]) - (unless (and (list? v) (andmap string? v)) - (error* "failed to get user-fields list from server")) - (wait-for-ok r "get-user-fields") + (case v + [(message) (message (read r)) (read/message)] + [(message-final) (message-final (read r)) (read/message)] + [(message-box) + (write+flush w (message-box (read r) (read r))) (read/message)] + [else v]))) + (write+flush w + 'set 'username/s username + 'set 'password passwd + 'set 'assignment assignment + 'save-submission) + (wait-for-ok r "login") + (write+flush w (bytes-length content)) + (let ([v (read r)]) + (unless (eq? v 'go) (error* "upload error: ~a" v))) + (display "$" w) + (display content w) + (flush-output w) + ;; during processing, we're waiting for 'confirm, in the meanwhile, we + ;; can get a 'message or 'message-box to show -- after 'message we expect + ;; a string to show using the `messenge' argument, and after 'message-box + ;; we expect a string and a style-list to be used with `message-box' and + ;; the resulting value written back + (let ([v (read/message)]) + (unless (eq? 'confirm v) (error* "submit error: ~a" v))) + (on-commit) + (write+flush w 'check) + (wait-for-ok r "commit" read/message) + (close-handin-ports h))) + +(define (retrieve-assignment h username passwd assignment) + (let ([r (handin-r h)] [w (handin-w h)]) + (write+flush w + 'set 'username/s username + 'set 'password passwd + 'set 'assignment assignment + 'get-submission) + (let ([len (read r)]) + (unless (and (number? len) (integer? len) (positive? len)) + (error* "bad response from server: ~a" len)) + (let ([buf (begin (regexp-match #rx"[$]" r) (read-bytes len r))]) + (wait-for-ok r "get-submission") (close-handin-ports h) - v))) + buf)))) - (define (retrieve-active-assignments h) - (let ([r (handin-r h)] [w (handin-w h)]) - (write+flush w 'get-active-assignments) - (let ([v (read r)]) - (unless (and (list? v) (andmap string? v)) - (error* "failed to get active-assignment list from server")) - v))) +(define (submit-addition h username passwd user-fields) + (let ([r (handin-r h)] [w (handin-w h)]) + (write+flush w + 'set 'username/s username + 'set 'password passwd + 'set 'user-fields user-fields + 'create-user) + (wait-for-ok r "create-user") + (close-handin-ports h))) - (define (submit-assignment h username passwd assignment content - on-commit message message-final message-box) - (let ([r (handin-r h)] [w (handin-w h)]) - (define (read/message) - (let ([v (read r)]) - (case v - [(message) (message (read r)) (read/message)] - [(message-final) (message-final (read r)) (read/message)] - [(message-box) - (write+flush w (message-box (read r) (read r))) (read/message)] - [else v]))) - (write+flush w - 'set 'username/s username - 'set 'password passwd - 'set 'assignment assignment - 'save-submission) - (wait-for-ok r "login") - (write+flush w (bytes-length content)) - (let ([v (read r)]) - (unless (eq? v 'go) (error* "upload error: ~a" v))) - (display "$" w) - (display content w) - (flush-output w) - ;; during processing, we're waiting for 'confirm, in the meanwhile, we - ;; can get a 'message or 'message-box to show -- after 'message we expect - ;; a string to show using the `messenge' argument, and after 'message-box - ;; we expect a string and a style-list to be used with `message-box' and - ;; the resulting value written back - (let ([v (read/message)]) - (unless (eq? 'confirm v) (error* "submit error: ~a" v))) - (on-commit) - (write+flush w 'check) - (wait-for-ok r "commit" read/message) - (close-handin-ports h))) +(define (submit-info-change h username old-passwd new-passwd user-fields) + (let ([r (handin-r h)] + [w (handin-w h)]) + (write+flush w + 'set 'username/s username + 'set 'password old-passwd + 'set 'new-password new-passwd + 'set 'user-fields user-fields + 'change-user-info) + (wait-for-ok r "change-user-info") + (close-handin-ports h))) - (define (retrieve-assignment h username passwd assignment) - (let ([r (handin-r h)] [w (handin-w h)]) - (write+flush w - 'set 'username/s username - 'set 'password passwd - 'set 'assignment assignment - 'get-submission) - (let ([len (read r)]) - (unless (and (number? len) (integer? len) (positive? len)) - (error* "bad response from server: ~a" len)) - (let ([buf (begin (regexp-match #rx"[$]" r) (read-bytes len r))]) - (wait-for-ok r "get-submission") - (close-handin-ports h) - buf)))) - - (define (submit-addition h username passwd user-fields) - (let ([r (handin-r h)] [w (handin-w h)]) - (write+flush w - 'set 'username/s username - 'set 'password passwd - 'set 'user-fields user-fields - 'create-user) - (wait-for-ok r "create-user") - (close-handin-ports h))) - - (define (submit-info-change h username old-passwd new-passwd user-fields) - (let ([r (handin-r h)] - [w (handin-w h)]) - (write+flush w - 'set 'username/s username - 'set 'password old-passwd - 'set 'new-password new-passwd - 'set 'user-fields user-fields - 'change-user-info) - (wait-for-ok r "change-user-info") - (close-handin-ports h))) - - (define (retrieve-user-info h username passwd) - (let ([r (handin-r h)] [w (handin-w h)]) - (write+flush w - 'set 'username/s username - 'set 'password passwd - 'get-user-info 'bye) - (let ([v (read r)]) - (unless (and (list? v) (andmap string? v)) - (error* "failed to get user-info list from server")) - (wait-for-ok r "get-user-info") - (close-handin-ports h) - v))) - - ) +(define (retrieve-user-info h username passwd) + (let ([r (handin-r h)] [w (handin-w h)]) + (write+flush w + 'set 'username/s username + 'set 'password passwd + 'get-user-info 'bye) + (let ([v (read r)]) + (unless (and (list? v) (andmap string? v)) + (error* "failed to get user-info list from server")) + (wait-for-ok r "get-user-info") + (close-handin-ports h) + v))) diff --git a/collects/handin-client/handin-multi.ss b/collects/handin-client/handin-multi.ss index 187dc95705..8425077ade 100644 --- a/collects/handin-client/handin-multi.ss +++ b/collects/handin-client/handin-multi.ss @@ -1,282 +1,276 @@ -(module handin-multi mzscheme - (require mzlib/class mzlib/list mzlib/string mzlib/port - mred framework - browser/external - "info.ss" "client-gui.ss" "this-collection.ss") +#lang scheme/base - (define handin-name (#%info-lookup 'name)) - (define web-address (#%info-lookup 'web-address - (lambda () "http://www.plt-scheme.org"))) - (define selection-mode (#%info-lookup 'selection-mode (lambda () 'extended))) - (define selection-defaults - (let ([sd (#%info-lookup 'selection-default (lambda () '("*.scm" "*.ss")))]) - (if (string? sd) (list sd) sd))) - (define last-dir-key (make-my-key 'multifile:last-dir)) - (preferences:set-default last-dir-key "" string?) - (define last-auto-key (make-my-key 'multifile:last-auto)) - (preferences:set-default last-auto-key (car selection-defaults) string?) - (define geometry-key (make-my-key 'multifile:geometry)) - (preferences:set-default geometry-key #f void) +(require scheme/class scheme/port mred framework browser/external + "info.ss" "client-gui.ss" "this-collection.ss") - (define update - (and (#%info-lookup 'enable-auto-update (lambda () #f)) - (dynamic-require `(lib "updater.ss" ,this-collection-name) 'update))) +(define handin-name (#%info-lookup 'name)) +(define web-address (#%info-lookup 'web-address + (lambda () "http://www.plt-scheme.org"))) +(define selection-mode (#%info-lookup 'selection-mode (lambda () 'extended))) +(define selection-defaults + (let ([sd (#%info-lookup 'selection-default (lambda () '("*.scm" "*.ss")))]) + (if (string? sd) (list sd) sd))) +(define last-dir-key (make-my-key 'multifile:last-dir)) +(preferences:set-default last-dir-key "" string?) +(define last-auto-key (make-my-key 'multifile:last-auto)) +(preferences:set-default last-auto-key (car selection-defaults) string?) +(define geometry-key (make-my-key 'multifile: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))) +(define update + (and (#%info-lookup 'enable-auto-update (lambda () #f)) + (dynamic-require `(lib "updater.ss" ,this-collection-name) 'update))) + +;; ========================================================================== +(define magic #"<<>>") +(define (pack-files files) + (let/ec return + (parameterize ([current-output-port (open-output-bytes)]) + (printf "~a\n" magic) + (for ([file files]) + (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)))) + (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) + ;; check if exists: users might rename files during questions + (when (file-exists? file) (delete-file file))) + (cond [(not (file-exists? file)) #t] + [overwrite-all? (del) #t] + [else (case (message-box/custom + "Retrieve" + (format "~s already exists, overwrite?" file) + "&Yes" "&No" "Yes to &All" parent + '(default=2 caution) 4) + [(1) (del) #t] + [(2) #f] + [(3) (set! overwrite-all? #t) (del) #t] + [(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")) - (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) - ;; check if exists: users might rename files during questions - (when (file-exists? file) (delete-file file))) - (cond [(not (file-exists? file)) #t] - [overwrite-all? (del) #t] - [else (case (message-box/custom - "Retrieve" - (format "~s already exists, overwrite?" file) - "&Yes" "&No" "Yes to &All" parent - '(default=2 caution) 4) - [(1) (del) #t] - [(2) #f] - [(3) (set! overwrite-all? #t) (del) #t] - [(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))))) + (for ([file files]) + (let ([file (car file)] [buf (cadr file)]) + (when (write? file) + (with-output-to-file file + (lambda () (display buf) (flush-output)))))) + (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 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)) - (define/augment (on-close) (close)) + ;; ---------------------------------------------------------------------- + (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)) + (define/augment (on-close) (close)) - ;; ---------------------------------------------------------------------- - (new button% [parent buttons-pane] - [label (make-object bitmap% (in-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 _ (new manage-handin-dialog% [parent this]))) - (when update (button "&Update" (lambda _ (update this #t)))) - (button "C&lose" (lambda _ (close)))) + ;; ---------------------------------------------------------------------- + (new button% [parent buttons-pane] + [label (make-object bitmap% (in-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 _ (new manage-handin-dialog% [parent this]))) + (when update (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-selections '() '())))])) - (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)))])) + ;; ---------------------------------------------------------------------- + (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-selections '() '())))])) + (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-selected+unselected) + (if (send files-list is-enabled?) + (let ([selected (send files-list get-selections)]) + (let loop ([i (sub1 (send files-list get-number))] [s '()] [u '()]) + (if (<= 0 i) + (let ([f (send files-list get-string i)]) + (if (memq i selected) + (loop (sub1 i) (cons f s) u) + (loop (sub1 i) s (cons f u)))) + (list (reverse s) (reverse u))))) + '(() ()))) + (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)))))] + [sel+unsel (if (equal? dir (->string (current-directory))) + (get-selected+unselected) '(() ()))]) + (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 set + (sort (map ->string (filter file-exists? (directory-list))) + stringregexps glob) + (if (equal? (car auto-glob+regexp) glob) + (cdr auto-glob+regexp) + (let* ([regexps + (map (lambda (glob) + (let* ([re (regexp-replace* #rx"[.]" glob "\\\\.")] + [re (regexp-replace* #rx"[?]" re ".")] + [re (regexp-replace* #rx"[*]" re ".*")] + [re (string-append "^" re "$")] + [re (with-handlers ([void (lambda _ #f)]) + (regexp re))]) + re)) + (regexp-split ";" glob))] + [regexps (filter values regexps)] + [regexps (if (pair? regexps) + (lambda (file) + (ormap (lambda (re) (regexp-match re file)) + regexps)) + (lambda (_) #f))]) + (set! auto-glob+regexp (cons glob regexps)) + regexps))) + (define (do-selections selected unselected) + (define glob (send auto-select get-value)) + (define regexps (globs->regexps glob)) + (let loop ([n (sub1 (send files-list get-number))]) + (when (<= 0 n) + (let ([file (send files-list get-string n)]) + (send files-list select n + (cond [(member file selected) #t] + [(member file unselected) #f] + [else (regexps file)])) + (loop (sub1 n))))) + (send (if (send files-list is-enabled?) files-list choose-dir-button) + focus)) - ;; ---------------------------------------------------------------------- - (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-selected+unselected) - (if (send files-list is-enabled?) - (let ([selected (send files-list get-selections)]) - (let loop ([i (sub1 (send files-list get-number))] [s '()] [u '()]) - (if (<= 0 i) - (let ([f (send files-list get-string i)]) - (if (memq i selected) - (loop (sub1 i) (cons f s) u) - (loop (sub1 i) s (cons f u)))) - (list (reverse s) (reverse u))))) - '(() ()))) - (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)))))] - [sel+unsel (if (equal? dir (->string (current-directory))) - (get-selected+unselected) '(() ()))]) - (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 set - (sort (map ->string (filter file-exists? (directory-list))) - stringregexps glob) - (if (equal? (car auto-glob+regexp) glob) - (cdr auto-glob+regexp) - (let* ([regexps - (map (lambda (glob) - (let* ([re (regexp-replace* #rx"[.]" glob "\\\\.")] - [re (regexp-replace* #rx"[?]" re ".")] - [re (regexp-replace* #rx"[*]" re ".*")] - [re (string-append "^" re "$")] - [re (with-handlers ([void (lambda _ #f)]) - (regexp re))]) - re)) - (regexp-split ";" glob))] - [regexps (filter values regexps)] - [regexps (if (pair? regexps) - (lambda (file) - (ormap (lambda (re) (regexp-match re file)) - regexps)) - (lambda (_) #f))]) - (set! auto-glob+regexp (cons glob regexps)) - regexps))) - (define (do-selections selected unselected) - (define glob (send auto-select get-value)) - (define regexps (globs->regexps glob)) - (let loop ([n (sub1 (send files-list get-number))]) - (when (<= 0 n) - (let ([file (send files-list get-string n)]) - (send files-list select n - (cond [(member file selected) #t] - [(member file unselected) #f] - [else (regexps file)])) - (loop (sub1 n))))) - (send (if (send files-list is-enabled?) files-list choose-dir-button) - focus)) + ;; ---------------------------------------------------------------------- + (define/override (on-drop-file path) + (cond [(directory-exists? path) (set-dir path)] + [(file-exists? path) + (let-values ([(dir name dir?) (split-path path)]) + (set-dir dir) + (cond [(send files-list find-string (->string 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/override (on-drop-file path) - (cond [(directory-exists? path) (set-dir path)] - [(file-exists? path) - (let-values ([(dir name dir?) (split-path path)]) - (set-dir dir) - (cond [(send files-list find-string (->string 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 (car (get-selected+unselected))]) + (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))) - ;; ---------------------------------------------------------------------- - (define (do-submit) - (let ([files (car (get-selected+unselected))]) - (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) + (when update (update this)))) - ;; ---------------------------------------------------------------------- - (send this accept-drop-files #t) - (send choose-dir-button focus) - (send this show #t) - (when update (update this)))) - - (provide multifile-handin) - (define (multifile-handin) (new multifile-dialog%)) - - ) +(provide multifile-handin) +(define (multifile-handin) (new multifile-dialog%)) diff --git a/collects/handin-client/this-collection.ss b/collects/handin-client/this-collection.ss index ce8c88ee67..c4af2a85c9 100644 --- a/collects/handin-client/this-collection.ss +++ b/collects/handin-client/this-collection.ss @@ -1,34 +1,34 @@ -(module this-collection mzscheme +#lang scheme/base - (define-syntax (this-name-stx stx) - (let* ([p (syntax-source stx)] - [dir (and (path? p) (let-values ([(b _1 _2) (split-path p)]) b))] - [name (and (path? dir) - (bytes->string/locale - (path-element->bytes - (let-values ([(_1 p _2) (split-path dir)]) p))))]) - ;; check that we are installed as a top-level collection (this is needed - ;; because there are some code bits (that depend on bindings from this - ;; file) that expect this to be true) - (with-handlers - ([void (lambda (e) - (raise - (make-exn:fail - "*** Error: this collection must be a top-level collection" - (exn-continuation-marks e))))]) - (collection-path name)) - (datum->syntax-object stx name stx))) +(require (for-syntax scheme/base)) - (provide this-collection-name) - (define this-collection-name this-name-stx) +(define-syntax (this-name-stx stx) + (let* ([p (syntax-source stx)] + [dir (and (path? p) (let-values ([(b _1 _2) (split-path p)]) b))] + [name (and (path? dir) + (bytes->string/locale + (path-element->bytes + (let-values ([(_1 p _2) (split-path dir)]) p))))]) + ;; check that we are installed as a top-level collection (this is needed + ;; because there are some code bits (that depend on bindings from this + ;; file) that expect this to be true) + (with-handlers + ([void (lambda (e) + (raise + (make-exn:fail + "*** Error: this collection must be a top-level collection" + (exn-continuation-marks e))))]) + (collection-path name)) + (datum->syntax stx name stx))) - (define this-collection-path (collection-path this-collection-name)) - (provide in-this-collection) - (define (in-this-collection . paths) - (apply build-path this-collection-path paths)) +(provide this-collection-name) +(define this-collection-name this-name-stx) - (provide make-my-key) - (define (make-my-key sym) - (string->symbol (format "handin:~a:~a" this-collection-name sym))) +(define this-collection-path (collection-path this-collection-name)) +(provide in-this-collection) +(define (in-this-collection . paths) + (apply build-path this-collection-path paths)) - ) +(provide make-my-key) +(define (make-my-key sym) + (string->symbol (format "handin:~a:~a" this-collection-name sym))) diff --git a/collects/handin-client/updater.ss b/collects/handin-client/updater.ss index 6d9f348ff7..bb226ed1ce 100644 --- a/collects/handin-client/updater.ss +++ b/collects/handin-client/updater.ss @@ -1,71 +1,72 @@ -(module updater mzscheme - (require mzlib/file mzlib/port net/url setup/plt-installer mred framework - "info.ss" "this-collection.ss") - (define name (#%info-lookup 'name)) - (define web-address (#%info-lookup 'web-address)) - (define version-filename (#%info-lookup 'version-filename)) - (define package-filename (#%info-lookup 'package-filename)) - (define dialog-title (string-append name " Updater")) - (define (file->inport filename) - (get-pure-port - (string->url - (string-append (regexp-replace #rx"/?$" web-address "/") filename)))) - (define update-key (make-my-key 'update-check)) - (preferences:set-default update-key #t boolean?) +#lang scheme/base +(require scheme/file scheme/port net/url setup/plt-installer mred framework + "info.ss" "this-collection.ss") - (define (update!) - (let* ([in (file->inport package-filename)] - [outf (make-temporary-file "tmp~a.plt")] - [out (open-output-file outf 'binary 'truncate)]) - (dynamic-wind void - (lambda () (copy-port in out)) - (lambda () (close-input-port in) (close-output-port out))) - (run-installer outf (lambda () (delete-file outf))))) - (define (maybe-update parent new-version) - (define response - (message-box/custom - dialog-title - (string-append - "A new version of the "name" plugin is available: " - (let ([v (format "~a" new-version)]) - (if (= 12 (string-length v)) - (apply format "~a~a~a~a/~a~a/~a~a ~a~a:~a~a" (string->list v)) - v))) - "&Update now" "Remind Me &Later" - ;; may be disabled, but explicitly invoked through menu item - (if (preferences:get update-key) - "&Stop Checking" "Update and &Always Check") - parent '(default=1 caution) 2)) - (case response - [(1) (update!)] - [(2) 'ok] ; do nothing - [(3) (preferences:set update-key (not (preferences:get update-key))) - (when (preferences:get update-key) (update!))] - [else (error 'update "internal error in ~a plugin updater" name)])) - (provide update) - (define (update parent . show-ok?) - (let* ([web-version - (with-handlers ([void (lambda _ 0)]) - (let ([in (file->inport version-filename)]) - (dynamic-wind void - (lambda () (read in)) - (lambda () (close-input-port in)))))] - ;; if the file was not there, we might have read some junk - [web-version (if (integer? web-version) web-version 0)] - [current-version - (with-input-from-file (in-this-collection "version") read)]) - (cond [(> web-version current-version) (maybe-update parent web-version)] - [(and (pair? show-ok?) (car show-ok?)) - (message-box dialog-title "Your plugin is up-to-date" parent)]))) +(define name (#%info-lookup 'name)) +(define web-address (#%info-lookup 'web-address)) +(define version-filename (#%info-lookup 'version-filename)) +(define package-filename (#%info-lookup 'package-filename)) +(define dialog-title (string-append name " Updater")) +(define (file->inport filename) + (get-pure-port + (string->url + (string-append (regexp-replace #rx"/?$" web-address "/") filename)))) +(define update-key (make-my-key 'update-check)) +(preferences:set-default update-key #t boolean?) - (define (wait-for-top-level-windows) - ;; wait until the definitions are instantiated, return top-level window - (let ([ws (get-top-level-windows)]) - (if (null? ws) (begin (sleep 1) (wait-for-top-level-windows)) (car ws)))) - (provide bg-update) - (define (bg-update) - (thread (lambda () - (when (preferences:get update-key) - (update (wait-for-top-level-windows)))))) +(define (update!) + (let* ([in (file->inport package-filename)] + [outf (make-temporary-file "tmp~a.plt")] + [out (open-output-file outf 'binary 'truncate)]) + (dynamic-wind + void + (lambda () (copy-port in out)) + (lambda () (close-input-port in) (close-output-port out))) + (run-installer outf (lambda () (delete-file outf))))) +(define (maybe-update parent new-version) + (define response + (message-box/custom + dialog-title + (string-append + "A new version of the "name" plugin is available: " + (let ([v (format "~a" new-version)]) + (if (= 12 (string-length v)) + (apply format "~a~a~a~a/~a~a/~a~a ~a~a:~a~a" (string->list v)) + v))) + "&Update now" "Remind Me &Later" + ;; may be disabled, but explicitly invoked through menu item + (if (preferences:get update-key) + "&Stop Checking" "Update and &Always Check") + parent '(default=1 caution) 2)) + (case response + [(1) (update!)] + [(2) 'ok] ; do nothing + [(3) (preferences:set update-key (not (preferences:get update-key))) + (when (preferences:get update-key) (update!))] + [else (error 'update "internal error in ~a plugin updater" name)])) +(provide update) +(define (update parent . show-ok?) + (let* ([web-version + (with-handlers ([void (lambda _ 0)]) + (let ([in (file->inport version-filename)]) + (dynamic-wind + void + (lambda () (read in)) + (lambda () (close-input-port in)))))] + ;; if the file was not there, we might have read some junk + [web-version (if (integer? web-version) web-version 0)] + [current-version + (with-input-from-file (in-this-collection "version") read)]) + (cond [(> web-version current-version) (maybe-update parent web-version)] + [(and (pair? show-ok?) (car show-ok?)) + (message-box dialog-title "Your plugin is up-to-date" parent)]))) - ) +(define (wait-for-top-level-windows) + ;; wait until the definitions are instantiated, return top-level window + (let ([ws (get-top-level-windows)]) + (if (null? ws) (begin (sleep 1) (wait-for-top-level-windows)) (car ws)))) +(provide bg-update) +(define (bg-update) + (thread (lambda () + (when (preferences:get update-key) + (update (wait-for-top-level-windows)))))) From 78632e178d7f446a3a60687d1be3cef2797d740c Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 12 Sep 2008 15:23:05 +0000 Subject: [PATCH 08/10] svn: r11682 --- collects/handin-server/utils.ss | 54 ++++++++++++++------------------- 1 file changed, 22 insertions(+), 32 deletions(-) diff --git a/collects/handin-server/utils.ss b/collects/handin-server/utils.ss index f3042d99fd..41153f73cd 100644 --- a/collects/handin-server/utils.ss +++ b/collects/handin-server/utils.ss @@ -1,11 +1,7 @@ #lang scheme/base -(require scheme/list - scheme/class - mred - lang/posn +(require scheme/class mred lang/posn scheme/pretty (prefix-in pc: mzlib/pconvert) - scheme/pretty (only-in "main.ss" timeout-control) "private/run-status.ss" "private/config.ss" @@ -13,29 +9,29 @@ "sandbox.ss") (provide (all-from-out "sandbox.ss") - + get-conf log-line - + unpack-submission - + make-evaluator/submission evaluate-all evaluate-submission - + call-with-evaluator call-with-evaluator/submission reraise-exn-as-submission-problem set-run-status message current-value-printer - + check-proc check-defined look-for-tests user-construct test-history-enabled - + timeout-control) (define (unpack-submission str) @@ -76,8 +72,8 @@ (define (reraise-exn-as-submission-problem thunk) (with-handlers ([void (lambda (exn) (error (if (exn? exn) - (exn-message exn) - (format "exception: ~e" exn))))]) + (exn-message exn) + (format "exception: ~e" exn))))]) (thunk))) ;; ---------------------------------------- @@ -98,10 +94,10 @@ (define (format-history one-test) (if (test-history-enabled) - (format "(begin~a)" - (apply string-append (map (lambda (s) (format " ~a" s)) - (reverse (test-history))))) - one-test)) + (format "(begin~a)" + (apply string-append (map (lambda (s) (format " ~a" s)) + (reverse (test-history))))) + one-test)) (define (check-proc e result equal? f . args) (let ([test (format "(~a~a)" f @@ -125,9 +121,7 @@ (unless ok? (error (format "instructor-supplied test ~a should have produced ~e, instead produced ~e" - (format-history test) - result - val))) + (format-history test) result val))) val))) (define (user-construct e func . args) @@ -138,18 +132,14 @@ (let loop ([found 0]) (let ([e (read p)]) (if (eof-object? e) - (when (found . < . count) - (error (format "found ~a test~a for ~a, need at least ~a test~a" - found - (if (= found 1) "" "s") - name - count - (if (= count 1) "" "s")))) - (loop (+ found - (if (and (pair? e) - (eq? (car e) name)) - 1 - 0)))))))) + (when (found . < . count) + (error (format "found ~a test~a for ~a, need at least ~a test~a" + found + (if (= found 1) "" "s") + name + count + (if (= count 1) "" "s")))) + (loop (+ found (if (and (pair? e) (eq? (car e) name)) 1 0)))))))) (define list-abbreviation-enabled (make-parameter #f)) From 0c0630d50d7c23a00f14ac5ead8cdce18c8501f6 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 12 Sep 2008 15:30:38 +0000 Subject: [PATCH 09/10] more v4-isms svn: r11683 --- collects/handin-server/private/config.ss | 201 +++++++++++------------ collects/handin-server/private/logger.ss | 143 ++++++++-------- collects/handin-server/private/md5.ss | 10 +- 3 files changed, 177 insertions(+), 177 deletions(-) diff --git a/collects/handin-server/private/config.ss b/collects/handin-server/private/config.ss index e90432ad26..2625ccf4c5 100644 --- a/collects/handin-server/private/config.ss +++ b/collects/handin-server/private/config.ss @@ -1,111 +1,110 @@ -(module config mzscheme - (require mzlib/file mzlib/list) +#lang scheme/base - ;; This module should be invoked when we're in the server directory - (provide server-dir) - (define server-dir (or (getenv "PLT_HANDINSERVER_DIR") (current-directory))) +(require scheme/file) - (define config-file (path->complete-path "config.ss" server-dir)) +;; This module should be invoked when we're in the server directory +(provide server-dir) +(define server-dir (or (getenv "PLT_HANDINSERVER_DIR") (current-directory))) - (define poll-freq 2000.0) ; poll at most once every two seconds +(define config-file (path->complete-path "config.ss" server-dir)) - (define last-poll #f) - (define last-filetime #f) - (define raw-config #f) - (define config-cache #f) +(define poll-freq 2000.0) ; poll at most once every two seconds - (provide get-conf) - (define (get-conf key) - (unless (and raw-config - (< (- (current-inexact-milliseconds) last-poll) poll-freq)) - (set! last-poll (current-inexact-milliseconds)) - (let ([filetime (file-or-directory-modify-seconds config-file)]) - (unless (and filetime (equal? filetime last-filetime)) - (set! last-filetime filetime) - (set! raw-config - (with-handlers ([void (lambda (_) - (error 'get-conf - "could not read conf (~a)" - config-file))]) - (when raw-config - ;; can't use log-line from logger, since it makes a cycle - (fprintf (current-error-port) - (format "loading configuration from ~a\n" - config-file))) - (with-input-from-file config-file read))) - (set! config-cache (make-hash-table))))) - (hash-table-get config-cache key - (lambda () - (let*-values ([(default translate) (config-default+translate key)] - ;; translate = #f => this is a computed value - [(v) (if translate - (translate (cond [(assq key raw-config) => cadr] - [else default])) - default)]) - (hash-table-put! config-cache key v) - v)))) +(define last-poll #f) +(define last-filetime #f) +(define raw-config #f) +(define config-cache #f) - (define (id x) x) - (define (rx s) (if (regexp? s) s (regexp s))) - (define (path p) (path->complete-path p server-dir)) - (define (path/false p) (and p (path p))) - (define (path-list l) (map path l)) +(provide get-conf) +(define (get-conf key) + (unless (and raw-config + (< (- (current-inexact-milliseconds) last-poll) poll-freq)) + (set! last-poll (current-inexact-milliseconds)) + (let ([filetime (file-or-directory-modify-seconds config-file)]) + (unless (and filetime (equal? filetime last-filetime)) + (set! last-filetime filetime) + (set! raw-config + (with-handlers ([void (lambda (_) + (error 'get-conf + "could not read conf (~a)" + config-file))]) + (when raw-config + ;; can't use log-line from logger, since it makes a cycle + (fprintf (current-error-port) + (format "loading configuration from ~a\n" + config-file))) + (with-input-from-file config-file read))) + (set! config-cache (make-hasheq))))) + (hash-ref config-cache key + (lambda () + (let*-values ([(default translate) (config-default+translate key)] + ;; translate = #f => this is a computed value + [(v) (if translate + (translate (cond [(assq key raw-config) => cadr] + [else default])) + default)]) + (hash-set! config-cache key v) + v)))) - (define (config-default+translate which) - (case which - [(active-dirs) (values '() path-list )] - [(inactive-dirs) (values '() path-list )] - [(port-number) (values 7979 id )] - [(https-port-number) (values #f id )] - [(hook-file) (values #f path/false )] - [(session-timeout) (values 300 id )] - [(session-memory-limit) (values 40000000 id )] - [(default-file-name) (values "handin.scm" id )] - [(max-upload) (values 500000 id )] - [(max-upload-keep) (values 9 id )] - [(user-regexp) (values #rx"^[a-z][a-z0-9]+$" rx )] - [(user-desc) (values "alphanumeric string" id )] - [(username-case-sensitive) (values #f id )] - [(allow-new-users) (values #f id )] - [(allow-change-info) (values #f id )] - [(master-password) (values #f id )] - [(web-base-dir) (values #f path/false )] - [(log-output) (values #t id )] - [(log-file) (values "log" path/false )] - [(web-log-file) (values #f path/false )] - [(extra-fields) - (values '(("Full Name" #f #f) - ("ID#" #f #f) - ("Email" #rx"^[^@<>\"`',]+@[a-zA-Z0-9_.-]+[.][a-zA-Z]+$" - "a valid email address")) - id)] - ;; computed from the above (mark by translate = #f) - [(all-dirs) - (values (append (get-conf 'active-dirs) (get-conf 'inactive-dirs)) #f)] - [(names-dirs) ; see below - (values (paths->map (get-conf 'all-dirs)) #f)] - [(user-fields) - (values (filter (lambda (f) (not (eq? '- (cadr f)))) - (get-conf 'extra-fields)) - #f)] - [else (error 'get-conf "unknown configuration entry: ~s" which)])) +(define (id x) x) +(define (rx s) (if (regexp? s) s (regexp s))) +(define (path p) (path->complete-path p server-dir)) +(define (path/false p) (and p (path p))) +(define (path-list l) (map path l)) - ;; This is used below to map names to submission directory paths and back - ;; returns a (list-of (either (list name path) (list path name))) - (define (paths->map dirs) - (define (path->name dir) - (unless (directory-exists? dir) - (error 'get-conf - "directory entry for an inexistent directory: ~e" dir)) - (let-values ([(_1 name _2) (split-path dir)]) - (bytes->string/locale (path-element->bytes name)))) - (let ([names (map path->name dirs)]) - (append (map list names dirs) (map list dirs names)))) +(define (config-default+translate which) + (case which + [(active-dirs) (values '() path-list )] + [(inactive-dirs) (values '() path-list )] + [(port-number) (values 7979 id )] + [(https-port-number) (values #f id )] + [(hook-file) (values #f path/false )] + [(session-timeout) (values 300 id )] + [(session-memory-limit) (values 40000000 id )] + [(default-file-name) (values "handin.scm" id )] + [(max-upload) (values 500000 id )] + [(max-upload-keep) (values 9 id )] + [(user-regexp) (values #rx"^[a-z][a-z0-9]+$" rx )] + [(user-desc) (values "alphanumeric string" id )] + [(username-case-sensitive) (values #f id )] + [(allow-new-users) (values #f id )] + [(allow-change-info) (values #f id )] + [(master-password) (values #f id )] + [(web-base-dir) (values #f path/false )] + [(log-output) (values #t id )] + [(log-file) (values "log" path/false )] + [(web-log-file) (values #f path/false )] + [(extra-fields) + (values '(("Full Name" #f #f) + ("ID#" #f #f) + ("Email" #rx"^[^@<>\"`',]+@[a-zA-Z0-9_.-]+[.][a-zA-Z]+$" + "a valid email address")) + id)] + ;; computed from the above (mark by translate = #f) + [(all-dirs) + (values (append (get-conf 'active-dirs) (get-conf 'inactive-dirs)) #f)] + [(names-dirs) ; see below + (values (paths->map (get-conf 'all-dirs)) #f)] + [(user-fields) + (values (filter (lambda (f) (not (eq? '- (cadr f)))) + (get-conf 'extra-fields)) + #f)] + [else (error 'get-conf "unknown configuration entry: ~s" which)])) - ;; Translates an assignment name to a directory path or back - (provide assignment<->dir) - (define (assignment<->dir a/d) - (cond [(assoc a/d (get-conf 'names-dirs)) => cadr] - [else (error 'assignment<->dir "internal error: ~e" a/d)])) +;; This is used below to map names to submission directory paths and back +;; returns a (list-of (either (list name path) (list path name))) +(define (paths->map dirs) + (define (path->name dir) + (unless (directory-exists? dir) + (error 'get-conf + "directory entry for an inexistent directory: ~e" dir)) + (let-values ([(_1 name _2) (split-path dir)]) + (bytes->string/locale (path-element->bytes name)))) + (let ([names (map path->name dirs)]) + (append (map list names dirs) (map list dirs names)))) - ) +;; Translates an assignment name to a directory path or back +(provide assignment<->dir) +(define (assignment<->dir a/d) + (cond [(assoc a/d (get-conf 'names-dirs)) => cadr] + [else (error 'assignment<->dir "internal error: ~e" a/d)])) diff --git a/collects/handin-server/private/logger.ss b/collects/handin-server/private/logger.ss index 4ef14de3e2..2246c88fb2 100644 --- a/collects/handin-server/private/logger.ss +++ b/collects/handin-server/private/logger.ss @@ -1,77 +1,78 @@ -(module logger mzscheme - (require "config.ss" mzlib/date mzlib/port) +#lang scheme/base - (provide current-session) - (define current-session (make-parameter #f)) +(require "config.ss" scheme/date scheme/port) - ;; A convenient function to print log lines (which really just assembles a - ;; string to print in one shot, and flushes the output) - (provide log-line) - (define (log-line fmt . args) - (let ([line (format "~a\n" (apply format fmt args))]) - (display line (current-error-port)))) +(provide current-session) +(define current-session (make-parameter #f)) - (define (prefix) - (parameterize ([date-display-format 'iso-8601]) - (format "[~a|~a] " - (or (current-session) '-) - (date->string (seconds->date (current-seconds)) #t)))) +;; A convenient function to print log lines (which really just assembles a +;; string to print in one shot, and flushes the output) +(provide log-line) +(define (log-line fmt . args) + (let ([line (format "~a\n" (apply format fmt args))]) + (display line (current-error-port)))) - (define (combine-outputs o1 o2) - (let-values ([(i o) (make-pipe)]) - (thread - (lambda () - (let loop () - (let ([line (read-bytes-line i)]) - (if (eof-object? line) - (begin (close-output-port o1) (close-output-port o2)) - (begin (write-bytes line o1) (newline o1) (flush-output o1) - (write-bytes line o2) (newline o2) (flush-output o2) - (loop))))))) - o)) +(define (prefix) + (parameterize ([date-display-format 'iso-8601]) + (format "[~a|~a] " + (or (current-session) '-) + (date->string (seconds->date (current-seconds)) #t)))) - ;; Implement a logger by making the current-error-port show prefix tags and - ;; output the line on the output port - (define (make-logger-port out log) - (if (and (not out) (not log)) - ;; /dev/null-like output port - (make-output-port 'nowhere - always-evt - (lambda (buf start end imm? break?) (- end start)) - void) - (let ([prompt? #t] - [sema (make-semaphore 1)] - [outp (cond [(not log) out] - [(not out) log] - [else (combine-outputs out log)])]) - (make-output-port - 'logger-output - outp - (lambda (buf start end imm? break?) - (dynamic-wind - (lambda () (semaphore-wait sema)) - (lambda () - (if (= start end) - (begin (flush-output outp) 0) - (let ([nl (regexp-match-positions #rx#"\n" buf start end)]) - ;; may be problematic if this hangs... - (when prompt? (display (prefix) outp) (set! prompt? #f)) - (if (not nl) - (write-bytes-avail* buf outp start end) - (let* ([nl (cdar nl)] - [l (write-bytes-avail* buf outp start nl)]) - (when (= l (- nl start)) - ;; pre-newline part written - (flush-output outp) (set! prompt? #t)) - l))))) - (lambda () (semaphore-post sema)))) - (lambda () (close-output-port outp)))))) +(define (combine-outputs o1 o2) + (let-values ([(i o) (make-pipe)]) + (thread + (lambda () + (let loop () + (let ([line (read-bytes-line i)]) + (if (eof-object? line) + (begin (close-output-port o1) (close-output-port o2)) + (begin (write-bytes line o1) (newline o1) (flush-output o1) + (write-bytes line o2) (newline o2) (flush-output o2) + (loop))))))) + o)) - ;; Install this wrapper as the current error port - (provide install-logger-port) - (define (install-logger-port) - (current-error-port - (make-logger-port - (and (get-conf 'log-output) (current-output-port)) - (cond [(get-conf 'log-file) => (lambda (f) (open-output-file f 'append))] - [else #f]))))) +;; Implement a logger by making the current-error-port show prefix tags and +;; output the line on the output port +(define (make-logger-port out log) + (if (and (not out) (not log)) + ;; /dev/null-like output port + (make-output-port 'nowhere + always-evt + (lambda (buf start end imm? break?) (- end start)) + void) + (let ([prompt? #t] + [sema (make-semaphore 1)] + [outp (cond [(not log) out] + [(not out) log] + [else (combine-outputs out log)])]) + (make-output-port + 'logger-output + outp + (lambda (buf start end imm? break?) + (dynamic-wind + (lambda () (semaphore-wait sema)) + (lambda () + (if (= start end) + (begin (flush-output outp) 0) + (let ([nl (regexp-match-positions #rx#"\n" buf start end)]) + ;; may be problematic if this hangs... + (when prompt? (display (prefix) outp) (set! prompt? #f)) + (if (not nl) + (write-bytes-avail* buf outp start end) + (let* ([nl (cdar nl)] + [l (write-bytes-avail* buf outp start nl)]) + (when (= l (- nl start)) + ;; pre-newline part written + (flush-output outp) (set! prompt? #t)) + l))))) + (lambda () (semaphore-post sema)))) + (lambda () (close-output-port outp)))))) + +;; Install this wrapper as the current error port +(provide install-logger-port) +(define (install-logger-port) + (current-error-port + (make-logger-port + (and (get-conf 'log-output) (current-output-port)) + (cond [(get-conf 'log-file) => (lambda (f) (open-output-file f 'append))] + [else #f])))) diff --git a/collects/handin-server/private/md5.ss b/collects/handin-server/private/md5.ss index 3471326533..91fadac41a 100644 --- a/collects/handin-server/private/md5.ss +++ b/collects/handin-server/private/md5.ss @@ -1,5 +1,5 @@ -(module md5 mzscheme - (require (prefix mz: mzlib/md5)) - (define (md5 s) - (bytes->string/latin-1 (mz:md5 (string->bytes/utf-8 s)))) - (provide md5)) +#lang scheme/base +(require (prefix-in mz: file/md5)) +(define (md5 s) + (bytes->string/latin-1 (mz:md5 (string->bytes/utf-8 s)))) +(provide md5) From 5541890dd5027cf70151de9782f8005a704dc0cb Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 12 Sep 2008 15:41:34 +0000 Subject: [PATCH 10/10] yet more v4-isms svn: r11684 --- collects/handin-server/checker.ss | 40 +++---- collects/handin-server/main.ss | 68 +++++------ collects/handin-server/private/hooker.ss | 27 +++-- collects/handin-server/private/lock.ss | 117 +++++++++---------- collects/handin-server/private/reloadable.ss | 84 +++++++------ collects/handin-server/private/run-status.ss | 32 +++-- 6 files changed, 173 insertions(+), 195 deletions(-) diff --git a/collects/handin-server/checker.ss b/collects/handin-server/checker.ss index ced5594804..01abf7ab88 100644 --- a/collects/handin-server/checker.ss +++ b/collects/handin-server/checker.ss @@ -191,10 +191,8 @@ ;; This code will hack textualization of text boxes (define (insert-to-editor editor . xs) - (for-each (lambda (x) - (send editor insert - (if (string? x) x (make-object editor-snip% x)))) - xs)) + (for ([x xs]) + (send editor insert (if (string? x) x (make-object editor-snip% x))))) ;; support for "text-box%" (define text-box-sc @@ -284,10 +282,9 @@ '(ok-cancel caution))))) (error* "Aborting..."))) ;; This will create copies of the original files - ;; (for-each (lambda (file) - ;; (with-output-to-file (car file) - ;; (lambda () (display (cadr file)) (flush-output)))) - ;; files) + ;; (for ([file files]) + ;; (with-output-to-file (car file) + ;; (lambda () (display (cadr file)) (flush-output)))) (let* ([pfx-len (string-length markup-prefix)] [line-len (- maxwidth pfx-len)] [=s (lambda (n) (if (<= 0 n) (make-string n #\=) ""))] @@ -301,14 +298,12 @@ (display ===) (newline)) (parameterize ([current-output-port (open-output-bytes)]) - (for-each (lambda (file) - (sep (car file)) - (parameterize ([current-input-port - (open-input-bytes (cadr file))] - [current-processed-file (car file)]) - (input->process->output - maxwidth textualize? untabify? prefix-re))) - files) + (for ([file files]) + (sep (car file)) + (parameterize ([current-input-port (open-input-bytes (cadr file))] + [current-processed-file (car file)]) + (input->process->output + maxwidth textualize? untabify? prefix-re))) (get-output-bytes (current-output-port)))))) ;; ============================================================================ @@ -394,10 +389,9 @@ [user-post (id 'user-post)] [(body ...) (syntax-case #'(body ...) () [() #'(void)] [_ #'(body ...)])]) - (for-each (lambda (x) - (unless (memq (car x) got) - (raise-syntax-error #f "unknown keyword" stx (cadr x)))) - keyvals) + (for ([x keyvals]) + (unless (memq (car x) got) + (raise-syntax-error #f "unknown keyword" stx (cadr x)))) #'(begin (provide checker) (define checker @@ -476,10 +470,8 @@ (set-run-status "creating text file") (with-output-to-file text-file #:exists 'truncate (lambda () - (for-each (lambda (user) - (prefix-line - (user-substs user student-line))) - users) + (for ([user users]) + (prefix-line (user-substs user student-line))) (for-each prefix-line/substs extra-lines) (for-each prefix-line/substs (or (thread-cell-ref added-lines) '())) diff --git a/collects/handin-server/main.ss b/collects/handin-server/main.ss index 59174ad353..260ef0a1ea 100644 --- a/collects/handin-server/main.ss +++ b/collects/handin-server/main.ss @@ -24,7 +24,7 @@ (error (apply format fmt args))) (define (write+flush port . xs) - (for-each (lambda (x) (write x port) (newline port)) xs) + (for ([x xs]) (write x port) (newline port)) (flush-output port)) (define-struct alist (name [l #:mutable])) @@ -87,20 +87,18 @@ ;; SUCCESS, or things that are newer in the main submission ;; directory are kept (but subdirs in SUCCESS will are copied as ;; is)) - (for-each - (lambda (f) - (define dir/f (build-path dir f)) - (cond [(not (or (file-exists? f) (directory-exists? f))) - ;; f is in dir but not in the working directory - (copy-directory/files dir/f f)] - [(or (<= (file-or-directory-modify-seconds f) - (file-or-directory-modify-seconds dir/f)) - (and (file-exists? f) (file-exists? dir/f) - (not (= (file-size f) (file-size dir/f))))) - ;; f is newer in dir than in the working directory - (delete-directory/files f) - (copy-directory/files dir/f f)])) - (directory-list dir))))) + (for ([f (directory-list dir)]) + (define dir/f (build-path dir f)) + (cond [(not (or (file-exists? f) (directory-exists? f))) + ;; f is in dir but not in the working directory + (copy-directory/files dir/f f)] + [(or (<= (file-or-directory-modify-seconds f) + (file-or-directory-modify-seconds dir/f)) + (and (file-exists? f) (file-exists? dir/f) + (not (= (file-size f) (file-size dir/f))))) + ;; f is newer in dir than in the working directory + (delete-directory/files f) + (copy-directory/files dir/f f)]))))) (define cleanup-sema (make-semaphore 1)) (define (cleanup-submission dir) @@ -118,14 +116,12 @@ (define (cleanup-all-submissions) (log-line "Cleaning up all submission directories") - (for-each (lambda (pset) - (when (directory-exists? pset) ; just in case - (parameterize ([current-directory pset]) - (for-each (lambda (sub) - (when (directory-exists? sub) ; filter non-dirs - (cleanup-submission sub))) - (directory-list))))) - (get-conf 'all-dirs))) + (for ([pset (get-conf 'all-dirs)] + #:when (directory-exists? pset)) ; just in case + (parameterize ([current-directory pset]) + (for ([sub (directory-list)] + #:when (directory-exists? sub)) ; filter non-dirs + (cleanup-submission sub))))) ;; On startup, we scan all submissions, then repeat at random intervals (only ;; if clients connected in that time), and check often for changes in the @@ -193,15 +189,11 @@ ;; we have a submission, need to create a directory if needed, make ;; sure that no users submitted work with someone else (unless (directory-exists? dirname) - (for-each - (lambda (dir) - (for-each - (lambda (d) - (when (member d users) - (error* "bad submission: ~a has an existing submission (~a)" - d dir))) - (regexp-split #rx" *[+] *" (path->string dir)))) - (directory-list)) + (for* ([dir (directory-list)] + [d (regexp-split #rx" *[+] *" (path->string dir))]) + (when (member d users) + (error* "bad submission: ~a has an existing submission (~a)" + d dir))) (make-directory dirname)) (parameterize ([current-directory dirname] [current-messenger @@ -378,9 +370,9 @@ (error* "the username \"checker.ss\" is reserved")) (when (get-user-data username) (error* "username already exists: `~a'" username)) - (for-each (lambda (str info) - (check-field str (cadr info) (car info) (caddr info))) - extra-fields (get-conf 'extra-fields)) + (for ([str extra-fields] + [info (get-conf 'extra-fields)]) + (check-field str (cadr info) (car info) (caddr info))) (wait-for-lock "+newuser+") (log-line "create user: ~a" username) (hook 'user-create `([username ,username] [fields ,extra-fields])) @@ -405,9 +397,9 @@ (error* "changing information not allowed: ~a" username)) (when (equal? new-data old-data) (error* "no fields changed: ~a" username)) - (for-each (lambda (str info) - (check-field str (cadr info) (car info) (caddr info))) - (cdr new-data) (get-conf 'extra-fields)) + (for ([str (cdr new-data)] + [info (get-conf 'extra-fields)]) + (check-field str (cadr info) (car info) (caddr info))) (log-line "change info for ~a ~s -> ~s" username old-data new-data) (unless (equal? (cdr new-data) (cdr old-data)) ; not for password change (hook 'user-change `([username ,username] diff --git a/collects/handin-server/private/hooker.ss b/collects/handin-server/private/hooker.ss index ef40587927..f8ae54b0f2 100644 --- a/collects/handin-server/private/hooker.ss +++ b/collects/handin-server/private/hooker.ss @@ -1,18 +1,17 @@ -(module hooker mzscheme - (require "config.ss" "logger.ss" "reloadable.ss") +#lang scheme/base - (provide hook) +(require "config.ss" "logger.ss" "reloadable.ss") - (define hook-file #f) - (define hook-proc #f) +(provide hook) - (define (hook what alist) - (let ([file (get-conf 'hook-file)]) - (when file - (unless (equal? file hook-file) - (set! hook-file file) - (set! hook-proc (auto-reload-procedure `(file ,(path->string file)) - 'hook))) - (hook-proc what (current-session) alist)))) +(define hook-file #f) +(define hook-proc #f) - ) +(define (hook what alist) + (let ([file (get-conf 'hook-file)]) + (when file + (unless (equal? file hook-file) + (set! hook-file file) + (set! hook-proc (auto-reload-procedure `(file ,(path->string file)) + 'hook))) + (hook-proc what (current-session) alist)))) diff --git a/collects/handin-server/private/lock.ss b/collects/handin-server/private/lock.ss index 870cbb5bbc..9804eb8f0c 100644 --- a/collects/handin-server/private/lock.ss +++ b/collects/handin-server/private/lock.ss @@ -1,64 +1,63 @@ -(module lock mzscheme - (require mzlib/list) +#lang scheme/base - (provide wait-for-lock) +(provide wait-for-lock) - ;; wait-for-lock : string -> void - ;; Gets a lock on `user' for the calling thread; the lock lasts until the - ;; calling thread terminates. If the lock was actually acquired, then on - ;; release the cleanup-thunk will be executed (unless it is #f), even if it - ;; was released when the acquiring thread crashed. - ;; *** Warning: It's vital that a clean-up thunk doesn't raise an exception, - ;; since this will kill the lock thread which will lock down everything - (define (wait-for-lock user . cleanup-thunk) - (let ([s (make-semaphore)]) - (channel-put req-ch - (make-req (thread-dead-evt (current-thread)) user s - (and (pair? cleanup-thunk) (car cleanup-thunk)))) - (semaphore-wait s))) +;; wait-for-lock : string -> void +;; Gets a lock on `user' for the calling thread; the lock lasts until the +;; calling thread terminates. If the lock was actually acquired, then on +;; release the cleanup-thunk will be executed (unless it is #f), even if it +;; was released when the acquiring thread crashed. +;; *** Warning: It's vital that a clean-up thunk doesn't raise an exception, +;; since this will kill the lock thread which will lock down everything +(define (wait-for-lock user . cleanup-thunk) + (let ([s (make-semaphore)]) + (channel-put req-ch + (make-req (thread-dead-evt (current-thread)) user s + (and (pair? cleanup-thunk) (car cleanup-thunk)))) + (semaphore-wait s))) - (define req-ch (make-channel)) +(define req-ch (make-channel)) - (define-struct req (thread-dead-evt user sema cleanup-thunk)) +(define-struct req (thread-dead-evt user sema cleanup-thunk)) - (thread - (lambda () - (let loop ([locks null] - [reqs null]) - (let-values ([(locks reqs) - ;; Try to satisfy lock requests: - (let loop ([reqs (reverse reqs)] - [locks locks] - [new-reqs null]) - (if (null? reqs) - (values locks new-reqs) - (let ([req (car reqs)] - [rest (cdr reqs)]) - (if (assoc (req-user req) locks) - ;; Lock not available: - (loop rest locks (cons req new-reqs)) - ;; Lock is available, so take it: - (begin (semaphore-post (req-sema req)) - (loop (cdr reqs) - (cons (cons (req-user req) req) locks) - new-reqs))))))]) - (sync - (handle-evt req-ch (lambda (req) (loop locks (cons req reqs)))) - ;; Release a lock whose thread is gone: - (apply choice-evt - (map (lambda (name+req) - (handle-evt - (req-thread-dead-evt (cdr name+req)) - (lambda (v) - ;; releasing a lock => run cleanup - (cond [(req-cleanup-thunk (cdr name+req)) - => (lambda (t) (t))]) - (loop (remq name+req locks) reqs)))) - locks)) - ;; Throw away a request whose thread is gone: - (apply choice-evt - (map (lambda (req) - (handle-evt - (req-thread-dead-evt req) - (lambda (v) (loop locks (remq req reqs))))) - reqs)))))))) +(thread + (lambda () + (let loop ([locks null] + [reqs null]) + (let-values ([(locks reqs) + ;; Try to satisfy lock requests: + (let loop ([reqs (reverse reqs)] + [locks locks] + [new-reqs null]) + (if (null? reqs) + (values locks new-reqs) + (let ([req (car reqs)] + [rest (cdr reqs)]) + (if (assoc (req-user req) locks) + ;; Lock not available: + (loop rest locks (cons req new-reqs)) + ;; Lock is available, so take it: + (begin (semaphore-post (req-sema req)) + (loop (cdr reqs) + (cons (cons (req-user req) req) locks) + new-reqs))))))]) + (sync + (handle-evt req-ch (lambda (req) (loop locks (cons req reqs)))) + ;; Release a lock whose thread is gone: + (apply choice-evt + (map (lambda (name+req) + (handle-evt + (req-thread-dead-evt (cdr name+req)) + (lambda (v) + ;; releasing a lock => run cleanup + (cond [(req-cleanup-thunk (cdr name+req)) + => (lambda (t) (t))]) + (loop (remq name+req locks) reqs)))) + locks)) + ;; Throw away a request whose thread is gone: + (apply choice-evt + (map (lambda (req) + (handle-evt + (req-thread-dead-evt req) + (lambda (v) (loop locks (remq req reqs))))) + reqs))))))) diff --git a/collects/handin-server/private/reloadable.ss b/collects/handin-server/private/reloadable.ss index ff8be9f1aa..defa9a8fc7 100644 --- a/collects/handin-server/private/reloadable.ss +++ b/collects/handin-server/private/reloadable.ss @@ -1,48 +1,46 @@ -(module reloadable mzscheme +#lang scheme/base - (require syntax/moddep "logger.ss") +(require syntax/moddep "logger.ss") - (provide reload-module) - (define (reload-module modspec path) - ;; the path argument is not needed (could use resolve-module-path here), - ;; but its always known when this function is called - (let* ([name ((current-module-name-resolver) modspec #f #f)]) - (log-line "(re)loading module from ~a" modspec) - (parameterize ([current-module-declare-name name] - [compile-enforce-module-constants #f]) - (namespace-require '(only mzscheme module #%top-interaction)) - (load/use-compiled path)))) +(provide reload-module) +(define (reload-module modspec path) + ;; the path argument is not needed (could use resolve-module-path here), but + ;; its always known when this function is called + (let* ([name ((current-module-name-resolver) modspec #f #f)]) + (log-line "(re)loading module from ~a" modspec) + (parameterize ([current-module-declare-name name] + [compile-enforce-module-constants #f]) + (namespace-require '(only mzscheme module #%top-interaction)) + (load/use-compiled path)))) - ;; pulls out a value from a module, reloading the module if its source file - ;; was modified - (provide auto-reload-value) - (define module-times (make-hash-table 'equal)) - (define (auto-reload-value modspec valname) - (let* ([path (resolve-module-path modspec #f)] - [last (hash-table-get module-times path #f)] - [cur (file-or-directory-modify-seconds path)]) - (unless (equal? cur last) - (hash-table-put! module-times path cur) - (reload-module modspec path)) - (dynamic-require modspec valname))) +;; pulls out a value from a module, reloading the module if its source file was +;; modified +(provide auto-reload-value) +(define module-times (make-hash)) +(define (auto-reload-value modspec valname) + (let* ([path (resolve-module-path modspec #f)] + [last (hash-ref module-times path #f)] + [cur (file-or-directory-modify-seconds path)]) + (unless (equal? cur last) + (hash-set! module-times path cur) + (reload-module modspec path)) + (dynamic-require modspec valname))) - (define poll-freq 2000.0) ; poll at most once every two seconds +(define poll-freq 2000.0) ; poll at most once every two seconds - ;; pulls out a procedure from a module, and returns a wrapped procedure that - ;; automatically reloads the module if the file was changed whenever the - ;; procedure is used - (provide auto-reload-procedure) - (define (auto-reload-procedure modspec procname) - (let ([path (resolve-module-path modspec #f)] [date #f] [proc #f] [poll #f]) - (define (reload) - (unless (and proc (< (- (current-inexact-milliseconds) poll) poll-freq)) - (set! poll (current-inexact-milliseconds)) - (let ([cur (file-or-directory-modify-seconds path)]) - (unless (equal? cur date) - (set! date cur) - (reload-module modspec path) - (set! proc (dynamic-require modspec procname)))))) - (reload) - (lambda xs (reload) (apply proc xs)))) - - ) +;; pulls out a procedure from a module, and returns a wrapped procedure that +;; automatically reloads the module if the file was changed whenever the +;; procedure is used +(provide auto-reload-procedure) +(define (auto-reload-procedure modspec procname) + (let ([path (resolve-module-path modspec #f)] [date #f] [proc #f] [poll #f]) + (define (reload) + (unless (and proc (< (- (current-inexact-milliseconds) poll) poll-freq)) + (set! poll (current-inexact-milliseconds)) + (let ([cur (file-or-directory-modify-seconds path)]) + (unless (equal? cur date) + (set! date cur) + (reload-module modspec path) + (set! proc (dynamic-require modspec procname)))))) + (reload) + (lambda xs (reload) (apply proc xs)))) diff --git a/collects/handin-server/private/run-status.ss b/collects/handin-server/private/run-status.ss index fdb82027c4..b960a81ffc 100644 --- a/collects/handin-server/private/run-status.ss +++ b/collects/handin-server/private/run-status.ss @@ -1,21 +1,19 @@ -(module run-status mzscheme +#lang scheme/base - (provide current-run-status-box set-run-status - current-messenger message) +(provide current-run-status-box set-run-status + current-messenger message) - ;; current-run-status-box is used to let the client know where we are in the - ;; submission process. - (define current-run-status-box (make-parameter #f)) +;; current-run-status-box is used to let the client know where we are in the +;; submission process. +(define current-run-status-box (make-parameter #f)) - ;; current-messenger is a function that will send a message to the client. - (define current-messenger (make-parameter #f)) - (define (message . args) - (let ([messenger (current-messenger)]) - (and messenger (apply messenger args)))) +;; current-messenger is a function that will send a message to the client. +(define current-messenger (make-parameter #f)) +(define (message . args) + (let ([messenger (current-messenger)]) + (and messenger (apply messenger args)))) - ;; Set the current-run-status-box and send a message. - (define (set-run-status s) - (let ([b (current-run-status-box)]) - (when b (set-box! b s) (message s)))) - - ) +;; Set the current-run-status-box and send a message. +(define (set-run-status s) + (let ([b (current-run-status-box)]) + (when b (set-box! b s) (message s))))