summary refs log tree commit diff
path: root/guix/scripts/package.scm
diff options
context:
space:
mode:
Diffstat (limited to 'guix/scripts/package.scm')
-rw-r--r--guix/scripts/package.scm356
1 files changed, 202 insertions, 154 deletions
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 3cc7ae760f..06ee441799 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -1,7 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
-;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
+;;; Copyright © 2013, 2015 Mark H Weaver <mhw@netris.org>
 ;;; Copyright © 2014 Alex Kost <alezost@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -25,6 +25,7 @@
   #:use-module (guix derivations)
   #:use-module (guix packages)
   #:use-module (guix profiles)
+  #:use-module (guix search-paths)
   #:use-module (guix monads)
   #:use-module (guix utils)
   #:use-module (guix config)
@@ -89,6 +90,15 @@ return PROFILE unchanged.  The goal is to treat '-p ~/.guix-profile' as if
       %current-profile
       profile))
 
+(define (user-friendly-profile profile)
+  "Return either ~/.guix-profile if that's what PROFILE refers to, directly or
+indirectly, or PROFILE."
+  (if (and %user-profile-directory
+           (false-if-exception
+            (string=? (readlink %user-profile-directory) profile)))
+      %user-profile-directory
+      profile))
+
 (define (link-to-empty-profile store generation)
   "Link GENERATION, a string, to the empty profile."
   (let* ((drv  (run-with-store store
@@ -232,6 +242,41 @@ DURATION-RELATION with the current time."
          filter-by-duration)
         (else #f)))
 
+(define (delete-matching-generations store profile pattern)
+  "Delete from PROFILE all the generations matching PATTERN.  PATTERN must be
+a string denoting a set of generations: the empty list means \"all generations
+but the current one\", a number designates a generation, and other patterns
+denote ranges as interpreted by 'matching-derivations'."
+  (let ((current (generation-number profile)))
+    (cond ((not (file-exists? profile))            ; XXX: race condition
+           (raise (condition (&profile-not-found-error
+                              (profile profile)))))
+          ((string-null? pattern)
+           (delete-generations (%store) profile
+                               (delv current (profile-generations profile))))
+          ;; Do not delete the zeroth generation.
+          ((equal? 0 (string->number pattern))
+           #t)
+
+          ;; If PATTERN is a duration, match generations that are
+          ;; older than the specified duration.
+          ((matching-generations pattern profile
+                                 #:duration-relation >)
+           =>
+           (lambda (numbers)
+             (when (memv current numbers)
+               (warning (_ "not removing generation ~a, which is current~%")
+                        current))
+
+             ;; Make sure we don't inadvertently remove the current
+             ;; generation.
+             (let ((numbers (delv current numbers)))
+               (when (null-list? numbers)
+                 (leave (_ "no matching generation~%")))
+               (delete-generations (%store) profile numbers))))
+          (else
+           (leave (_ "invalid syntax: ~a~%") pattern)))))
+
 
 ;;;
 ;;; Package specifications.
@@ -330,77 +375,35 @@ an output path different than CURRENT-PATH."
 ;;; Search paths.
 ;;;
 
-(define-syntax-rule (with-null-error-port exp)
-  "Evaluate EXP with the error port pointing to the bit bucket."
-  (with-error-to-port (%make-void-port "w")
-    (lambda () exp)))
-
 (define* (search-path-environment-variables entries profile
-                                            #:optional (getenv getenv))
+                                            #:optional (getenv getenv)
+                                            #:key (kind 'exact))
   "Return environment variable definitions that may be needed for the use of
 ENTRIES, a list of manifest entries, in PROFILE.  Use GETENV to determine the
-current settings and report only settings not already effective."
-
-  ;; Prefer ~/.guix-profile to the real profile directory name.
-  (let ((profile (if (and %user-profile-directory
-                          (false-if-exception
-                           (string=? (readlink %user-profile-directory)
-                                     profile)))
-                     %user-profile-directory
-                     profile)))
-
-    ;; The search path info is not stored in the manifest.  Thus, we infer the
-    ;; search paths from same-named packages found in the distro.
-
-    (define manifest-entry->package
-      (match-lambda
-       (($ <manifest-entry> name version)
-        ;; Use 'find-best-packages-by-name' and not 'find-packages-by-name';
-        ;; the former traverses the module tree only once and then allows for
-        ;; efficient access via a vhash.
-        (match (find-best-packages-by-name name version)
-          ((p _ ...) p)
-          (_
-           (match (find-best-packages-by-name name #f)
-             ((p _ ...) p)
-             (_ #f)))))))
-
-    (define search-path-definition
-      (match-lambda
-       (($ <search-path-specification> variable files separator
-                                       type pattern)
-        (let* ((values (or (and=> (getenv variable)
-                                  (cut string-tokenize* <> separator))
-                           '()))
-               ;; Add a trailing slash to force symlinks to be treated as
-               ;; directories when 'find-files' traverses them.
-               (files  (if pattern
-                           (map (cut string-append <> "/") files)
-                           files))
-
-               ;; XXX: Silence 'find-files' when it stumbles upon non-existent
-               ;; directories (see
-               ;; <http://lists.gnu.org/archive/html/guix-devel/2015-01/msg00269.html>.)
-               (path   (with-null-error-port
-                        (search-path-as-list files (list profile)
-                                             #:type type
-                                             #:pattern pattern))))
-          (if (every (cut member <> values) path)
-              #f
-              (format #f "export ~a=\"~a\""
-                      variable
-                      (string-join path separator)))))))
-
-    (let* ((packages     (filter-map manifest-entry->package entries))
-           (search-paths (delete-duplicates
-                          (append-map package-native-search-paths
-                                      packages))))
-      (filter-map search-path-definition search-paths))))
-
-(define (display-search-paths entries profile)
+current settings and report only settings not already effective.  KIND
+must be one of 'exact, 'prefix, or 'suffix, depending on the kind of search
+path definition to be returned."
+  (let ((search-paths (delete-duplicates
+                       (cons $PATH
+                             (append-map manifest-entry-search-paths
+                                         entries)))))
+    (filter-map (match-lambda
+                  ((spec . value)
+                   (let ((variable (search-path-specification-variable spec))
+                         (sep      (search-path-specification-separator spec)))
+                     (environment-variable-definition variable value
+                                                      #:separator sep
+                                                      #:kind kind))))
+                (evaluate-search-paths search-paths (list profile)
+                                       getenv))))
+
+(define* (display-search-paths entries profile
+                               #:key (kind 'exact))
   "Display the search path environment variables that may need to be set for
 ENTRIES, a list of manifest entries, in the context of PROFILE."
-  (let ((settings (search-path-environment-variables entries profile)))
+  (let* ((profile  (user-friendly-profile profile))
+         (settings (search-path-environment-variables entries profile
+                                                      #:kind kind)))
     (unless (null? settings)
       (format #t (_ "The following environment variable definitions may be needed:~%"))
       (format #t "~{   ~a~%~}" settings))))
@@ -430,9 +433,15 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
   (display (_ "
   -u, --upgrade[=REGEXP] upgrade all the installed packages matching REGEXP"))
   (display (_ "
+  -m, --manifest=FILE    create a new profile generation with the manifest
+                         from FILE"))
+  (display (_ "
+      --do-not-upgrade[=REGEXP] do not upgrade any packages matching REGEXP"))
+  (display (_ "
       --roll-back        roll back to the previous generation"))
   (display (_ "
-      --search-paths     display needed environment variable definitions"))
+      --search-paths[=KIND]
+                         display needed environment variable definitions"))
   (display (_ "
   -l, --list-generations[=PATTERN]
                          list generations matching PATTERN"))
@@ -508,10 +517,21 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
                                          ;; would upgrade everything.
                                          (delete '(upgrade . #f) result))
                              arg-handler))))
+         (option '("do-not-upgrade") #f #t
+                 (lambda (opt name arg result arg-handler)
+                   (let arg-handler ((arg arg) (result result))
+                     (values (if arg
+                                 (alist-cons 'do-not-upgrade arg result)
+                                 result)
+                             arg-handler))))
          (option '("roll-back") #f #f
                  (lambda (opt name arg result arg-handler)
                    (values (alist-cons 'roll-back? #t result)
                            #f)))
+         (option '(#\m "manifest") #t #f
+                 (lambda (opt name arg result arg-handler)
+                   (values (alist-cons 'manifest arg result)
+                           arg-handler)))
          (option '(#\l "list-generations") #f #t
                  (lambda (opt name arg result arg-handler)
                    (values (cons `(query list-generations ,(or arg ""))
@@ -526,10 +546,20 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
                  (lambda (opt name arg result arg-handler)
                    (values (alist-cons 'switch-generation arg result)
                            #f)))
-         (option '("search-paths") #f #f
+         (option '("search-paths") #f #t
                  (lambda (opt name arg result arg-handler)
-                   (values (cons `(query search-paths) result)
-                           #f)))
+                   (let ((kind (match arg
+                                 ((or "exact" "prefix" "suffix")
+                                  (string->symbol arg))
+                                 (#f
+                                  'exact)
+                                 (x
+                                  (leave (_ "~a: unsupported \
+kind of search path~%")
+                                         x)))))
+                     (values (cons `(query search-paths ,kind)
+                                   result)
+                             #f))))
          (option '(#\p "profile") #t #f
                  (lambda (opt name arg result arg-handler)
                    (values (alist-cons 'profile (canonicalize-profile arg)
@@ -586,6 +616,13 @@ return the new list of manifest entries."
                  (_ #f))
                 opts))
 
+  (define do-not-upgrade-regexps
+    (filter-map (match-lambda
+                 (('do-not-upgrade . regexp)
+                  (make-regexp regexp))
+                 (_ #f))
+                opts))
+
   (define packages-to-upgrade
     (match upgrade-regexps
       (()
@@ -595,6 +632,8 @@ return the new list of manifest entries."
                     (($ <manifest-entry> name version output path _)
                      (and (any (cut regexp-exec <> name)
                                upgrade-regexps)
+                          (not (any (cut regexp-exec <> name)
+                                    do-not-upgrade-regexps))
                           (upgradeable? name version path)
                           (let ((output (or output "out")))
                             (call-with-values
@@ -677,13 +716,31 @@ doesn't need it."
 
 (define (readlink* file)
   "Call 'readlink' until the result is not a symlink."
-  (catch 'system-error
-    (lambda ()
-      (readlink* (readlink file)))
-    (lambda args
-      (if (= EINVAL (system-error-errno args))
-          file
-          (apply throw args)))))
+  (define %max-symlink-depth 50)
+
+  (let loop ((file  file)
+             (depth 0))
+    (define (absolute target)
+      (if (absolute-file-name? target)
+          target
+          (string-append (dirname file) "/" target)))
+
+    (if (>= depth %max-symlink-depth)
+        file
+        (call-with-values
+            (lambda ()
+              (catch 'system-error
+                (lambda ()
+                  (values #t (readlink file)))
+                (lambda args
+                  (let ((errno (system-error-errno args)))
+                    (if (or (= errno EINVAL))
+                        (values #f file)
+                        (apply throw args))))))
+          (lambda (success? target)
+            (if success?
+                (loop (absolute target) (+ depth 1))
+                file))))))
 
 
 ;;;
@@ -751,8 +808,49 @@ more information.~%"))
     (define dry-run? (assoc-ref opts 'dry-run?))
     (define profile  (assoc-ref opts 'profile))
 
-    (define current-generation-number
-      (generation-number profile))
+    (define (build-and-use-profile manifest)
+      (let* ((bootstrap?  (assoc-ref opts 'bootstrap?)))
+
+        (when (equal? profile %current-profile)
+          (ensure-default-profile))
+
+        (let* ((prof-drv (run-with-store (%store)
+                           (profile-derivation
+                            manifest
+                            #:hooks (if bootstrap?
+                                        '()
+                                        %default-profile-hooks))))
+               (prof     (derivation->output-path prof-drv)))
+          (show-what-to-build (%store) (list prof-drv)
+                              #:use-substitutes?
+                              (assoc-ref opts 'substitutes?)
+                              #:dry-run? dry-run?)
+
+          (cond
+           (dry-run? #t)
+           ((and (file-exists? profile)
+                 (and=> (readlink* profile) (cut string=? prof <>)))
+            (format (current-error-port) (_ "nothing to be done~%")))
+           (else
+            (let* ((number (generation-number profile))
+
+                   ;; Always use NUMBER + 1 for the new profile,
+                   ;; possibly overwriting a "previous future
+                   ;; generation".
+                   (name   (generation-file-name profile
+                                                 (+ 1 number))))
+              (and (build-derivations (%store) (list prof-drv))
+                   (let* ((entries (manifest-entries manifest))
+                          (count   (length entries)))
+                     (switch-symlinks name prof)
+                     (switch-symlinks profile name)
+                     (unless (string=? profile %current-profile)
+                       (register-gc-root (%store) name))
+                     (format #t (N_ "~a package in profile~%"
+                                    "~a packages in profile~%"
+                                    count)
+                             count)
+                     (display-search-paths entries profile)))))))))
 
     ;; First roll back if asked to.
     (cond ((and (assoc-ref opts 'roll-back?)
@@ -782,88 +880,34 @@ more information.~%"))
            (for-each
             (match-lambda
              (('delete-generations . pattern)
-              (cond ((not (file-exists? profile)) ; XXX: race condition
-                     (raise (condition (&profile-not-found-error
-                                        (profile profile)))))
-                    ((string-null? pattern)
-                     (delete-generations
-                      (%store) profile
-                      (delete current-generation-number
-                              (profile-generations profile))))
-                    ;; Do not delete the zeroth generation.
-                    ((equal? 0 (string->number pattern))
-                     (exit 0))
-
-                    ;; If PATTERN is a duration, match generations that are
-                    ;; older than the specified duration.
-                    ((matching-generations pattern profile
-                                           #:duration-relation >)
-                     =>
-                     (lambda (numbers)
-                       (if (null-list? numbers)
-                           (exit 1)
-                           (delete-generations (%store) profile numbers))))
-                    (else
-                     (leave (_ "invalid syntax: ~a~%")
-                            pattern)))
+              (delete-matching-generations (%store) profile pattern)
 
               (process-actions
                (alist-delete 'delete-generations opts)))
              (_ #f))
             opts))
+          ((and (assoc-ref opts 'manifest)
+                (not dry-run?))
+           (let* ((file-name (assoc-ref opts 'manifest))
+                  (user-module (make-user-module '((guix profiles)
+                                                   (gnu))))
+                  (manifest (load* file-name user-module)))
+             (format #t (_ "installing new manifest from ~a with ~d entries.~%")
+                     file-name (length (manifest-entries manifest)))
+             (build-and-use-profile manifest)))
           (else
            (let* ((manifest    (profile-manifest profile))
                   (install     (options->installable opts manifest))
                   (remove      (options->removable opts manifest))
-                  (bootstrap?  (assoc-ref opts 'bootstrap?))
                   (transaction (manifest-transaction (install install)
                                                      (remove remove)))
                   (new         (manifest-perform-transaction
                                 manifest transaction)))
 
-             (when (equal? profile %current-profile)
-               (ensure-default-profile))
-
              (unless (and (null? install) (null? remove))
-               (let* ((prof-drv (run-with-store (%store)
-                                  (profile-derivation
-                                   new
-                                   #:info-dir? (not bootstrap?)
-                                   #:ca-certificate-bundle? (not bootstrap?))))
-                      (prof     (derivation->output-path prof-drv)))
-                 (show-manifest-transaction (%store) manifest transaction
-                                            #:dry-run? dry-run?)
-                 (show-what-to-build (%store) (list prof-drv)
-                                     #:use-substitutes?
-                                     (assoc-ref opts 'substitutes?)
-                                     #:dry-run? dry-run?)
-
-                 (cond
-                  (dry-run? #t)
-                  ((and (file-exists? profile)
-                        (and=> (readlink* profile) (cut string=? prof <>)))
-                   (format (current-error-port) (_ "nothing to be done~%")))
-                  (else
-                   (let* ((number (generation-number profile))
-
-                          ;; Always use NUMBER + 1 for the new profile,
-                          ;; possibly overwriting a "previous future
-                          ;; generation".
-                          (name   (generation-file-name profile
-                                                        (+ 1 number))))
-                     (and (build-derivations (%store) (list prof-drv))
-                          (let* ((entries (manifest-entries new))
-                                 (count   (length entries)))
-                            (switch-symlinks name prof)
-                            (switch-symlinks profile name)
-                            (unless (string=? profile %current-profile)
-                              (register-gc-root (%store) name))
-                            (format #t (N_ "~a package in profile~%"
-                                           "~a packages in profile~%"
-                                           count)
-                                    count)
-                            (display-search-paths entries
-                                                  profile))))))))))))
+               (show-manifest-transaction (%store) manifest transaction
+                                          #:dry-run? dry-run?)
+               (build-and-use-profile new))))))
 
   (define (process-query opts)
     ;; Process any query specified by OPTS.  Return #t when a query was
@@ -932,11 +976,13 @@ more information.~%"))
                 (available (fold-packages
                             (lambda (p r)
                               (let ((n (package-name p)))
-                                (if regexp
-                                    (if (regexp-exec regexp n)
-                                        (cons p r)
-                                        r)
-                                    (cons p r))))
+                                (if (supported-package? p)
+                                    (if regexp
+                                        (if (regexp-exec regexp n)
+                                            (cons p r)
+                                            r)
+                                        (cons p r))
+                                    r)))
                             '())))
            (leave-on-EPIPE
             (for-each (lambda (p)
@@ -966,11 +1012,13 @@ more information.~%"))
                       (find-packages-by-name name version)))
            #t))
 
-        (('search-paths)
+        (('search-paths kind)
          (let* ((manifest (profile-manifest profile))
                 (entries  (manifest-entries manifest))
+                (profile  (user-friendly-profile profile))
                 (settings (search-path-environment-variables entries profile
-                                                             (const #f))))
+                                                             (const #f)
+                                                             #:kind kind)))
            (format #t "~{~a~%~}" settings)
            #t))