Add (guix profiles).
* guix/scripts/package.scm (show-what-to-remove/install): New procedure, moved from... (guix-package): ... here. (<manifest>, make-manifest, <manifest-entry>, profile-manifest, manifest->sexp, sexp->manifest, read-manifest, write-manifest, remove-manifest-entry, manifest-remove, manifest-installed?, manifest=?, profile-regexp, generation-numbers, previous-generation-number, profile-derivation, generation-number, generation-file-name, generation-time, lower-input): Move to... * guix/profiles.scm: ... here. New file. * Makefile.am (MODULES): Add it.
This commit is contained in:
Ludovic Courtès
parent
fdd6c72683
commit
cc4ecc2d88
|
|
@ -41,6 +41,7 @@ MODULES = \
|
||||||
guix/hash.scm \
|
guix/hash.scm \
|
||||||
guix/utils.scm \
|
guix/utils.scm \
|
||||||
guix/monads.scm \
|
guix/monads.scm \
|
||||||
|
guix/profiles.scm \
|
||||||
guix/serialization.scm \
|
guix/serialization.scm \
|
||||||
guix/nar.scm \
|
guix/nar.scm \
|
||||||
guix/derivations.scm \
|
guix/derivations.scm \
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,315 @@
|
||||||
|
;;; 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
|
||||||
|
|
||||||
|
read-manifest
|
||||||
|
write-manifest
|
||||||
|
|
||||||
|
manifest-remove
|
||||||
|
manifest-installed?
|
||||||
|
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 (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* (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
|
||||||
|
|
@ -23,22 +23,19 @@
|
||||||
#:use-module (guix store)
|
#:use-module (guix store)
|
||||||
#:use-module (guix derivations)
|
#:use-module (guix derivations)
|
||||||
#:use-module (guix packages)
|
#:use-module (guix packages)
|
||||||
|
#:use-module (guix profiles)
|
||||||
#:use-module (guix utils)
|
#:use-module (guix utils)
|
||||||
#:use-module (guix config)
|
#:use-module (guix config)
|
||||||
#:use-module (guix records)
|
|
||||||
#:use-module ((guix build utils) #:select (directory-exists? mkdir-p))
|
#:use-module ((guix build utils) #:select (directory-exists? mkdir-p))
|
||||||
#:use-module ((guix ftp-client) #:select (ftp-open))
|
#:use-module ((guix ftp-client) #:select (ftp-open))
|
||||||
#:use-module (ice-9 ftw)
|
|
||||||
#:use-module (ice-9 format)
|
#:use-module (ice-9 format)
|
||||||
#:use-module (ice-9 match)
|
#:use-module (ice-9 match)
|
||||||
#:use-module (ice-9 regex)
|
#:use-module (ice-9 regex)
|
||||||
#:use-module (ice-9 vlist)
|
#:use-module (ice-9 vlist)
|
||||||
#:use-module (srfi srfi-1)
|
#:use-module (srfi srfi-1)
|
||||||
#:use-module (srfi srfi-9)
|
|
||||||
#:use-module (srfi srfi-11)
|
#:use-module (srfi srfi-11)
|
||||||
#:use-module (srfi srfi-19)
|
#:use-module (srfi srfi-19)
|
||||||
#:use-module (srfi srfi-26)
|
#:use-module (srfi srfi-26)
|
||||||
#:use-module (srfi srfi-34)
|
|
||||||
#:use-module (srfi srfi-37)
|
#:use-module (srfi srfi-37)
|
||||||
#:use-module (gnu packages)
|
#:use-module (gnu packages)
|
||||||
#:use-module ((gnu packages base) #:select (guile-final))
|
#:use-module ((gnu packages base) #:select (guile-final))
|
||||||
|
|
@ -51,7 +48,7 @@
|
||||||
|
|
||||||
|
|
||||||
;;;
|
;;;
|
||||||
;;; User profile.
|
;;; Profiles.
|
||||||
;;;
|
;;;
|
||||||
|
|
||||||
(define %user-profile-directory
|
(define %user-profile-directory
|
||||||
|
|
@ -69,240 +66,6 @@
|
||||||
;; coexist with Nix profiles.
|
;; coexist with Nix profiles.
|
||||||
(string-append %profile-directory "/guix-profile"))
|
(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)
|
(define (link-to-empty-profile generation)
|
||||||
"Link GENERATION, a string, to the empty profile."
|
"Link GENERATION, a string, to the empty profile."
|
||||||
(let* ((drv (profile-derivation (%store) (manifest '())))
|
(let* ((drv (profile-derivation (%store) (manifest '())))
|
||||||
|
|
@ -340,11 +103,6 @@ the given MANIFEST."
|
||||||
(else
|
(else
|
||||||
(switch-to-previous-generation profile))))) ; anything 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)
|
(define* (matching-generations str #:optional (profile %current-profile)
|
||||||
#:key (duration-relation <=))
|
#:key (duration-relation <=))
|
||||||
"Return the list of available generations matching a pattern in STR. See
|
"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)
|
filter-by-duration)
|
||||||
(else #f)))
|
(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 _ 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)))
|
||||||
|
|
||||||
|
|
||||||
|
;;;
|
||||||
|
;;; Package specifications.
|
||||||
|
;;;
|
||||||
|
|
||||||
(define (find-packages-by-description rx)
|
(define (find-packages-by-description rx)
|
||||||
"Return the list of packages whose name, synopsis, or description matches
|
"Return the list of packages whose name, synopsis, or description matches
|
||||||
RX."
|
RX."
|
||||||
|
|
@ -437,16 +239,6 @@ RX."
|
||||||
(package-name p2))))
|
(package-name p2))))
|
||||||
same-location?))
|
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)
|
(define (input->name+path input)
|
||||||
"Convert the name/package/sub-drv tuple INPUT to a name/store-path tuple."
|
"Convert the name/package/sub-drv tuple INPUT to a name/store-path tuple."
|
||||||
(let loop ((input input))
|
(let loop ((input input))
|
||||||
|
|
@ -500,11 +292,6 @@ return its return value."
|
||||||
(format (current-error-port) " interrupted by signal ~a~%" SIGINT)
|
(format (current-error-port) " interrupted by signal ~a~%" SIGINT)
|
||||||
#f))))
|
#f))))
|
||||||
|
|
||||||
|
|
||||||
;;;
|
|
||||||
;;; Package specifications.
|
|
||||||
;;;
|
|
||||||
|
|
||||||
(define newest-available-packages
|
(define newest-available-packages
|
||||||
(memoize find-newest-available-packages))
|
(memoize find-newest-available-packages))
|
||||||
|
|
||||||
|
|
@ -989,44 +776,6 @@ more information.~%"))
|
||||||
(and (equal? name entry-name)
|
(and (equal? name entry-name)
|
||||||
(equal? output entry-output)))))
|
(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
|
(define current-generation-number
|
||||||
(generation-number profile))
|
(generation-number profile))
|
||||||
|
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue