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

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))])))
-        )
       
       
       ;                                                                                                       

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))
+    (with-powerful-security-guard
-        (map (lambda (item) (update/create-element 6 (λ (_) 'development-link) (update-element 4 bytes->path item)))
+     (if (file-exists? (HARD-LINK-FILE))
-             (with-input-from-file (HARD-LINK-FILE) read-all))
+         (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))])
+    (with-powerful-security-guard
-      (try-make-directory* base))
+     (let-values ([(base name dir) (split-path (HARD-LINK-FILE))])
-    (call-with-file-lock/timeout
+       (try-make-directory* base))
-     (HARD-LINK-FILE)
+     (call-with-file-lock/timeout
-     'exclusive
+      (HARD-LINK-FILE)
-     t
+      'exclusive
-     (λ () 
+      t
-       (error 'planet/planet-shared.rkt "unable to obtain lock on ~s" (HARD-LINK-FILE)))))
+      (λ () 
+        (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
+    (with-powerful-security-guard
-      (lambda ()
+     (with-output-to-file (HARD-LINK-FILE) #:exists 'truncate
-        (display "")
+       (lambda ()
-        (for-each 
+         (display "")
-         (lambda (row)
+         (for-each 
-           (write (update-element 4 path->bytes row))
+          (lambda (row)
-           (newline))
+            (write (update-element 4 path->bytes row))
-         table))))
+            (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

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
+      (parameterize ([current-security-guard (or (powerful-security-guard) (current-security-guard))])
-       full-pkg-path
+        (call-with-file-lock/timeout
-       'exclusive
+         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))
+           (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)))))
+         (λ ()
+           (log-error (format "planet/resolver.rkt: unable to save the planet package ~a" full-pkg-path))))))
     full-pkg-path))
 
 ;; =============================================================================