suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

let the planet resolver bestow on itself more powerful filesystem inspection capabilities

Browse Source
This commit is contained in:
Robby Findler 2011-09-07 22:15:50 -05:00
parent 9e94c8b56c
commit 3ade0eaca9
3 changed files with 59 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
collects/drracket/private/unit.rkt
View File

@ -1265,6 +1265,8 @@ module browser threading seems wrong.
(define/public-final (toggle-log)
(set! log-visible? (not log-visible?))
(send frame show/hide-log log-visible?))
(define/public-final (hide-log)
(when log-visible? (toggle-log)))
(define/public-final (update-log)
(send frame show/hide-log log-visible?))
(define/public-final (update-logger-window command)
@ -1431,19 +1433,25 @@ module browser threading seems wrong.
(remq logger-panel l)])))]
[else
(when show? ;; if we want to hide and it isn't built yet, do nothing
(define logger-gui-tab-panel-parent (new horizontal-panel% [parent logger-panel] [stretchable-height #f]))
(set! logger-gui-tab-panel
(new tab-panel%
[choices (list (string-constant logging-all)
"fatal" "error" "warning" "info" "debug")]
[parent logger-panel]
[parent logger-gui-tab-panel-parent]
[stretchable-height #f]
[style '(no-border)]
[callback
(λ (tp evt)
(preferences:set 'drracket:logger-gui-tab-panel-level (send logger-gui-tab-panel get-selection))
(update-logger-window #f))]))
(new button% [label (string-constant hide-log)]
[callback (λ (x y) (send current-tab hide-log))]
[parent logger-gui-tab-panel-parent])
(send logger-gui-tab-panel set-selection (preferences:get 'drracket:logger-gui-tab-panel-level))
(new-logger-text)
(set! logger-gui-canvas
(new editor-canvas% [parent logger-gui-tab-panel] [editor logger-gui-text]))
(new editor-canvas% [parent logger-panel] [editor logger-gui-text]))
(send logger-menu-item set-label (string-constant hide-log))
(update-logger-window #f)
(send logger-parent-panel change-children (lambda (l) (append l (list logger-panel)))))])
@ -3122,8 +3130,7 @@ module browser threading seems wrong.
[label (string-constant show-log)]
[parent show-menu]
[callback
(λ (x y) (send current-tab toggle-log))]))
)
(λ (x y) (send current-tab toggle-log))])))
;

60
collects/planet/private/planet-shared.rkt
View File

@ -78,7 +78,18 @@ Various common pieces of code that both the client and server need to access
check/take-installation-lock
dir->successful-installation-file
dir->unpacked-file
dir->metadata-files)
dir->metadata-files
powerful-security-guard
with-powerful-security-guard)
(define powerful-security-guard (make-parameter #f))
(define-syntax-rule
(with-powerful-security-guard e1 e2 ...)
(with-powerful-security-guard/proc (λ () e1 e2 ...)))
(define (with-powerful-security-guard/proc t)
(parameterize ([current-security-guard (or (powerful-security-guard) (current-security-guard))])
(t)))
; ==========================================================================================
; CACHE LOGIC
@ -222,25 +233,27 @@ Various common pieces of code that both the client and server need to access
;; get-hard-link-table/internal : -> assoc-table
(define (get-hard-link-table/internal)
(verify-well-formed-hard-link-parameter!)
(if (file-exists? (HARD-LINK-FILE))
(map (lambda (item) (update/create-element 6 (λ (_) 'development-link) (update-element 4 bytes->path item)))
(with-input-from-file (HARD-LINK-FILE) read-all))
'()))
(with-powerful-security-guard
(if (file-exists? (HARD-LINK-FILE))
(map (lambda (item) (update/create-element 6 (λ (_) 'development-link) (update-element 4 bytes->path item)))
(with-input-from-file (HARD-LINK-FILE) read-all))
'())))
(define (with-hard-link-lock t)
(let-values ([(base name dir) (split-path (HARD-LINK-FILE))])
(try-make-directory* base))
(call-with-file-lock/timeout
(HARD-LINK-FILE)
'exclusive
t
(λ ()
(error 'planet/planet-shared.rkt "unable to obtain lock on ~s" (HARD-LINK-FILE)))))
(with-powerful-security-guard
(let-values ([(base name dir) (split-path (HARD-LINK-FILE))])
(try-make-directory* base))
(call-with-file-lock/timeout
(HARD-LINK-FILE)
'exclusive
t
(λ ()
(error 'planet/planet-shared.rkt "unable to obtain lock on ~s" (HARD-LINK-FILE))))))
(define (get-hard-link-table)
;; we can only call with-hard-link-lock when the directory containing
;; (HARD-LINK-FILE) exists
(if (file-exists? (HARD-LINK-FILE))
(if (with-powerful-security-guard (file-exists? (HARD-LINK-FILE)))
(with-hard-link-lock
(λ ()
(get-hard-link-table/internal)))
@ -267,14 +280,15 @@ Various common pieces of code that both the client and server need to access
;; assumes that the lock on the HARD-LINK table file has been acquired
(define (save-hard-link-table table)
(verify-well-formed-hard-link-parameter!)
(with-output-to-file (HARD-LINK-FILE) #:exists 'truncate
(lambda ()
(display "")
(for-each
(lambda (row)
(write (update-element 4 path->bytes row))
(newline))
table))))
(with-powerful-security-guard
(with-output-to-file (HARD-LINK-FILE) #:exists 'truncate
(lambda ()
(display "")
(for-each
(lambda (row)
(write (update-element 4 path->bytes row))
(newline))
table)))))
;; add-hard-link! string (listof string) num num path -> void
;; adds the given hard link, clearing any previous ones already in place
@ -770,7 +784,7 @@ Various common pieces of code that both the client and server need to access
;; make sure the lock file exists
(with-handlers ((exn:fail:filesystem:exists? void))
(call-with-output-file lf void))
(define p (open-output-file lf #:exists 'truncate))
(define p (with-powerful-security-guard (open-output-file lf #:exists 'truncate)))
(cond
[(port-try-file-lock? p 'exclusive)
;; we got the lock; keep the file open

20
collects/planet/private/resolver.rkt
View File

@ -341,7 +341,8 @@ See the scribble documentation on the planet/resolver module.
[current-eval (call-with-parameterization orig-paramz current-eval)]
[current-module-declare-name #f]
[use-compiled-file-paths (call-with-parameterization orig-paramz use-compiled-file-paths)]
[current-library-collection-paths (call-with-parameterization orig-paramz current-library-collection-paths)])
[current-library-collection-paths (call-with-parameterization orig-paramz current-library-collection-paths)]
[powerful-security-guard (call-with-parameterization orig-paramz current-security-guard)])
(let-values ([(path pkg) (get-planet-module-path/pkg/internal spec rmp stx load?)])
(when load? (add-pkg-to-diamond-registry! pkg stx))
(do-require path (pkg-path pkg) rmp stx load?))))
@ -485,14 +486,15 @@ See the scribble documentation on the planet/resolver module.
(try-make-directory* dir)
(unless (equal? (normalize-path (uninstalled-pkg-path uninst-p))
(normalize-path full-pkg-path))
(call-with-file-lock/timeout
full-pkg-path
'exclusive
(λ ()
(when (file-exists? full-pkg-path) (delete-file full-pkg-path))
(copy-file (uninstalled-pkg-path uninst-p) full-pkg-path))
(λ ()
(log-error (format "planet/resolver.rkt: unable to save the planet package ~a" full-pkg-path)))))
(parameterize ([current-security-guard (or (powerful-security-guard) (current-security-guard))])
(call-with-file-lock/timeout
full-pkg-path
'exclusive
(λ ()
(when (file-exists? full-pkg-path) (delete-file full-pkg-path))
(copy-file (uninstalled-pkg-path uninst-p) full-pkg-path))
(λ ()
(log-error (format "planet/resolver.rkt: unable to save the planet package ~a" full-pkg-path))))))
full-pkg-path))
;; =============================================================================