mirror/guix
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/guix.git synced 2025-01-19 14:07:01 +01:00
Code Issues Projects Releases Packages Wiki Activity Actions

guix package: Introduce <manifest> and <manifest-entry> types.

Browse source 
* guix/scripts/package.scm (<manifest>, <manifest-entry>): New record
  types.
  (make-manifest, read-manifest, manifest->sexp, sexp->manifest,
  read-manifest, write-manifest, remove-manifest-entry, manifest-remove,
  manifest-installed?): New procedures.
  (profile-derivation): Take a manifest as the second parameter.  Use
  'manifest->sexp'.  Expect <manifest-entry> objects instead of
  "tuples".  Adjust callers accordingly.
  (search-path-environment-variables): Changes 'packages' parameter to
  'entries'.  Rename 'package-in-manifest->package' to
  'manifest-entry->package'; expect <manifest-entry> objects.
  (display-search-paths): Rename 'packages' to 'entries'.
  (options->installable): Change 'installed' to 'manifest'.  Have
  'canonicalize-deps' return name/path tuples instead of raw packages.
  Rename 'package->tuple' to 'package->manifest-entry'.  Use
  <manifest-entry> objects instead of tuples.
  (guix-package)[process-actions]: Likewise.  Rename 'packages' to
  'entries'.
  [process-query]: Use 'manifest-entries' instead of
  'manifest-packages'.
This commit is contained in:
Ludovic Courtès 2013-10-30 17:13:27 +01:00
parent edac884624
commit f067fc3e77
1 changed files with 179 additions and 86 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

265
guix/scripts/package.scm
View file

