trunk merge
svn: r11691
This commit is contained in:
Stevie Strickland
commit
a4c6d310df
File diff suppressed because it is too large
Load Diff
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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 #"<<<MULTI-SUBMISSION-FILE>>>")
|
||||
(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 #"<<<MULTI-SUBMISSION-FILE>>>")
|
||||
(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)))
|
||||
string<?))
|
||||
(if (< 0 (send files-list get-number))
|
||||
(begin (apply do-selections sel+unsel)
|
||||
(send files-list enable #t)
|
||||
(send files-list focus))
|
||||
(begin (send files-list append "no files")
|
||||
(send files-list enable #f))))))
|
||||
(define (choose-dir)
|
||||
(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)))
|
||||
(set-dir
|
||||
(get-directory "Choose a directory with files to submit" this
|
||||
(and (not (equal? ldir "")) ldir)))))
|
||||
(define (refresh-dir)
|
||||
(when dir-selected? (set-dir (current-directory))))
|
||||
(define auto-glob+regexp '(#f #f))
|
||||
(define (globs->regexps 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)))
|
||||
string<?))
|
||||
(if (< 0 (send files-list get-number))
|
||||
(begin (apply do-selections sel+unsel)
|
||||
(send files-list enable #t)
|
||||
(send files-list focus))
|
||||
(begin (send files-list append "no files")
|
||||
(send files-list enable #f))))))
|
||||
(define (choose-dir)
|
||||
(let ([ldir (preferences:get last-dir-key)])
|
||||
(set-dir
|
||||
(get-directory "Choose a directory with files to submit" this
|
||||
(and (not (equal? ldir "")) ldir)))))
|
||||
(define (refresh-dir)
|
||||
(when dir-selected? (set-dir (current-directory))))
|
||||
(define auto-glob+regexp '(#f #f))
|
||||
(define (globs->regexps 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%))
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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))))))
|
||||
|
|
|
|||
|
|
@ -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) '()))
|
||||
|
|
|
|||
|
|
@ -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]
|
||||
|
|
|
|||
|
|
@ -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)]))
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
|
|
@ -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)))))))
|
||||
|
|
|
|||
|
|
@ -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]))))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
#lang scheme/base (provide stamp) (define stamp "11sep2008")
|
||||
#lang scheme/base (provide stamp) (define stamp "12sep2008")
|
||||
|
|
|
|||
|
|
@ -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
|
||||
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")
|
||||
(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}
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user