aboutsummaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
Diffstat (limited to 'guix')
-rw-r--r--guix/build-system/cmake.scm1
-rw-r--r--guix/build-system/perl.scm10
-rw-r--r--guix/build/cmake-build-system.scm2
-rw-r--r--guix/build/union.scm44
-rw-r--r--guix/derivations.scm3
-rw-r--r--guix/download.scm22
-rw-r--r--guix/gnu-maintenance.scm2
-rw-r--r--guix/records.scm8
-rw-r--r--guix/scripts/package.scm695
-rw-r--r--guix/scripts/pull.scm96
-rw-r--r--guix/ui.scm2
11 files changed, 533 insertions, 352 deletions
diff --git a/guix/build-system/cmake.scm b/guix/build-system/cmake.scm
index 5f5c243572..e09f165b97 100644
--- a/guix/build-system/cmake.scm
+++ b/guix/build-system/cmake.scm
@@ -64,7 +64,6 @@
(guix build gnu-build-system)
(guix build utils)))
(modules '((guix build cmake-build-system)
- (guix build gnu-build-system)
(guix build utils))))
"Build SOURCE using CMAKE, and with INPUTS. This assumes that SOURCE
provides a 'CMakeLists.txt' file as its build system."
diff --git a/guix/build-system/perl.scm b/guix/build-system/perl.scm
index 6661689efb..5dc50d97f3 100644
--- a/guix/build-system/perl.scm
+++ b/guix/build-system/perl.scm
@@ -35,9 +35,16 @@
;;
;; Code:
+(define (default-perl)
+ "Return the default Perl package."
+
+ ;; Do not use `@' to avoid introducing circular dependencies.
+ (let ((module (resolve-interface '(gnu packages perl))))
+ (module-ref module 'perl)))
+
(define* (perl-build store name source inputs
#:key
- (perl (@ (gnu packages perl) perl))
+ (perl (default-perl))
(search-paths '())
(tests? #t)
(make-maker-flags ''())
@@ -50,7 +57,6 @@
(guix build gnu-build-system)
(guix build utils)))
(modules '((guix build perl-build-system)
- (guix build gnu-build-system)
(guix build utils))))
"Build SOURCE using PERL, and with INPUTS. This assumes that SOURCE
provides a `Makefile.PL' file as its build system."
diff --git a/guix/build/cmake-build-system.scm b/guix/build/cmake-build-system.scm
index 877d8110d7..449c609398 100644
--- a/guix/build/cmake-build-system.scm
+++ b/guix/build/cmake-build-system.scm
@@ -38,6 +38,8 @@
(if (file-exists? "CMakeLists.txt")
(let ((args `(,(string-append "-DCMAKE_INSTALL_PREFIX=" out)
,@configure-flags)))
+ (setenv "CMAKE_LIBRARY_PATH" (getenv "LIBRARY_PATH"))
+ (setenv "CMAKE_INCLUDE_PATH" (getenv "CPATH"))
(format #t "running 'cmake' with arguments ~s~%" args)
(zero? (apply system* "cmake" args)))
(error "no CMakeLists.txt found"))))
diff --git a/guix/build/union.scm b/guix/build/union.scm
index 077b7fe530..1b09da45c7 100644
--- a/guix/build/union.scm
+++ b/guix/build/union.scm
@@ -22,6 +22,8 @@
#:use-module (ice-9 format)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
+ #:use-module (rnrs bytevectors)
+ #:use-module (rnrs io ports)
#:export (tree-union
delete-duplicate-leaves
union-build))
@@ -100,7 +102,25 @@ single leaf."
,@(map loop dirs))))
(leaf leaf))))
-(define* (union-build output directories)
+(define (file=? file1 file2)
+ "Return #t if the contents of FILE1 and FILE2 are identical, #f otherwise."
+ (and (= (stat:size (stat file1)) (stat:size (stat file2)))
+ (call-with-input-file file1
+ (lambda (port1)
+ (call-with-input-file file2
+ (lambda (port2)
+ (define len 8192)
+ (define buf1 (make-bytevector len))
+ (define buf2 (make-bytevector len))
+ (let loop ()
+ (let ((n1 (get-bytevector-n! port1 buf1 0 len))
+ (n2 (get-bytevector-n! port2 buf2 0 len)))
+ (and (equal? n1 n2)
+ (or (eof-object? n1)
+ (loop)))))))))))
+
+(define* (union-build output directories
+ #:key (log-port (current-error-port)))
"Build in the OUTPUT directory a symlink tree that is the union of all
the DIRECTORIES."
(define (file-tree dir)
@@ -162,18 +182,21 @@ the DIRECTORIES."
;; LEAVES all actually point to the same file, so nothing to worry
;; about.
one-and-the-same)
- ((and lst (head _ ...))
- ;; A real collision.
- (format (current-error-port) "warning: collision encountered: ~{~a ~}~%"
- lst)
-
- ;; TODO: Implement smarter strategies.
- (format (current-error-port) "warning: arbitrarily choosing ~a~%"
- head)
+ ((and lst (head rest ...))
+ ;; A real collision, unless those files are all identical.
+ (unless (every (cut file=? head <>) rest)
+ (format (current-error-port) "warning: collision encountered: ~{~a ~}~%"
+ lst)
+
+ ;; TODO: Implement smarter strategies.
+ (format (current-error-port) "warning: arbitrarily choosing ~a~%"
+ head))
head)))
(setvbuf (current-output-port) _IOLBF)
(setvbuf (current-error-port) _IOLBF)
+ (when (file-port? log-port)
+ (setvbuf log-port _IOLBF))
(mkdir output)
(let loop ((tree (delete-duplicate-leaves
@@ -189,8 +212,7 @@ the DIRECTORIES."
;; A leaf: create a symlink.
(let* ((dir (string-join dir "/"))
(target (string-append output "/" dir "/" (basename tree))))
- (format (current-error-port) "`~a' ~~> `~a'~%"
- tree target)
+ (format log-port "`~a' ~~> `~a'~%" tree target)
(symlink tree target)))
(((? string? subdir) leaves ...)
;; A sub-directory: create it in OUTPUT, and iterate over LEAVES.
diff --git a/guix/derivations.scm b/guix/derivations.scm
index 433a8f145e..48e9d5ec05 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -441,7 +441,8 @@ that form."
(lambda* (path #:optional (output "out"))
"Read the derivation from PATH (`/nix/store/xxx.drv'), and return the store
path of its output OUTPUT."
- (derivation->output-path (call-with-input-file path read-derivation)))))
+ (derivation->output-path (call-with-input-file path read-derivation)
+ output))))
(define (derivation-path->output-paths path)
"Read the derivation from PATH (`/nix/store/xxx.drv'), and return the
diff --git a/guix/download.scm b/guix/download.scm
index 03c2f8066f..837ff0e683 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -24,6 +24,7 @@
#:use-module ((guix store) #:select (derivation-path? add-to-store))
#:use-module ((guix build download) #:renamer (symbol-prefix-proc 'build:))
#:use-module (guix utils)
+ #:use-module (web uri)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:export (%mirrors
@@ -244,13 +245,18 @@ must be a list of symbol/URL-list pairs."
#:key (log (current-error-port)))
"Download from URL to STORE, either under NAME or URL's basename if
omitted. Write progress reports to LOG."
- (call-with-temporary-output-file
- (lambda (temp port)
- (let ((result
- (parameterize ((current-output-port log))
- (build:url-fetch url temp #:mirrors %mirrors))))
- (close port)
- (and result
- (add-to-store store name #f "sha256" temp))))))
+ (define uri
+ (string->uri url))
+
+ (if (memq (uri-scheme uri) '(file #f))
+ (add-to-store store name #f "sha256" (uri-path uri))
+ (call-with-temporary-output-file
+ (lambda (temp port)
+ (let ((result
+ (parameterize ((current-output-port log))
+ (build:url-fetch url temp #:mirrors %mirrors))))
+ (close port)
+ (and result
+ (add-to-store store name #f "sha256" temp)))))))
;;; download.scm ends here
diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 1b767f35ac..3dd8874985 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -86,7 +86,7 @@
;; This file contains package descriptions in recutils format.
;; See <https://lists.gnu.org/archive/html/guix-devel/2013-10/msg00071.html>.
(string->uri
- (string-append %gnumaint-base-url "pkgdescr.txt?root=womb")))
+ (string-append %gnumaint-base-url "pkgblurbs.txt?root=womb")))
(define-record-type* <gnu-package-descriptor>
gnu-package-descriptor
diff --git a/guix/records.scm b/guix/records.scm
index d47bbf89f2..37d34b4c81 100644
--- a/guix/records.scm
+++ b/guix/records.scm
@@ -73,7 +73,7 @@ thunked fields."
(memq (syntax->datum f) '#,thunked))
(define (field-bindings field+value)
- ;; Return field to value bindings, for use in `letrec*' below.
+ ;; Return field to value bindings, for use in 'let*' below.
(map (lambda (field+value)
(syntax-case field+value ()
((field value)
@@ -85,7 +85,7 @@ thunked fields."
(syntax-case s (inherit #,@fields)
((_ (inherit orig-record) (field value) (... ...))
- #`(letrec* #,(field-bindings #'((field value) (... ...)))
+ #`(let* #,(field-bindings #'((field value) (... ...)))
#,(record-inheritance #'orig-record
#'((field value) (... ...)))))
((_ (field value) (... ...))
@@ -116,8 +116,8 @@ thunked fields."
s)))))
(let ((fields (append fields (map car dflt))))
(cond ((lset= eq? fields 'expected)
- #`(letrec* #,(field-bindings
- #'((field value) (... ...)))
+ #`(let* #,(field-bindings
+ #'((field value) (... ...)))
(ctor #,@(map field-value 'expected))))
((pair? (lset-difference eq? fields 'expected))
(error* "extraneous field initializers ~a"
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 5c7c165cbb..008ae53b47 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -25,6 +25,7 @@
#:use-module (guix packages)
#:use-module (guix utils)
#:use-module (guix config)
+ #:use-module (guix records)
#:use-module ((guix build utils) #:select (directory-exists? mkdir-p))
#:use-module ((guix ftp-client) #:select (ftp-open))
#:use-module (ice-9 ftw)
@@ -33,6 +34,7 @@
#:use-module (ice-9 regex)
#:use-module (ice-9 vlist)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
@@ -49,10 +51,10 @@
;;;
-;;; User environment.
+;;; User profile.
;;;
-(define %user-environment-directory
+(define %user-profile-directory
(and=> (getenv "HOME")
(cut string-append <> "/.guix-profile")))
@@ -67,30 +69,125 @@
;; coexist with Nix profiles.
(string-append %profile-directory "/guix-profile"))
+
+;;;
+;;; Manifests.
+;;;
+
+(define-record-type <manifest>
+ (manifest entries)
+ manifest?
+ (entries manifest-entries)) ; list of <manifest-entry>
+
+;; Convenient alias, to avoid name clashes.
+(define make-manifest manifest)
+
+(define-record-type* <manifest-entry> manifest-entry
+ make-manifest-entry
+ manifest-entry?
+ (name manifest-entry-name) ; string
+ (version manifest-entry-version) ; string
+ (output manifest-entry-output ; string
+ (default "out"))
+ (path manifest-entry-path) ; store path
+ (dependencies manifest-entry-dependencies ; list of store paths
+ (default '()))
+ (inputs manifest-entry-inputs ; list of inputs to build
+ (default '()))) ; this entry
+
(define (profile-manifest profile)
"Return the PROFILE's manifest."
- (let ((manifest (string-append profile "/manifest")))
- (if (file-exists? manifest)
- (call-with-input-file manifest read)
- '(manifest (version 1) (packages ())))))
+ (let ((file (string-append profile "/manifest")))
+ (if (file-exists? file)
+ (call-with-input-file file read-manifest)
+ (manifest '()))))
+
+(define (manifest->sexp manifest)
+ "Return a representation of MANIFEST as an sexp."
+ (define (entry->sexp entry)
+ (match entry
+ (($ <manifest-entry> name version path output (deps ...))
+ (list name version path output deps))))
-(define (manifest-packages manifest)
- "Return the packages listed in MANIFEST."
(match manifest
+ (($ <manifest> (entries ...))
+ `(manifest (version 1)
+ (packages ,(map entry->sexp entries))))))
+
+(define (sexp->manifest sexp)
+ "Parse SEXP as a manifest."
+ (match sexp
(('manifest ('version 0)
('packages ((name version output path) ...)))
- (zip name version output path
- (make-list (length name) '())))
+ (manifest
+ (map (lambda (name version output path)
+ (manifest-entry
+ (name name)
+ (version version)
+ (output output)
+ (path path)))
+ name version output path)))
;; Version 1 adds a list of propagated inputs to the
;; name/version/output/path tuples.
(('manifest ('version 1)
- ('packages (packages ...)))
- packages)
+ ('packages ((name version output path deps) ...)))
+ (manifest
+ (map (lambda (name version output path deps)
+ (manifest-entry
+ (name name)
+ (version version)
+ (output output)
+ (path path)
+ (dependencies deps)))
+ name version output path deps)))
(_
(error "unsupported manifest format" manifest))))
+(define (read-manifest port)
+ "Return the packages listed in MANIFEST."
+ (sexp->manifest (read port)))
+
+(define (write-manifest manifest port)
+ "Write MANIFEST to PORT."
+ (write (manifest->sexp manifest) port))
+
+(define (remove-manifest-entry name lst)
+ "Remove the manifest entry named NAME from LST."
+ (remove (match-lambda
+ (($ <manifest-entry> entry-name)
+ (string=? name entry-name)))
+ lst))
+
+(define (manifest-remove manifest names)
+ "Remove entries for each of NAMES from MANIFEST."
+ (make-manifest (fold remove-manifest-entry
+ (manifest-entries manifest)
+ names)))
+
+(define (manifest-installed? manifest name)
+ "Return #t if MANIFEST has an entry for NAME, #f otherwise."
+ (define (->bool x)
+ (not (not x)))
+
+ (->bool (find (match-lambda
+ (($ <manifest-entry> entry-name)
+ (string=? entry-name name)))
+ (manifest-entries manifest))))
+
+(define (manifest=? m1 m2)
+ "Return #t if manifests M1 and M2 are equal. This differs from 'equal?' in
+that the 'inputs' field is ignored for the comparison, since it is know to
+have no effect on the manifest contents."
+ (equal? (manifest->sexp m1)
+ (manifest->sexp m2)))
+
+
+;;;
+;;; Profiles.
+;;;
+
(define (profile-regexp profile)
"Return a regular expression that matches PROFILE's name and number."
(make-regexp (string-append "^" (regexp-quote (basename profile))
@@ -157,17 +254,9 @@ case when generations have been deleted (there are \"holes\")."
0
(generation-numbers profile)))
-(define (profile-derivation store packages)
- "Return a derivation that builds a profile (a user environment) with
-all of PACKAGES, a list of name/version/output/path/deps tuples."
- (define packages*
- ;; Turn any package object in PACKAGES into its output path.
- (map (match-lambda
- ((name version output path (deps ...))
- `(,name ,version ,output ,path
- ,(map input->name+path deps))))
- packages))
-
+(define (profile-derivation store manifest)
+ "Return a derivation that builds a profile (aka. 'user environment') with
+the given MANIFEST."
(define builder
`(begin
(use-modules (ice-9 pretty-print)
@@ -178,33 +267,29 @@ all of PACKAGES, a list of name/version/output/path/deps tuples."
(let ((output (assoc-ref %outputs "out"))
(inputs (map cdr %build-inputs)))
- (format #t "building user environment `~a' with ~a packages...~%"
+ (format #t "building profile '~a' with ~a packages...~%"
output (length inputs))
- (union-build output inputs)
+ (union-build output inputs
+ #:log-port (%make-void-port "w"))
(call-with-output-file (string-append output "/manifest")
(lambda (p)
- (pretty-print '(manifest (version 1)
- (packages ,packages*))
- p))))))
-
- (define ensure-valid-input
- ;; If a package object appears in the given input, turn it into a
- ;; derivation path.
- (match-lambda
- ((name (? package? p) sub-drv ...)
- `(,name ,(package-derivation (%store) p) ,@sub-drv))
- (input
- input)))
-
- (build-expression->derivation store "user-environment"
+ (pretty-print ',(manifest->sexp manifest) p))))))
+
+ (build-expression->derivation store "profile"
(%current-system)
builder
(append-map (match-lambda
- ((name version output path deps)
- `((,name ,path)
- ,@(map ensure-valid-input
- deps))))
- packages)
+ (($ <manifest-entry> name version
+ output path deps (inputs ..1))
+ (map (cute lower-input
+ (%store) <>)
+ inputs))
+ (($ <manifest-entry> name version
+ output path deps)
+ ;; Assume PATH and DEPS are
+ ;; already valid.
+ `((,name ,path) ,@deps)))
+ (manifest-entries manifest))
#:modules '((guix build union))))
(define (generation-number profile)
@@ -214,9 +299,13 @@ all of PACKAGES, a list of name/version/output/path/deps tuples."
(compose string->number (cut match:substring <> 1)))
0))
+(define (generation-file-name profile generation)
+ "Return the file name for PROFILE's GENERATION."
+ (format #f "~a-~a-link" profile generation))
+
(define (link-to-empty-profile generation)
"Link GENERATION, a string, to the empty profile."
- (let* ((drv (profile-derivation (%store) '()))
+ (let* ((drv (profile-derivation (%store) (manifest '())))
(prof (derivation->output-path drv "out")))
(when (not (build-derivations (%store) (list drv)))
(leave (_ "failed to build the empty profile~%")))
@@ -227,8 +316,7 @@ all of PACKAGES, a list of name/version/output/path/deps tuples."
"Atomically switch PROFILE to the previous generation."
(let* ((number (generation-number profile))
(previous-number (previous-generation-number profile number))
- (previous-generation (format #f "~a-~a-link"
- profile previous-number)))
+ (previous-generation (generation-file-name profile previous-number)))
(format #t (_ "switching from generation ~a to ~a~%")
number previous-number)
(switch-symlinks profile previous-generation)))
@@ -237,8 +325,7 @@ all of PACKAGES, a list of name/version/output/path/deps tuples."
"Roll back to the previous generation of PROFILE."
(let* ((number (generation-number profile))
(previous-number (previous-generation-number profile number))
- (previous-generation (format #f "~a-~a-link"
- profile previous-number))
+ (previous-generation (generation-file-name profile previous-number))
(manifest (string-append previous-generation "/manifest")))
(cond ((not (file-exists? profile)) ; invalid profile
(leave (_ "profile '~a' does not exist~%")
@@ -256,7 +343,7 @@ all of PACKAGES, a list of name/version/output/path/deps tuples."
(define (generation-time profile number)
"Return the creation time of a generation in the UTC format."
(make-time time-utc 0
- (stat:ctime (stat (format #f "~a-~a-link" profile number)))))
+ (stat:ctime (stat (generation-file-name profile number)))))
(define* (matching-generations str #:optional (profile %current-profile)
#:key (duration-relation <=))
@@ -325,8 +412,8 @@ DURATION-RELATION with the current time."
(else #f)))
(define (find-packages-by-description rx)
- "Search in SYNOPSIS and DESCRIPTION using RX. Return a list of
-matching packages."
+ "Return the list of packages whose name, synopsis, or description matches
+RX."
(define (same-location? p1 p2)
;; Compare locations of two packages.
(equal? (package-location p1) (package-location p2)))
@@ -337,7 +424,8 @@ matching packages."
(define matches?
(cut regexp-exec rx <>))
- (if (or (and=> (package-synopsis package)
+ (if (or (matches? (gettext (package-name package)))
+ (and=> (package-synopsis package)
(compose matches? gettext))
(and=> (package-description package)
(compose matches? gettext)))
@@ -349,6 +437,16 @@ matching packages."
(package-name p2))))
same-location?))
+(define* (lower-input store input #:optional (system (%current-system)))
+ "Lower INPUT so that it contains derivations instead of packages."
+ (match input
+ ((name (? package? package))
+ `(,name ,(package-derivation store package system)))
+ ((name (? package? package) output)
+ `(,name ,(package-derivation store package system)
+ ,output))
+ (_ input)))
+
(define (input->name+path input)
"Convert the name/package/sub-drv tuple INPUT to a name/store-path tuple."
(let loop ((input input))
@@ -402,6 +500,76 @@ return its return value."
(format (current-error-port) " interrupted by signal ~a~%" SIGINT)
#f))))
+
+;;;
+;;; Package specifications.
+;;;
+
+(define newest-available-packages
+ (memoize find-newest-available-packages))
+
+(define (find-best-packages-by-name name version)
+ "If version is #f, return the list of packages named NAME with the highest
+version numbers; otherwise, return the list of packages named NAME and at
+VERSION."
+ (if version
+ (find-packages-by-name name version)
+ (match (vhash-assoc name (newest-available-packages))
+ ((_ version pkgs ...) pkgs)
+ (#f '()))))
+
+(define* (specification->package+output spec #:optional (output "out"))
+ "Find the package and output specified by SPEC, or #f and #f; SPEC may
+optionally contain a version number and an output name, as in these examples:
+
+ guile
+ guile-2.0.9
+ guile:debug
+ guile-2.0.9:debug
+
+If SPEC does not specify a version number, return the preferred newest
+version; if SPEC does not specify an output, return OUTPUT."
+ (define (ensure-output p sub-drv)
+ (if (member sub-drv (package-outputs p))
+ sub-drv
+ (leave (_ "package `~a' lacks output `~a'~%")
+ (package-full-name p)
+ sub-drv)))
+
+ (let*-values (((name sub-drv)
+ (match (string-rindex spec #\:)
+ (#f (values spec output))
+ (colon (values (substring spec 0 colon)
+ (substring spec (+ 1 colon))))))
+ ((name version)
+ (package-name->name+version name)))
+ (match (find-best-packages-by-name name version)
+ ((p)
+ (values p (ensure-output p sub-drv)))
+ ((p p* ...)
+ (warning (_ "ambiguous package specification `~a'~%")
+ spec)
+ (warning (_ "choosing ~a from ~a~%")
+ (package-full-name p)
+ (location->string (package-location p)))
+ (values p (ensure-output p sub-drv)))
+ (()
+ (leave (_ "~a: package not found~%") spec)))))
+
+(define (upgradeable? name current-version current-path)
+ "Return #t if there's a version of package NAME newer than CURRENT-VERSION,
+or if the newest available version is equal to CURRENT-VERSION but would have
+an output path different than CURRENT-PATH."
+ (match (vhash-assoc name (newest-available-packages))
+ ((_ candidate-version pkg . rest)
+ (case (version-compare candidate-version current-version)
+ ((>) #t)
+ ((<) #f)
+ ((=) (let ((candidate-path (derivation->output-path
+ (package-derivation (%store) pkg))))
+ (not (string=? current-path candidate-path))))))
+ (#f #f)))
+
(define ftp-open*
;; Memoizing version of `ftp-open'. The goal is to avoid initiating a new
;; FTP connection for each package, esp. since most of them are to the same
@@ -437,26 +605,31 @@ but ~a is available upstream~%")
((getaddrinfo-error ftp-error) #f)
(else (apply throw key args))))))
-(define* (search-path-environment-variables packages profile
+
+;;;
+;;; Search paths.
+;;;
+
+(define* (search-path-environment-variables entries profile
#:optional (getenv getenv))
"Return environment variable definitions that may be needed for the use of
-PACKAGES in PROFILE. Use GETENV to determine the current settings and report
-only settings not already effective."
+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-environment-directory
+ (let ((profile (if (and %user-profile-directory
(false-if-exception
- (string=? (readlink %user-environment-directory)
+ (string=? (readlink %user-profile-directory)
profile)))
- %user-environment-directory
+ %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 package-in-manifest->package
+ (define manifest-entry->package
(match-lambda
- ((name version _ ...)
+ (($ <manifest-entry> name version)
(match (append (find-packages-by-name name version)
(find-packages-by-name name))
((p _ ...) p)
@@ -478,16 +651,16 @@ only settings not already effective."
variable
(string-join directories separator)))))))
- (let* ((packages (filter-map package-in-manifest->package packages))
+ (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 packages profile)
+(define (display-search-paths entries profile)
"Display the search path environment variables that may need to be set for
-PACKAGES, in the context of PROFILE."
- (let ((settings (search-path-environment-variables packages profile)))
+ENTRIES, a list of manifest entries, in the context of PROFILE."
+ (let ((settings (search-path-environment-variables entries profile)))
(unless (null? settings)
(format #t (_ "The following environment variable definitions may be needed:~%"))
(format #t "~{ ~a~%~}" settings))))
@@ -633,6 +806,110 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
(cons `(query list-available ,(or arg ""))
result)))))
+(define (options->installable opts manifest)
+ "Given MANIFEST, the current manifest, and OPTS, the result of 'args-fold',
+return the new list of manifest entries."
+ (define (deduplicate deps)
+ ;; Remove duplicate entries from DEPS, a list of propagated inputs, where
+ ;; each input is a name/path tuple.
+ (define (same? d1 d2)
+ (match d1
+ ((_ p1)
+ (match d2
+ ((_ p2) (eq? p1 p2))
+ (_ #f)))
+ ((_ p1 out1)
+ (match d2
+ ((_ p2 out2)
+ (and (string=? out1 out2)
+ (eq? p1 p2)))
+ (_ #f)))))
+
+ (delete-duplicates deps same?))
+
+ (define (package->manifest-entry p output)
+ ;; Return a manifest entry for the OUTPUT of package P.
+ (check-package-freshness p)
+ ;; When given a package via `-e', install the first of its
+ ;; outputs (XXX).
+ (let* ((output (or output (car (package-outputs p))))
+ (path (package-output (%store) p output))
+ (deps (deduplicate (package-transitive-propagated-inputs p))))
+ (manifest-entry
+ (name (package-name p))
+ (version (package-version p))
+ (output output)
+ (path path)
+ (dependencies (map input->name+path deps))
+ (inputs (cons (list (package-name p) p output)
+ deps)))))
+
+ (define upgrade-regexps
+ (filter-map (match-lambda
+ (('upgrade . regexp)
+ (make-regexp (or regexp "")))
+ (_ #f))
+ opts))
+
+ (define packages-to-upgrade
+ (match upgrade-regexps
+ (()
+ '())
+ ((_ ...)
+ (let ((newest (find-newest-available-packages)))
+ (filter-map (match-lambda
+ (($ <manifest-entry> name version output path _)
+ (and (any (cut regexp-exec <> name)
+ upgrade-regexps)
+ (upgradeable? name version path)
+ (let ((output (or output "out")))
+ (call-with-values
+ (lambda ()
+ (specification->package+output name output))
+ list))))
+ (_ #f))
+ (manifest-entries manifest))))))
+
+ (define to-upgrade
+ (map (match-lambda
+ ((package output)
+ (package->manifest-entry package output)))
+ packages-to-upgrade))
+
+ (define packages-to-install
+ (filter-map (match-lambda
+ (('install . (? package? p))
+ (list p "out"))
+ (('install . (? string? spec))
+ (and (not (store-path? spec))
+ (let-values (((package output)
+ (specification->package+output spec)))
+ (and package (list package output)))))
+ (_ #f))
+ opts))
+
+ (define to-install
+ (append (map (match-lambda
+ ((package output)
+ (package->manifest-entry package output)))
+ packages-to-install)
+ (filter-map (match-lambda
+ (('install . (? package?))
+ #f)
+ (('install . (? store-path? path))
+ (let-values (((name version)
+ (package-name->name+version
+ (store-path-package-name path))))
+ (manifest-entry
+ (name name)
+ (version version)
+ (output #f)
+ (path path))))
+ (_ #f))
+ opts)))
+
+ (append to-upgrade to-install))
+
;;;
;;; Entry point.
@@ -653,67 +930,6 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
(let ((out (derivation->output-path (%guile-for-build))))
(not (valid-path? (%store) out))))
- (define newest-available-packages
- (memoize find-newest-available-packages))
-
- (define (find-best-packages-by-name name version)
- (if version
- (find-packages-by-name name version)
- (match (vhash-assoc name (newest-available-packages))
- ((_ version pkgs ...) pkgs)
- (#f '()))))
-
- (define* (find-package name #:optional (output "out"))
- ;; Find the package NAME; NAME may contain a version number and a
- ;; sub-derivation name. If the version number is not present,
- ;; return the preferred newest version. If the sub-derivation name is not
- ;; present, use OUTPUT.
- (define request name)
-
- (define (ensure-output p sub-drv)
- (if (member sub-drv (package-outputs p))
- p
- (leave (_ "package `~a' lacks output `~a'~%")
- (package-full-name p)
- sub-drv)))
-
- (let*-values (((name sub-drv)
- (match (string-rindex name #\:)
- (#f (values name output))
- (colon (values (substring name 0 colon)
- (substring name (+ 1 colon))))))
- ((name version)
- (package-name->name+version name)))
- (match (find-best-packages-by-name name version)
- ((p)
- (list name (package-version p) sub-drv (ensure-output p sub-drv)
- (package-transitive-propagated-inputs p)))
- ((p p* ...)
- (warning (_ "ambiguous package specification `~a'~%")
- request)
- (warning (_ "choosing ~a from ~a~%")
- (package-full-name p)
- (location->string (package-location p)))
- (list name (package-version p) sub-drv (ensure-output p sub-drv)
- (package-transitive-propagated-inputs p)))
- (()
- (leave (_ "~a: package not found~%") request)))))
-
- (define (upgradeable? name current-version current-path)
- ;; Return #t if there's a version of package NAME newer than
- ;; CURRENT-VERSION, or if the newest available version is equal to
- ;; CURRENT-VERSION but would have an output path different than
- ;; CURRENT-PATH.
- (match (vhash-assoc name (newest-available-packages))
- ((_ candidate-version pkg . rest)
- (case (version-compare candidate-version current-version)
- ((>) #t)
- ((<) #f)
- ((=) (let ((candidate-path (derivation->output-path
- (package-derivation (%store) pkg))))
- (not (string=? current-path candidate-path))))))
- (#f #f)))
-
(define (ensure-default-profile)
;; Ensure the default profile symlink and directory exist and are
;; writable.
@@ -725,11 +941,11 @@ more information.~%"))
(exit 1))
;; Create ~/.guix-profile if it doesn't exist yet.
- (when (and %user-environment-directory
+ (when (and %user-profile-directory
%current-profile
(not (false-if-exception
- (lstat %user-environment-directory))))
- (symlink %current-profile %user-environment-directory))
+ (lstat %user-profile-directory))))
+ (symlink %current-profile %user-profile-directory))
(let ((s (stat %profile-directory #f)))
;; Attempt to create /…/profiles/per-user/$USER if needed.
@@ -767,48 +983,17 @@ more information.~%"))
(define verbose? (assoc-ref opts 'verbose?))
(define profile (assoc-ref opts 'profile))
- (define (canonicalize-deps deps)
- ;; Remove duplicate entries from DEPS, a list of propagated inputs,
- ;; where each input is a name/path tuple.
- (define (same? d1 d2)
- (match d1
- ((_ p1)
- (match d2
- ((_ p2) (eq? p1 p2))
- (_ #f)))
- ((_ p1 out1)
- (match d2
- ((_ p2 out2)
- (and (string=? out1 out2)
- (eq? p1 p2)))
- (_ #f)))))
-
- (delete-duplicates deps same?))
-
- (define (same-package? tuple name out)
- (match tuple
- ((tuple-name _ tuple-output _ ...)
- (and (equal? name tuple-name)
- (equal? out tuple-output)))))
-
- (define (package->tuple p)
- ;; Convert package P to a tuple.
- ;; When given a package via `-e', install the first of its
- ;; outputs (XXX).
- (let* ((out (car (package-outputs p)))
- (path (package-output (%store) p out))
- (deps (package-transitive-propagated-inputs p)))
- `(,(package-name p)
- ,(package-version p)
- ,out
- ,p
- ,(canonicalize-deps deps))))
+ (define (same-package? entry name output)
+ (match entry
+ (($ <manifest-entry> entry-name _ entry-output _ ...)
+ (and (equal? name entry-name)
+ (equal? output entry-output)))))
(define (show-what-to-remove/install remove install dry-run?)
;; Tell the user what's going to happen in high-level terms.
;; TODO: Report upgrades more clearly.
(match remove
- (((name version _ path _) ..1)
+ ((($ <manifest-entry> name version _ path _) ..1)
(let ((len (length name))
(remove (map (cut format #f " ~a-~a\t~a" <> <> <>)
name version path)))
@@ -825,7 +1010,7 @@ more information.~%"))
remove))))
(_ #f))
(match install
- (((name version output path _) ..1)
+ ((($ <manifest-entry> name version output path _) ..1)
(let ((len (length name))
(install (map (cut format #f " ~a-~a\t~a\t~a" <> <> <> <>)
name version output path)))
@@ -846,15 +1031,15 @@ more information.~%"))
(generation-number profile))
(define (display-and-delete number)
- (let ((generation (format #f "~a-~a-link" profile number)))
+ (let ((generation (generation-file-name profile number)))
(unless (zero? number)
(format #t (_ "deleting ~a~%") generation)
(delete-file generation))))
(define (delete-generation number)
(let* ((previous-number (previous-generation-number profile number))
- (previous-generation (format #f "~a-~a-link"
- profile previous-number)))
+ (previous-generation
+ (generation-file-name profile previous-number)))
(cond ((zero? number)) ; do not delete generation 0
((and (= number current-generation-number)
(not (file-exists? previous-generation)))
@@ -909,126 +1094,59 @@ more information.~%"))
(_ #f))
opts))
(else
- (let* ((installed (manifest-packages (profile-manifest profile)))
- (upgrade-regexps (filter-map (match-lambda
- (('upgrade . regexp)
- (make-regexp (or regexp "")))
- (_ #f))
- opts))
- (upgrade (if (null? upgrade-regexps)
- '()
- (let ((newest (find-newest-available-packages)))
- (filter-map
- (match-lambda
- ((name version output path _)
- (and (any (cut regexp-exec <> name)
- upgrade-regexps)
- (upgradeable? name version path)
- (find-package name
- (or output "out"))))
- (_ #f))
- installed))))
- (install (append
- upgrade
- (filter-map (match-lambda
- (('install . (? package? p))
- (package->tuple p))
- (('install . (? store-path?))
- #f)
- (('install . package)
- (find-package package))
+ (let* ((manifest (profile-manifest profile))
+ (install* (options->installable opts manifest))
+ (remove (filter-map (match-lambda
+ (('remove . package)
+ package)
(_ #f))
- opts)))
- (drv (filter-map (match-lambda
- ((name version sub-drv
- (? package? package)
- (deps ...))
- (check-package-freshness package)
- (package-derivation (%store) package))
- (_ #f))
- install))
- (install*
- (append
- (filter-map (match-lambda
- (('install . (? package? p))
- #f)
- (('install . (? store-path? path))
- (let-values (((name version)
- (package-name->name+version
- (store-path-package-name
- path))))
- `(,name ,version #f ,path ())))
- (_ #f))
- opts)
- (map (lambda (tuple drv)
- (match tuple
- ((name version sub-drv _ (deps ...))
- (let ((output-path
- (derivation->output-path
- drv sub-drv)))
- `(,name ,version ,sub-drv ,output-path
- ,(canonicalize-deps deps))))))
- install drv)))
- (remove (filter-map (match-lambda
- (('remove . package)
- package)
- (_ #f))
- opts))
- (remove* (filter-map (cut assoc <> installed) remove))
- (packages
+ opts))
+ (remove* (filter (cut manifest-installed? manifest <>)
+ remove))
+ (entries
(append install*
(fold (lambda (package result)
(match package
- ((name _ out _ ...)
- (filter (negate
- (cut same-package? <>
- name out))
- result))))
- (fold alist-delete installed remove)
- install*))))
-
- (when (equal? profile %current-profile)
- (ensure-default-profile))
-
- (show-what-to-remove/install remove* install* dry-run?)
- (show-what-to-build (%store) drv
- #:use-substitutes? (assoc-ref opts 'substitutes?)
- #:dry-run? dry-run?)
-
- (or dry-run?
- (and (build-derivations (%store) drv)
- (let* ((prof-drv (profile-derivation (%store) packages))
- (prof (derivation->output-path prof-drv))
- (old-drv (profile-derivation
- (%store) (manifest-packages
- (profile-manifest profile))))
- (old-prof (derivation->output-path old-drv))
- (number (generation-number profile))
-
- ;; Always use NUMBER + 1 for the new profile,
- ;; possibly overwriting a "previous future
- ;; generation".
- (name (format #f "~a-~a-link"
- profile (+ 1 number))))
- (if (string=? old-prof prof)
- (when (or (pair? install) (pair? remove))
- (format (current-error-port)
- (_ "nothing to be done~%")))
- (and (parameterize ((current-build-output-port
- ;; Output something when Guile
- ;; needs to be built.
- (if (or verbose? (guile-missing?))
- (current-error-port)
- (%make-void-port "w"))))
- (build-derivations (%store) (list prof-drv)))
- (let ((count (length packages)))
+ (($ <manifest-entry> name _ out _ ...)
+ (filter (negate
+ (cut same-package? <>
+ name out))
+ result))))
+ (manifest-entries
+ (manifest-remove manifest remove))
+ install*)))
+ (new (make-manifest entries)))
+
+ (when (equal? profile %current-profile)
+ (ensure-default-profile))
+
+ (if (manifest=? new manifest)
+ (format (current-error-port) (_ "nothing to be done~%"))
+ (let ((prof-drv (profile-derivation (%store) new)))
+ (show-what-to-remove/install remove* install* dry-run?)
+ (show-what-to-build (%store) (list prof-drv)
+ #:use-substitutes?
+ (assoc-ref opts 'substitutes?)
+ #:dry-run? dry-run?)
+
+ (or dry-run?
+ (let* ((prof (derivation->output-path prof-drv))
+ (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 ((count (length entries)))
(switch-symlinks name prof)
(switch-symlinks profile name)
(format #t (N_ "~a package in profile~%"
"~a packages in profile~%"
count)
count)
- (display-search-paths packages
+ (display-search-paths entries
profile)))))))))))
(define (process-query opts)
@@ -1049,15 +1167,15 @@ more information.~%"))
(format #t (_ "~a\t(current)~%") header)
(format #t "~a~%" header)))
(for-each (match-lambda
- ((name version output location _)
+ (($ <manifest-entry> name version output location _)
(format #t " ~a\t~a\t~a\t~a~%"
name version output location)))
;; Show most recently installed packages last.
(reverse
- (manifest-packages
+ (manifest-entries
(profile-manifest
- (format #f "~a-~a-link" profile number)))))
+ (generation-file-name profile number)))))
(newline)))
(cond ((not (file-exists? profile)) ; XXX: race condition
@@ -1082,9 +1200,9 @@ more information.~%"))
(('list-installed regexp)
(let* ((regexp (and regexp (make-regexp regexp)))
(manifest (profile-manifest profile))
- (installed (manifest-packages manifest)))
+ (installed (manifest-entries manifest)))
(for-each (match-lambda
- ((name version output path _)
+ (($ <manifest-entry> name version output path _)
(when (or (not regexp)
(regexp-exec regexp name))
(format #t "~a\t~a\t~a\t~a~%"
@@ -1125,9 +1243,9 @@ more information.~%"))
(('search-paths)
(let* ((manifest (profile-manifest profile))
- (packages (manifest-packages manifest))
- (settings (search-path-environment-variables packages
- profile
+ (entries (manifest-entries manifest))
+ (packages (map manifest-entry-name entries))
+ (settings (search-path-environment-variables entries profile
(const #f))))
(format #t "~{~a~%~}" settings)
#t))
@@ -1139,6 +1257,7 @@ more information.~%"))
(with-error-handling
(parameterize ((%store (open-connection)))
(set-build-options (%store)
+ #:print-build-trace #f
#:fallback? (assoc-ref opts 'fallback?)
#:use-substitutes?
(assoc-ref opts 'substitutes?)
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 023b83e6a3..b910276204 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -45,13 +45,54 @@ files."
(use-modules (guix build utils)
(system base compile)
(ice-9 ftw)
- (ice-9 match))
+ (ice-9 match)
+ (srfi srfi-1)
+ (srfi srfi-11)
+ (srfi srfi-26))
+
+ (setvbuf (current-output-port) _IOLBF)
+ (setvbuf (current-error-port) _IOLBF)
(let ((out (assoc-ref %outputs "out"))
(tar (assoc-ref %build-inputs "tar"))
(gzip (assoc-ref %build-inputs "gzip"))
(gcrypt (assoc-ref %build-inputs "gcrypt"))
(tarball (assoc-ref %build-inputs "tarball")))
+
+ (define* (compile-file* file #:key output-file (opts '()))
+ ;; Like 'compile-file', but remove any (guix …) and (gnu …) modules
+ ;; created during the process as an ugly workaround for
+ ;; <http://bugs.gnu.org/15602> (FIXME). This ensures correctness,
+ ;; but is overly conservative and very slow.
+
+ (define (module-directory+file module)
+ ;; Return the directory for MODULE, like the 'dir-hint' in
+ ;; boot-9.scm.
+ (match (module-name module)
+ ((beginning ... last)
+ (values (string-concatenate
+ (map (lambda (elt)
+ (string-append (symbol->string elt)
+ file-name-separator-string))
+ beginning))
+ (symbol->string last)))))
+
+ (define (clear-module-tree! root)
+ ;; Delete all the modules under ROOT.
+ (hash-for-each (lambda (name module)
+ (module-remove! root name)
+ (let-values (((dir name)
+ (module-directory+file module)))
+ (set-autoloaded! dir name #f))
+ (clear-module-tree! module))
+ (module-submodules root))
+ (hash-clear! (module-submodules root)))
+
+ (compile-file file #:output-file output-file #:opts opts)
+
+ (for-each (compose clear-module-tree! resolve-module)
+ '((guix) (gnu))))
+
(setenv "PATH" (string-append tar "/bin:" gzip "/bin"))
(system* "tar" "xvf" tarball)
@@ -66,27 +107,9 @@ files."
(format #t "copying and compiling Guix to `~a'...~%" out)
;; Copy everything under guix/ and gnu/ plus guix.scm.
- (file-system-fold (lambda (dir stat result) ; enter?
- (or (string-prefix? "./guix" dir)
- (string-prefix? "./gnu" dir)
- (string=? "." dir)))
- (lambda (file stat result) ; leaf
- (when (or (not (string=? (dirname file) "."))
- (string=? (basename file) "guix.scm"))
- (let ((target (string-drop file 1)))
- (copy-file file
- (string-append out target)))))
- (lambda (dir stat result) ; down
- (mkdir (string-append out
- (string-drop dir 1))))
- (const #t) ; up
- (const #t) ; skip
- (lambda (file stat errno result)
- (error "cannot access file"
- file (strerror errno)))
- #f
- "."
- lstat)
+ (copy-recursively "guix" (string-append out "/guix"))
+ (copy-recursively "gnu" (string-append out "/gnu"))
+ (copy-file "guix.scm" (string-append out "/guix.scm"))
;; Add a fake (guix config) module to allow the other modules to be
;; compiled. The user's (guix config) is the one that will be used.
@@ -107,15 +130,12 @@ files."
".go")))
(format (current-error-port)
"compiling '~a'...~%" file)
- (compile-file file
- #:output-file go
- #:opts %auto-compilation-options))))
+ (compile-file* file
+ #:output-file go
+ #:opts
+ %auto-compilation-options))))
- ;; XXX: Because of the autoload hack in (guix build
- ;; download), we must build it first to avoid errors since
- ;; (gnutls) is unavailable.
- (cons (string-append out "/guix/build/download.scm")
- (find-files out "\\.scm")))
+ (find-files out "\\.scm"))
;; Remove the "fake" (guix config).
(delete-file (string-append out "/guix/config.scm"))
@@ -137,7 +157,7 @@ files."
(define %default-options
;; Alist of default option values.
- '())
+ `((tarball-url . ,%snapshot-url)))
(define (show-help)
(display (_ "Usage: guix pull [OPTION]...
@@ -145,6 +165,8 @@ Download and deploy the latest version of Guix.\n"))
(display (_ "
--verbose produce verbose output"))
(display (_ "
+ --url=URL download the Guix tarball from URL"))
+ (display (_ "
--bootstrap use the bootstrap Guile to build the new Guix"))
(newline)
(display (_ "
@@ -159,6 +181,10 @@ Download and deploy the latest version of Guix.\n"))
(list (option '("verbose") #f #f
(lambda (opt name arg result)
(alist-cons 'verbose? #t result)))
+ (option '("url") #t #f
+ (lambda (opt name arg result)
+ (alist-cons 'tarball-url arg
+ (alist-delete 'tarball-url result))))
(option '("bootstrap") #f #f
(lambda (opt name arg result)
(alist-cons 'bootstrap? #t result)))
@@ -182,10 +208,10 @@ Download and deploy the latest version of Guix.\n"))
%default-options))
(with-error-handling
- (let ((opts (parse-options))
- (store (open-connection)))
- (let ((tarball (download-to-store store %snapshot-url
- "guix-latest.tar.gz")))
+ (let* ((opts (parse-options))
+ (store (open-connection))
+ (url (assoc-ref opts 'tarball-url)))
+ (let ((tarball (download-to-store store url "guix-latest.tar.gz")))
(unless tarball
(leave (_ "failed to download up-to-date source, exiting\n")))
(parameterize ((%guile-for-build
diff --git a/guix/ui.scm b/guix/ui.scm
index 4415997252..7f8ed970d4 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -123,7 +123,7 @@ messages."
(define (initialize-guix)
"Perform the usual initialization for stand-alone Guix commands."
(install-locale)
- (textdomain "guix")
+ (textdomain %gettext-domain)
;; Ignore SIGPIPE. If the daemon closes the connection, we prefer to be
;; notified via an EPIPE later.
generated by cgit v1.2.3 (git 2.45.0) at 2024-12-12 08:43:19 +0000