diff --git a/collects/drracket/private/unit.rkt b/collects/drracket/private/unit.rkt index 6b3bdee01a..8d8afe6504 100644 --- a/collects/drracket/private/unit.rkt +++ b/collects/drracket/private/unit.rkt @@ -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))]))) ; diff --git a/collects/planet/private/planet-shared.rkt b/collects/planet/private/planet-shared.rkt index b68161b3eb..ec274c508a 100644 --- a/collects/planet/private/planet-shared.rkt +++ b/collects/planet/private/planet-shared.rkt @@ -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 diff --git a/collects/planet/private/resolver.rkt b/collects/planet/private/resolver.rkt index 5ff32905a0..772bd9a028 100644 --- a/collects/planet/private/resolver.rkt +++ b/collects/planet/private/resolver.rkt @@ -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)) ;; =============================================================================