pull: Tweak cache directory validation code.

This is a followup to 7c52cad0464175370c44bd4695e4c01a62b8268f.

* guix/scripts/pull.scm (guix-pull): Move cache directory validation
code to...
(validate-cache-directory-ownership): ... here.  New procedure.  Use
SRFI-71 instead of SRFI-11.  Use 'formatted-message' for the error
message, with ASCII quotation marks, and use Texinfo markup for
'&fix-hint'.

1 files changed, 31 insertions, 25 deletions

diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index df683b61c4..b0cc459d63 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -20,6 +20,7 @@
 
 (define-module (guix scripts pull)
   #:use-module ((guix ui) #:hide (display-profile-content))
+  #:use-module (guix diagnostics)
   #:use-module (guix colors)
   #:use-module (guix utils)
   #:use-module ((guix status) #:select (with-status-verbosity))
@@ -49,7 +50,6 @@
   #:autoload   (gnu packages bootstrap) (%bootstrap-guile)
   #:autoload   (gnu packages certs) (le-certs)
   #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
@@ -787,6 +787,35 @@ Use '~/.config/guix/channels.scm' instead."))
            channels))
         channels)))
 
+(define (validate-cache-directory-ownership)
+  "Bail out if the cache directory is not owned by the current user."
+  (let ((stats dir
+               (let loop ((dir (cache-directory)))
+                 (let ((stats (stat dir #f)))
+                   (if stats
+                       (values stats dir)
+                       (loop (dirname dir)))))))
+    (let ((dir:uid (stat:uid stats))
+          (our:uid (getuid)))
+      (unless (= dir:uid our:uid)
+        (let* ((user (lambda (uid)         ;handle the unthinkable invalid UID
+                       (or (false-if-exception (passwd:name
+                                                (getpwuid uid)))
+                           uid)))
+               (our:user (user our:uid))
+               (dir:user (user dir:uid)))
+          (raise
+           (make-compound-condition
+            (formatted-message
+             (G_ "directory '~a' is not owned by user ~a")
+             dir our:user)
+            (condition
+             (&fix-hint
+              (hint
+               (format #f (G_ "You should run this command as ~a; use \
+@command{sudo -i} or equivalent if you really want to pull as ~a.")
+                       dir:user our:user)))))))))))
+
 
 (define-command (guix-pull . args)
   (synopsis "pull the latest revision of Guix")
@@ -813,30 +842,7 @@ Use '~/.config/guix/channels.scm' instead."))
         (else
          ;; Bail out early when users accidentally run, e.g., ’sudo guix pull’.
          ;; If CACHE-DIRECTORY doesn't yet exist, test where it would end up.
-         (let-values (((stats dir) (let loop ((dir (cache-directory)))
-                                     (let ((stats (stat dir #f)))
-                                       (if stats
-                                           (values stats dir)
-                                           (loop (dirname dir)))))))
-           (let ((dir:uid (stat:uid stats))
-                 (our:uid (getuid)))
-             (unless (= dir:uid our:uid)
-               (let* ((user (lambda (uid)    ; handle the unthinkable invalid UID
-                              (or (false-if-exception (passwd:name
-                                                       (getpwuid uid)))
-                                  uid)))
-                      (our:user (user our:uid))
-                      (dir:user (user dir:uid)))
-                 (raise
-                  (condition
-                   (&message
-                    (message
-                     (format #f (G_ "directory ‘~a’ is not owned by user ~a")
-                             dir our:user)))
-                   (&fix-hint
-                    (hint
-                     (format #f (G_ "You should run this command as ~a; use ‘sudo -i’ or equivalent if you really want to pull as ~a.")
-                             dir:user our:user)))))))))
+         (validate-cache-directory-ownership)
 
          (with-store store
            (with-status-verbosity (assoc-ref opts 'verbosity)