mirror of
https://git.savannah.gnu.org/git/guix.git
synced 2025-02-07 11:29:59 +01:00
pull: Tweak cache directory validation code.
This is a followup to 7c52cad046
.
* 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'.
This commit is contained in:
parent
13c46cc29d
commit
9be470b5d2
1 changed files with 31 additions and 25 deletions
|
@ -20,6 +20,7 @@
|
||||||
|
|
||||||
(define-module (guix scripts pull)
|
(define-module (guix scripts pull)
|
||||||
#:use-module ((guix ui) #:hide (display-profile-content))
|
#:use-module ((guix ui) #:hide (display-profile-content))
|
||||||
|
#:use-module (guix diagnostics)
|
||||||
#:use-module (guix colors)
|
#:use-module (guix colors)
|
||||||
#:use-module (guix utils)
|
#:use-module (guix utils)
|
||||||
#:use-module ((guix status) #:select (with-status-verbosity))
|
#:use-module ((guix status) #:select (with-status-verbosity))
|
||||||
|
@ -49,7 +50,6 @@
|
||||||
#:autoload (gnu packages bootstrap) (%bootstrap-guile)
|
#:autoload (gnu packages bootstrap) (%bootstrap-guile)
|
||||||
#:autoload (gnu packages certs) (le-certs)
|
#:autoload (gnu packages certs) (le-certs)
|
||||||
#:use-module (srfi srfi-1)
|
#:use-module (srfi srfi-1)
|
||||||
#:use-module (srfi srfi-11)
|
|
||||||
#:use-module (srfi srfi-26)
|
#:use-module (srfi srfi-26)
|
||||||
#:use-module (srfi srfi-34)
|
#:use-module (srfi srfi-34)
|
||||||
#:use-module (srfi srfi-35)
|
#:use-module (srfi srfi-35)
|
||||||
|
@ -787,6 +787,35 @@ Use '~/.config/guix/channels.scm' instead."))
|
||||||
channels))
|
channels))
|
||||||
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)
|
(define-command (guix-pull . args)
|
||||||
(synopsis "pull the latest revision of Guix")
|
(synopsis "pull the latest revision of Guix")
|
||||||
|
@ -813,30 +842,7 @@ Use '~/.config/guix/channels.scm' instead."))
|
||||||
(else
|
(else
|
||||||
;; Bail out early when users accidentally run, e.g., ’sudo guix pull’.
|
;; 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.
|
;; If CACHE-DIRECTORY doesn't yet exist, test where it would end up.
|
||||||
(let-values (((stats dir) (let loop ((dir (cache-directory)))
|
(validate-cache-directory-ownership)
|
||||||
(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)))))))))
|
|
||||||
|
|
||||||
(with-store store
|
(with-store store
|
||||||
(with-status-verbosity (assoc-ref opts 'verbosity)
|
(with-status-verbosity (assoc-ref opts 'verbosity)
|
||||||
|
|
Loading…
Add table
Reference in a new issue