@ -25,6 +25,7 @@ (define-module (guix scripts package)
#: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 @@ (define-module (guix scripts package)
#: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)
@ -67,30 +69,116 @@ (define %current-profile
;; 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 '())))
(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))))
;;;
;;; 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 +245,9 @@ (define (previous-generation-number profile number)
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 (a user environment) with the
given MANIFEST."
(define builder
`(begin
(use-modules (ice-9 pretty-print)
@ -183,9 +263,7 @@ (define builder
(union-build output inputs)
(call-with-output-file (string-append output "/manifest")
(lambda (p)
(pretty-print '(manifest (version 1)
(packages ,packages*))
p))))))
(pretty-print ',(manifest->sexp manifest) p))))))
(define ensure-valid-input
;; If a package object appears in the given input, turn it into a
@ -200,11 +278,12 @@ (define ensure-valid-input
(%current-system)
builder
(append-map (match-lambda
((name version output path deps)
(($ <manifest-entry> name version
output path deps)
`((,name ,path)
,@(map ensure-valid-input
deps))))
packages)
(manifest-entries manifest))
#:modules '((guix build union))))
(define (generation-number profile)
@ -216,7 +295,7 @@ (define (generation-number profile)
(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~%")))
@ -513,11 +592,11 @@ (define (check-package-freshness package)
;;; Search paths.
;;;
(define* (search-path-environment-variables packages profile
(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
@ -530,9 +609,9 @@ (define* (search-path-environment-variables packages 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)
@ -554,16 +633,16 @@ (define search-path-definition
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))))
@ -709,13 +788,14 @@ (define %options
(cons `(query list-available ,(or arg ""))
result)))))
(define (options->installable opts installed)
"Given INSTALLED, the set of currently installed packages, and OPTS, the
result of 'args-fold', return two values: the new list of manifest entries,
and the list of derivations that need to be built."
(define (options->installable opts manifest)
"Given MANIFEST, the current manifest, and OPTS, the result of 'args-fold',
return two values: the new list of manifest entries, and the list of
derivations that need to be built."
(define (canonicalize-deps deps)
;; Remove duplicate entries from DEPS, a list of propagated inputs,
;; where each input is a name/path tuple.
;; where each input is a name/path tuple, and replace package objects with
;; store paths.
(define (same? d1 d2)
(match d1
((_ p1)
@ -729,21 +809,27 @@ (define (same? d1 d2)
(eq? p1 p2)))
(_ #f)))))
(delete-duplicates deps same?))
(map (match-lambda
((name package)
(list name (package-output (%store) package)))
((name package output)
(list name (package-output (%store) package output))))
(delete-duplicates deps same?)))
(define* (package->tuple p #:optional output)
;; Convert package P to a manifest tuple.
(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).
(check-package-freshness p)
(let* ((output (or output (car (package-outputs p))))
(path (package-output (%store) p output))
(deps (package-transitive-propagated-inputs p)))
`(,(package-name p)
,(package-version p)
,output
,path
,(canonicalize-deps deps))))
(manifest-entry
(name (package-name p))
(version (package-version p))
(output output)
(path path)
(dependencies (canonicalize-deps deps)))))
(define upgrade-regexps
(filter-map (match-lambda
@ -759,7 +845,7 @@ (define packages-to-upgrade
((_ ...)
(let ((newest (find-newest-available-packages)))
(filter-map (match-lambda
((name version output path _)
(($ <manifest-entry> name version output path _)
(and (any (cut regexp-exec <> name)
upgrade-regexps)
(upgradeable? name version path)
@ -769,12 +855,12 @@ (define packages-to-upgrade
(specification->package+output name output))
list))))
(_ #f))
installed)))))
(manifest-entries manifest))))))
(define to-upgrade
(map (match-lambda
((package output)
(package->tuple package output)))
(package->manifest-entry package output)))
packages-to-upgrade))
(define packages-to-install
@ -792,7 +878,7 @@ (define packages-to-install
(define to-install
(append (map (match-lambda
((package output)
(package->tuple package output)))
(package->manifest-entry package output)))
packages-to-install)
(filter-map (match-lambda
(('install . (? package?))
@ -801,7 +887,11 @@ (define to-install
(let-values (((name version)
(package-name->name+version
(store-path-package-name path))))
`(,name ,version #f ,path ())))
(manifest-entry
(name name)
(version version)
(output #f)
(path path))))
(_ #f))
opts)))
@ -888,17 +978,17 @@ (define dry-run? (assoc-ref opts 'dry-run?))
(define verbose? (assoc-ref opts 'verbose?))
(define profile (assoc-ref opts 'profile))
(define (same-package? tuple name out)
(match tuple
((tuple-name _ tuple-output _ ...)
(and (equal? name tuple-name)
(equal? out tuple-output)))))
(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)))
@ -915,7 +1005,7 @@ (define (show-what-to-remove/install remove install dry-run?)
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)))
@ -999,26 +1089,28 @@ (define (delete-generation number)
(_ #f))
opts))
(else
(let*-values (((installed)
(manifest-packages (profile-manifest profile)))
(let*-values (((manifest)
(profile-manifest profile))
((install* drv)
(options->installable opts installed)))
(let* ((remove (filter-map (match-lambda
(('remove . package)
package)
(_ #f))
opts))
(remove* (filter-map (cut assoc <> installed) remove))
(packages
(options->installable opts manifest)))
(let* ((remove (filter-map (match-lambda
(('remove . package)
package)
(_ #f))
opts))
(remove* (filter (cut manifest-installed? manifest <>)
remove))
(entries
(append install*
(fold (lambda (package result)
(match package
((name _ out _ ...)
(($ <manifest-entry> name _ out _ ...)
(filter (negate
(cut same-package? <>
name out))
result))))
(fold alist-delete installed remove)
(manifest-entries
(manifest-remove manifest remove))
install*))))
(when (equal? profile %current-profile)
@ -1031,11 +1123,12 @@ (define (delete-generation number)
(or dry-run?
(and (build-derivations (%store) drv)
(let* ((prof-drv (profile-derivation (%store) packages))
(let* ((prof-drv (profile-derivation (%store)
(make-manifest
entries)))
(prof (derivation->output-path prof-drv))
(old-drv (profile-derivation
(%store) (manifest-packages
(profile-manifest profile))))
(%store) (profile-manifest profile)))
(old-prof (derivation->output-path old-drv))
(number (generation-number profile))
@ -1055,14 +1148,14 @@ (define (delete-generation number)
(current-error-port)
(%make-void-port "w"))))
(build-derivations (%store) (list prof-drv)))
(let ((count (length packages)))
(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)
@ -1083,13 +1176,13 @@ (define (list-generation number)
(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)))))
(newline)))
@ -1116,9 +1209,9 @@ (define (list-generation number)
(('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~%"
@ -1159,9 +1252,9 @@ (define (list-generation number)
(('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))