let the planet resolver bestow on itself more powerful filesystem inspection capabilities
This commit is contained in:
parent
9e94c8b56c
commit
3ade0eaca9
|
@ -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))])))
|
||||
|
||||
|
||||
;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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))
|
||||
|
||||
;; =============================================================================
|
||||
|
|
Loading…
Reference in New Issue
Block a user