summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2013-11-08 21:58:09 +0100
committerLudovic Courtès <ludo@gnu.org>2013-11-08 21:58:09 +0100
commit7db9608d52ab431165ab150a0a0707c686990c1c (patch)
treeb19d49a71e71f8da939a4825b545da3a31907e65 /guix
parent7a78cc7af24a1303dd0117cb977e15ca89a5dad8 (diff)
parent6a9957545ce51e7a50381059d4509d0dfcba0aba (diff)
Merge branch 'master' into core-updates
Conflicts: guix/packages.scm
Diffstat (limited to 'guix')
-rw-r--r--guix/packages.scm81
-rw-r--r--guix/profiles.scm347
-rw-r--r--guix/scripts/package.scm387
-rw-r--r--guix/ui.scm36
4 files changed, 516 insertions, 335 deletions
diff --git a/guix/packages.scm b/guix/packages.scm
index 157013a496..9a2f08d862 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -41,6 +41,9 @@
origin-patch-flags
origin-patch-inputs
origin-patch-guile
+ origin-snippet
+ origin-modules
+ origin-imported-modules
base32
<search-path-specification>
@@ -107,6 +110,7 @@
(sha256 origin-sha256) ; bytevector
(file-name origin-file-name (default #f)) ; optional file name
(patches origin-patches (default '())) ; list of file names
+ (snippet origin-snippet (default #f)) ; sexp or #f
(patch-flags origin-patch-flags ; list of strings
(default '("-p1")))
@@ -114,6 +118,10 @@
;; used to specify these dependencies when needed.
(patch-inputs origin-patch-inputs ; input list or #f
(default #f))
+ (modules origin-modules ; list of module names
+ (default '()))
+ (imported-modules origin-imported-modules ; list of module names
+ (default '()))
(patch-guile origin-patch-guile ; package or #f
(default #f)))
@@ -272,26 +280,38 @@ corresponds to the arguments expected by `set-path-environment-variable'."
(let ((distro (resolve-interface '(gnu packages base))))
(module-ref distro 'guile-final)))
-(define* (patch-and-repack store source patches inputs
+(define* (patch-and-repack store source patches
#:key
+ (inputs '())
+ (snippet #f)
(flags '("-p1"))
+ (modules '())
+ (imported-modules '())
(guile-for-build (%guile-for-build))
(system (%current-system)))
- "Unpack SOURCE (a derivation), apply all of PATCHES, and repack the tarball
-using the tools listed in INPUTS."
+ "Unpack SOURCE (a derivation or store path), apply all of PATCHES, and
+repack the tarball using the tools listed in INPUTS. When SNIPPET is true,
+it must be an s-expression that will run from within the directory where
+SOURCE was unpacked, after all of PATCHES have been applied. MODULES and
+IMPORTED-MODULES specify modules to use/import for use by SNIPPET."
+ (define source-file-name
+ ;; SOURCE is usually a derivation, but it could be a store file.
+ (if (derivation? source)
+ (derivation->output-path source)
+ source))
+
(define decompression-type
- (let ((out (derivation->output-path source)))
- (cond ((string-suffix? "gz" out) "gzip")
- ((string-suffix? "bz2" out) "bzip2")
- ((string-suffix? "lz" out) "lzip")
- (else "xz"))))
+ (cond ((string-suffix? "gz" source-file-name) "gzip")
+ ((string-suffix? "bz2" source-file-name) "bzip2")
+ ((string-suffix? "lz" source-file-name) "lzip")
+ (else "xz")))
(define original-file-name
- (let ((out (derivation->output-path source)))
- ;; Remove the store prefix plus the slash, hash, and hyphen.
- (let* ((sans (string-drop out (+ (string-length (%store-prefix)) 1)))
- (dash (string-index sans #\-)))
- (string-drop sans (+ 1 dash)))))
+ ;; Remove the store prefix plus the slash, hash, and hyphen.
+ (let* ((sans (string-drop source-file-name
+ (+ (string-length (%store-prefix)) 1)))
+ (dash (string-index sans #\-)))
+ (string-drop sans (+ 1 dash))))
(define patch-inputs
(map (lambda (number patch)
@@ -331,7 +351,24 @@ using the tools listed in INPUTS."
(format (current-error-port)
"source is under '~a'~%" directory)
(chdir directory)
+
(and (every apply-patch ',(map car patch-inputs))
+
+ ,@(if snippet
+ `((let ((module (make-fresh-user-module)))
+ (module-use-interfaces! module
+ (map resolve-interface
+ ',modules))
+ (module-define! module '%build-inputs
+ %build-inputs)
+ (module-define! module '%outputs %outputs)
+ ((@ (system base compile) compile)
+ ',snippet
+ #:to 'value
+ #:opts %auto-compilation-options
+ #:env module)))
+ '())
+
(begin (chdir "..") #t)
(zero? (system* tar "cvfa" out directory))))))))
@@ -351,19 +388,21 @@ using the tools listed in INPUTS."
`(("source" ,source)
,@inputs
,@patch-inputs)
+ #:modules imported-modules
#:guile-for-build guile-for-build)))
(define* (package-source-derivation store source
#:optional (system (%current-system)))
"Return the derivation path for SOURCE, a package source, for SYSTEM."
(match source
- (($ <origin> uri method sha256 name ())
- ;; No patches.
+ (($ <origin> uri method sha256 name () #f)
+ ;; No patches, no snippet: this is a fixed-output derivation.
(method store uri 'sha256 sha256 name
#:system system))
- (($ <origin> uri method sha256 name (patches ...) (flags ...)
- inputs guile-for-build)
- ;; One or more patches.
+ (($ <origin> uri method sha256 name (patches ...) snippet
+ (flags ...) inputs (modules ...) (imported-modules ...)
+ guile-for-build)
+ ;; Patches and/or a snippet.
(let ((source (method store uri 'sha256 sha256 name
#:system system))
(guile (match (or guile-for-build (%guile-for-build)
@@ -372,9 +411,13 @@ using the tools listed in INPUTS."
(package-derivation store p system))
((? derivation? drv)
drv))))
- (patch-and-repack store source patches inputs
+ (patch-and-repack store source patches
+ #:inputs inputs
+ #:snippet snippet
#:flags flags
#:system system
+ #:modules modules
+ #:imported-modules modules
#:guile-for-build guile)))
((and (? string?) (? store-path?) file)
file)
diff --git a/guix/profiles.scm b/guix/profiles.scm
new file mode 100644
index 0000000000..1f62099e45
--- /dev/null
+++ b/guix/profiles.scm
@@ -0,0 +1,347 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix profiles)
+ #:use-module (guix utils)
+ #:use-module (guix records)
+ #:use-module (guix derivations)
+ #:use-module (guix packages)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 regex)
+ #:use-module (ice-9 ftw)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-19)
+ #:use-module (srfi srfi-26)
+ #:export (manifest make-manifest
+ manifest?
+ manifest-entries
+
+ <manifest-entry> ; FIXME: eventually make it internal
+ manifest-entry
+ manifest-entry?
+ manifest-entry-name
+ manifest-entry-version
+ manifest-entry-output
+ manifest-entry-path
+ manifest-entry-dependencies
+
+ manifest-pattern
+ manifest-pattern?
+
+ read-manifest
+ write-manifest
+
+ manifest-remove
+ manifest-installed?
+ manifest-matching-entries
+ manifest=?
+
+ profile-manifest
+ profile-derivation
+ generation-number
+ generation-numbers
+ previous-generation-number
+ generation-time
+ generation-file-name))
+
+;;; Commentary:
+;;;
+;;; Tools to create and manipulate profiles---i.e., the representation of a
+;;; set of installed packages.
+;;;
+;;; Code:
+
+
+;;;
+;;; 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-record-type* <manifest-pattern> manifest-pattern
+ make-manifest-pattern
+ manifest-pattern?
+ (name manifest-pattern-name) ; string
+ (version manifest-pattern-version ; string | #f
+ (default #f))
+ (output manifest-pattern-output ; string | #f
+ (default "out")))
+
+(define (profile-manifest profile)
+ "Return the PROFILE's manifest."
+ (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))))
+
+ (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) ...)))
+ (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 ((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 (entry-predicate pattern)
+ "Return a procedure that returns #t when passed a manifest entry that
+matches NAME/OUTPUT/VERSION. OUTPUT and VERSION may be #f, in which case they
+are ignored."
+ (match pattern
+ (($ <manifest-pattern> name version output)
+ (match-lambda
+ (($ <manifest-entry> entry-name entry-version entry-output)
+ (and (string=? entry-name name)
+ (or (not entry-output) (not output)
+ (string=? entry-output output))
+ (or (not version)
+ (string=? entry-version version))))))))
+
+(define (manifest-remove manifest patterns)
+ "Remove entries for each of PATTERNS from MANIFEST. Each item in PATTERNS
+must be a manifest-pattern."
+ (define (remove-entry pattern lst)
+ (remove (entry-predicate pattern) lst))
+
+ (make-manifest (fold remove-entry
+ (manifest-entries manifest)
+ patterns)))
+
+(define (manifest-installed? manifest pattern)
+ "Return #t if MANIFEST has an entry matching PATTERN (a manifest-pattern),
+#f otherwise."
+ (->bool (find (entry-predicate pattern)
+ (manifest-entries manifest))))
+
+(define (manifest-matching-entries manifest patterns)
+ "Return all the entries of MANIFEST that match one of the PATTERNS."
+ (define predicates
+ (map entry-predicate patterns))
+
+ (define (matches? entry)
+ (any (lambda (pred)
+ (pred entry))
+ predicates))
+
+ (filter matches? (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* (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 (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)
+ (guix build union))
+
+ (setvbuf (current-output-port) _IOLBF)
+ (setvbuf (current-error-port) _IOLBF)
+
+ (let ((output (assoc-ref %outputs "out"))
+ (inputs (map cdr %build-inputs)))
+ (format #t "building profile '~a' with ~a packages...~%"
+ output (length inputs))
+ (union-build output inputs
+ #:log-port (%make-void-port "w"))
+ (call-with-output-file (string-append output "/manifest")
+ (lambda (p)
+ (pretty-print ',(manifest->sexp manifest) p))))))
+
+ (build-expression->derivation store "profile"
+ (%current-system)
+ builder
+ (append-map (match-lambda
+ (($ <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 (profile-regexp profile)
+ "Return a regular expression that matches PROFILE's name and number."
+ (make-regexp (string-append "^" (regexp-quote (basename profile))
+ "-([0-9]+)")))
+
+(define (generation-number profile)
+ "Return PROFILE's number or 0. An absolute file name must be used."
+ (or (and=> (false-if-exception (regexp-exec (profile-regexp profile)
+ (basename (readlink profile))))
+ (compose string->number (cut match:substring <> 1)))
+ 0))
+
+(define (generation-numbers profile)
+ "Return the sorted list of generation numbers of PROFILE, or '(0) if no
+former profiles were found."
+ (define* (scandir name #:optional (select? (const #t))
+ (entry<? (@ (ice-9 i18n) string-locale<?)))
+ ;; XXX: Bug-fix version introduced in Guile v2.0.6-62-g139ce19.
+ (define (enter? dir stat result)
+ (and stat (string=? dir name)))
+
+ (define (visit basename result)
+ (if (select? basename)
+ (cons basename result)
+ result))
+
+ (define (leaf name stat result)
+ (and result
+ (visit (basename name) result)))
+
+ (define (down name stat result)
+ (visit "." '()))
+
+ (define (up name stat result)
+ (visit ".." result))
+
+ (define (skip name stat result)
+ ;; All the sub-directories are skipped.
+ (visit (basename name) result))
+
+ (define (error name* stat errno result)
+ (if (string=? name name*) ; top-level NAME is unreadable
+ result
+ (visit (basename name*) result)))
+
+ (and=> (file-system-fold enter? leaf down up skip error #f name lstat)
+ (lambda (files)
+ (sort files entry<?))))
+
+ (match (scandir (dirname profile)
+ (cute regexp-exec (profile-regexp profile) <>))
+ (#f ; no profile directory
+ '(0))
+ (() ; no profiles
+ '(0))
+ ((profiles ...) ; former profiles around
+ (sort (map (compose string->number
+ (cut match:substring <> 1)
+ (cute regexp-exec (profile-regexp profile) <>))
+ profiles)
+ <))))
+
+(define (previous-generation-number profile number)
+ "Return the number of the generation before generation NUMBER of
+PROFILE, or 0 if none exists. It could be NUMBER - 1, but it's not the
+case when generations have been deleted (there are \"holes\")."
+ (fold (lambda (candidate highest)
+ (if (and (< candidate number) (> candidate highest))
+ candidate
+ highest))
+ 0
+ (generation-numbers profile)))
+
+(define (generation-file-name profile generation)
+ "Return the file name for PROFILE's GENERATION."
+ (format #f "~a-~a-link" profile generation))
+
+(define (generation-time profile number)
+ "Return the creation time of a generation in the UTC format."
+ (make-time time-utc 0
+ (stat:ctime (stat (generation-file-name profile number)))))
+
+;;; profiles.scm ends here
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 008ae53b47..bf39259922 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -23,22 +23,19 @@
#:use-module (guix store)
#:use-module (guix derivations)
#:use-module (guix packages)
+ #:use-module (guix profiles)
#: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)
#:use-module (ice-9 format)
#:use-module (ice-9 match)
#: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)
- #:use-module (srfi srfi-34)
#:use-module (srfi srfi-37)
#:use-module (gnu packages)
#:use-module ((gnu packages base) #:select (guile-final))
@@ -51,7 +48,7 @@
;;;
-;;; User profile.
+;;; Profiles.
;;;
(define %user-profile-directory
@@ -69,240 +66,6 @@
;; 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 ((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))))
-
- (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) ...)))
- (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 ((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))
- "-([0-9]+)")))
-
-(define (generation-numbers profile)
- "Return the sorted list of generation numbers of PROFILE, or '(0) if no
-former profiles were found."
- (define* (scandir name #:optional (select? (const #t))
- (entry<? (@ (ice-9 i18n) string-locale<?)))
- ;; XXX: Bug-fix version introduced in Guile v2.0.6-62-g139ce19.
- (define (enter? dir stat result)
- (and stat (string=? dir name)))
-
- (define (visit basename result)
- (if (select? basename)
- (cons basename result)
- result))
-
- (define (leaf name stat result)
- (and result
- (visit (basename name) result)))
-
- (define (down name stat result)
- (visit "." '()))
-
- (define (up name stat result)
- (visit ".." result))
-
- (define (skip name stat result)
- ;; All the sub-directories are skipped.
- (visit (basename name) result))
-
- (define (error name* stat errno result)
- (if (string=? name name*) ; top-level NAME is unreadable
- result
- (visit (basename name*) result)))
-
- (and=> (file-system-fold enter? leaf down up skip error #f name lstat)
- (lambda (files)
- (sort files entry<?))))
-
- (match (scandir (dirname profile)
- (cute regexp-exec (profile-regexp profile) <>))
- (#f ; no profile directory
- '(0))
- (() ; no profiles
- '(0))
- ((profiles ...) ; former profiles around
- (sort (map (compose string->number
- (cut match:substring <> 1)
- (cute regexp-exec (profile-regexp profile) <>))
- profiles)
- <))))
-
-(define (previous-generation-number profile number)
- "Return the number of the generation before generation NUMBER of
-PROFILE, or 0 if none exists. It could be NUMBER - 1, but it's not the
-case when generations have been deleted (there are \"holes\")."
- (fold (lambda (candidate highest)
- (if (and (< candidate number) (> candidate highest))
- candidate
- highest))
- 0
- (generation-numbers profile)))
-
-(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)
- (guix build union))
-
- (setvbuf (current-output-port) _IOLBF)
- (setvbuf (current-error-port) _IOLBF)
-
- (let ((output (assoc-ref %outputs "out"))
- (inputs (map cdr %build-inputs)))
- (format #t "building profile '~a' with ~a packages...~%"
- output (length inputs))
- (union-build output inputs
- #:log-port (%make-void-port "w"))
- (call-with-output-file (string-append output "/manifest")
- (lambda (p)
- (pretty-print ',(manifest->sexp manifest) p))))))
-
- (build-expression->derivation store "profile"
- (%current-system)
- builder
- (append-map (match-lambda
- (($ <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)
- "Return PROFILE's number or 0. An absolute file name must be used."
- (or (and=> (false-if-exception (regexp-exec (profile-regexp profile)
- (basename (readlink profile))))
- (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) (manifest '())))
@@ -340,11 +103,6 @@ the given MANIFEST."
(else
(switch-to-previous-generation profile))))) ; anything else
-(define (generation-time profile number)
- "Return the creation time of a generation in the UTC format."
- (make-time time-utc 0
- (stat:ctime (stat (generation-file-name profile number)))))
-
(define* (matching-generations str #:optional (profile %current-profile)
#:key (duration-relation <=))
"Return the list of available generations matching a pattern in STR. See
@@ -411,6 +169,50 @@ DURATION-RELATION with the current time."
filter-by-duration)
(else #f)))
+(define (show-what-to-remove/install remove install dry-run?)
+ "Given the manifest entries listed in REMOVE and INSTALL, display the
+packages that will/would be installed and removed."
+ ;; TODO: Report upgrades more clearly.
+ (match remove
+ ((($ <manifest-entry> name version output path _) ..1)
+ (let ((len (length name))
+ (remove (map (cut format #f " ~a-~a\t~a\t~a" <> <> <> <>)
+ name version output path)))
+ (if dry-run?
+ (format (current-error-port)
+ (N_ "The following package would be removed:~%~{~a~%~}~%"
+ "The following packages would be removed:~%~{~a~%~}~%"
+ len)
+ remove)
+ (format (current-error-port)
+ (N_ "The following package will be removed:~%~{~a~%~}~%"
+ "The following packages will be removed:~%~{~a~%~}~%"
+ len)
+ remove))))
+ (_ #f))
+ (match install
+ ((($ <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)))
+ (if dry-run?
+ (format (current-error-port)
+ (N_ "The following package would be installed:~%~{~a~%~}~%"
+ "The following packages would be installed:~%~{~a~%~}~%"
+ len)
+ install)
+ (format (current-error-port)
+ (N_ "The following package will be installed:~%~{~a~%~}~%"
+ "The following packages will be installed:~%~{~a~%~}~%"
+ len)
+ install))))
+ (_ #f)))
+
+
+;;;
+;;; Package specifications.
+;;;
+
(define (find-packages-by-description rx)
"Return the list of packages whose name, synopsis, or description matches
RX."
@@ -437,16 +239,6 @@ RX."
(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))
@@ -500,11 +292,6 @@ 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))
@@ -536,13 +323,8 @@ version; if SPEC does not specify an output, return OUTPUT."
(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)))
+ (let-values (((name version sub-drv)
+ (package-specification->name+version+output spec)))
(match (find-best-packages-by-name name version)
((p)
(values p (ensure-output p sub-drv)))
@@ -910,6 +692,22 @@ return the new list of manifest entries."
(append to-upgrade to-install))
+(define (options->removable options manifest)
+ "Given options, return the list of manifest patterns of packages to be
+removed from MANIFEST."
+ (filter-map (match-lambda
+ (('remove . spec)
+ (call-with-values
+ (lambda ()
+ (package-specification->name+version+output spec))
+ (lambda (name version output)
+ (manifest-pattern
+ (name name)
+ (version version)
+ (output output)))))
+ (_ #f))
+ options))
+
;;;
;;; Entry point.
@@ -989,44 +787,6 @@ more information.~%"))
(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
- ((($ <manifest-entry> name version _ path _) ..1)
- (let ((len (length name))
- (remove (map (cut format #f " ~a-~a\t~a" <> <> <>)
- name version path)))
- (if dry-run?
- (format (current-error-port)
- (N_ "The following package would be removed:~% ~{~a~%~}~%"
- "The following packages would be removed:~% ~{~a~%~}~%"
- len)
- remove)
- (format (current-error-port)
- (N_ "The following package will be removed:~% ~{~a~%~}~%"
- "The following packages will be removed:~% ~{~a~%~}~%"
- len)
- remove))))
- (_ #f))
- (match install
- ((($ <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)))
- (if dry-run?
- (format (current-error-port)
- (N_ "The following package would be installed:~%~{~a~%~}~%"
- "The following packages would be installed:~%~{~a~%~}~%"
- len)
- install)
- (format (current-error-port)
- (N_ "The following package will be installed:~%~{~a~%~}~%"
- "The following packages will be installed:~%~{~a~%~}~%"
- len)
- install))))
- (_ #f)))
-
(define current-generation-number
(generation-number profile))
@@ -1095,16 +855,10 @@ more information.~%"))
opts))
(else
(let* ((manifest (profile-manifest profile))
- (install* (options->installable opts manifest))
- (remove (filter-map (match-lambda
- (('remove . package)
- package)
- (_ #f))
- opts))
- (remove* (filter (cut manifest-installed? manifest <>)
- remove))
+ (install (options->installable opts manifest))
+ (remove (options->removable opts manifest))
(entries
- (append install*
+ (append install
(fold (lambda (package result)
(match package
(($ <manifest-entry> name _ out _ ...)
@@ -1114,7 +868,7 @@ more information.~%"))
result))))
(manifest-entries
(manifest-remove manifest remove))
- install*)))
+ install)))
(new (make-manifest entries)))
(when (equal? profile %current-profile)
@@ -1122,8 +876,9 @@ more information.~%"))
(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?)
+ (let ((prof-drv (profile-derivation (%store) new))
+ (remove (manifest-matching-entries manifest remove)))
+ (show-what-to-remove/install remove install dry-run?)
(show-what-to-build (%store) (list prof-drv)
#:use-substitutes?
(assoc-ref opts 'substitutes?)
diff --git a/guix/ui.scm b/guix/ui.scm
index 7f8ed970d4..8a28574c3c 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -52,6 +52,7 @@
fill-paragraph
string->recutils
package->recutils
+ package-specification->name+version+output
string->generations
string->duration
args-fold*
@@ -136,6 +137,11 @@ messages."
"Display version information for COMMAND and `(exit 0)'."
(simple-format #t "~a (~a) ~a~%"
command %guix-package-name %guix-version)
+ (display (_ "Copyright (C) 2013 the Guix authors
+License GPLv3+: GNU GPL version 3 or later <http://gnu.org/licenses/gpl.html>
+This is free software: you are free to change and redistribute it.
+There is NO WARRANTY, to the extent permitted by law.
+"))
(exit 0))
(define (show-bug-report-information)
@@ -358,6 +364,11 @@ converted to a space; sequences of more than one line break are preserved."
((_ _ chars)
(list->string (reverse chars)))))
+
+;;;
+;;; Packages.
+;;;
+
(define (string->recutils str)
"Return a version of STR where newlines have been replaced by newlines
followed by \"+ \", which makes for a valid multi-line field value in the
@@ -472,6 +483,31 @@ following patterns: \"1d\", \"1w\", \"1m\"."
(hours->duration (* 24 30) match)))
(else #f)))
+(define* (package-specification->name+version+output spec
+ #:optional (output "out"))
+ "Parse package specification SPEC and return three value: the specified
+package name, version number (or #f), and output name (or OUTPUT). 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
+"
+ (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)))
+ (values name version sub-drv)))
+
+
+;;;
+;;; Command-line option processing.
+;;;
+
(define (args-fold* options unrecognized-option-proc operand-proc . seeds)
"A wrapper on top of `args-fold' that does proper user-facing error
reporting."