~ruther/guix-local

70c4329172020bf6cc81170c379ef8d0bd0a9ba0 — Ludovic Courtès 13 years ago 101d9f3
package: Make sure the profile directory is owned by the user.

* guix/scripts/package.scm (guix-package)[ensure-default-profile]: Check
  the owner of %PROFILE-DIRECTORY.  Report an error when the owner is
  not the current user.  Add `rtfm' procedure.
* doc/guix.texi (Invoking guix package): Mention the ownership test.
2 files changed, 38 insertions(+), 19 deletions(-)

M doc/guix.texi
M guix/scripts/package.scm
M doc/guix.texi => doc/guix.texi +2 -1
@@ 490,7 490,8 @@ directory is normally
@var{localstatedir} is the value passed to @code{configure} as
@code{--localstatedir}, and @var{user} is the user name.  It must be
created by @code{root}, with @var{user} as the owner.  When it does not
exist, @command{guix package} emits an error about it.
exist, or is not owned by @var{user}, @command{guix package} emits an
error about it.

The @var{options} can be among the following:


M guix/scripts/package.scm => guix/scripts/package.scm +36 -18
@@ 600,7 600,14 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
      (#f #f)))

  (define (ensure-default-profile)
    ;; Ensure the default profile symlink and directory exist.
    ;; Ensure the default profile symlink and directory exist and are
    ;; writable.

    (define (rtfm)
      (format (current-error-port)
              (_ "Try \"info '(guix) Invoking guix package'\" for \
more information.~%"))
      (exit 1))

    ;; Create ~/.guix-profile if it doesn't exist yet.
    (when (and %user-environment-directory


@@ 609,23 616,34 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
                     (lstat %user-environment-directory))))
      (symlink %current-profile %user-environment-directory))

    ;; Attempt to create /…/profiles/per-user/$USER if needed.
    (unless (directory-exists? %profile-directory)
      (catch 'system-error
        (lambda ()
          (mkdir-p %profile-directory))
        (lambda args
          ;; Often, we cannot create %PROFILE-DIRECTORY because its
          ;; parent directory is root-owned and we're running
          ;; unprivileged.
          (format (current-error-port)
                  (_ "error: while creating directory `~a': ~a~%")
                  %profile-directory
                  (strerror (system-error-errno args)))
          (format (current-error-port)
                  (_ "Please create the `~a' directory, with you as the owner.~%")
                  %profile-directory)
          (exit 1)))))
    (let ((s (stat %profile-directory #f)))
      ;; Attempt to create /…/profiles/per-user/$USER if needed.
      (unless (and s (eq? 'directory (stat:type s)))
        (catch 'system-error
          (lambda ()
            (mkdir-p %profile-directory))
          (lambda args
            ;; Often, we cannot create %PROFILE-DIRECTORY because its
            ;; parent directory is root-owned and we're running
            ;; unprivileged.
            (format (current-error-port)
                    (_ "error: while creating directory `~a': ~a~%")
                    %profile-directory
                    (strerror (system-error-errno args)))
            (format (current-error-port)
                    (_ "Please create the `~a' directory, with you as the owner.~%")
                    %profile-directory)
            (rtfm))))

      ;; Bail out if it's not owned by the user.
      (unless (= (stat:uid s) (getuid))
        (format (current-error-port)
                (_ "error: directory `~a' is not owned by you~%")
                %profile-directory)
        (format (current-error-port)
                (_ "Please change the owner of `~a' to user ~s.~%")
                %profile-directory (or (getenv "USER") (getuid)))
        (rtfm))))

  (define (process-actions opts)
    ;; Process any install/remove/upgrade action from OPTS.