nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

* 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 @@
#:use-module (guix packages) #:use-module (guix packages)
#: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 ftw)
@ -33,6 +34,7 @@
#: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)
@ -67,30 +69,116 @@
;; 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 '())))
(define (profile-manifest profile) (define (profile-manifest profile)
"Return the PROFILE's manifest." "Return the PROFILE's manifest."
(let ((manifest (string-append profile "/manifest"))) (let ((file (string-append profile "/manifest")))
(if (file-exists? manifest) (if (file-exists? file)
(call-with-input-file manifest read) (call-with-input-file file read-manifest)
'(manifest (version 1) (packages ()))))) (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 (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) (('manifest ('version 0)
('packages ((name version output path) ...))) ('packages ((name version output path) ...)))
(zip name version output path (manifest
(make-list (length name) '()))) (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 ;; Version 1 adds a list of propagated inputs to the
;; name/version/output/path tuples. ;; name/version/output/path tuples.
(('manifest ('version 1) (('manifest ('version 1)
('packages (packages ...))) ('packages ((name version output path deps) ...)))
packages) (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)))) (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) (define (profile-regexp profile)
"Return a regular expression that matches PROFILE's name and number." "Return a regular expression that matches PROFILE's name and number."
(make-regexp (string-append "^" (regexp-quote (basename profile)) (make-regexp (string-append "^" (regexp-quote (basename profile))
@ -157,17 +245,9 @@ case when generations have been deleted (there are \"holes\")."
0 0
(generation-numbers profile))) (generation-numbers profile)))
(define (profile-derivation store packages) (define (profile-derivation store manifest)
"Return a derivation that builds a profile (a user environment) with "Return a derivation that builds a profile (a user environment) with the
all of PACKAGES, a list of name/version/output/path/deps tuples." given MANIFEST."
(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 builder (define builder
`(begin `(begin
(use-modules (ice-9 pretty-print) (use-modules (ice-9 pretty-print)
@ -183,9 +263,7 @@ all of PACKAGES, a list of name/version/output/path/deps tuples."
(union-build output inputs) (union-build output inputs)
(call-with-output-file (string-append output "/manifest") (call-with-output-file (string-append output "/manifest")
(lambda (p) (lambda (p)
(pretty-print '(manifest (version 1) (pretty-print ',(manifest->sexp manifest) p))))))
(packages ,packages*))
p))))))
(define ensure-valid-input (define ensure-valid-input
;; If a package object appears in the given input, turn it into a ;; If a package object appears in the given input, turn it into a
@ -200,11 +278,12 @@ all of PACKAGES, a list of name/version/output/path/deps tuples."
(%current-system) (%current-system)
builder builder
(append-map (match-lambda (append-map (match-lambda
((name version output path deps) (($ <manifest-entry> name version
output path deps)
`((,name ,path) `((,name ,path)
,@(map ensure-valid-input ,@(map ensure-valid-input
deps)))) deps))))
packages) (manifest-entries manifest))
#:modules '((guix build union)))) #:modules '((guix build union))))
(define (generation-number profile) (define (generation-number profile)
@ -216,7 +295,7 @@ all of PACKAGES, a list of name/version/output/path/deps tuples."
(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) '())) (let* ((drv (profile-derivation (%store) (manifest '())))
(prof (derivation->output-path drv "out"))) (prof (derivation->output-path drv "out")))
(when (not (build-derivations (%store) (list drv))) (when (not (build-derivations (%store) (list drv)))
(leave (_ "failed to build the empty profile~%"))) (leave (_ "failed to build the empty profile~%")))
@ -513,11 +592,11 @@ but ~a is available upstream~%")
;;; Search paths. ;;; Search paths.
;;; ;;;
(define* (search-path-environment-variables packages profile (define* (search-path-environment-variables entries profile
#:optional (getenv getenv)) #:optional (getenv getenv))
"Return environment variable definitions that may be needed for the use of "Return environment variable definitions that may be needed for the use of
PACKAGES in PROFILE. Use GETENV to determine the current settings and report ENTRIES, a list of manifest entries, in PROFILE. Use GETENV to determine the
only settings not already effective." current settings and report only settings not already effective."
;; Prefer ~/.guix-profile to the real profile directory name. ;; Prefer ~/.guix-profile to the real profile directory name.
(let ((profile (if (and %user-environment-directory (let ((profile (if (and %user-environment-directory
@ -530,9 +609,9 @@ only settings not already effective."
;; The search path info is not stored in the manifest. Thus, we infer the ;; The search path info is not stored in the manifest. Thus, we infer the
;; search paths from same-named packages found in the distro. ;; search paths from same-named packages found in the distro.
(define package-in-manifest->package (define manifest-entry->package
(match-lambda (match-lambda
((name version _ ...) (($ <manifest-entry> name version)
(match (append (find-packages-by-name name version) (match (append (find-packages-by-name name version)
(find-packages-by-name name)) (find-packages-by-name name))
((p _ ...) p) ((p _ ...) p)
@ -554,16 +633,16 @@ only settings not already effective."
variable variable
(string-join directories separator))))))) (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 (search-paths (delete-duplicates
(append-map package-native-search-paths (append-map package-native-search-paths
packages)))) packages))))
(filter-map search-path-definition search-paths)))) (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 "Display the search path environment variables that may need to be set for
PACKAGES, in the context of PROFILE." ENTRIES, a list of manifest entries, in the context of PROFILE."
(let ((settings (search-path-environment-variables packages profile))) (let ((settings (search-path-environment-variables entries profile)))
(unless (null? settings) (unless (null? settings)
(format #t (_ "The following environment variable definitions may be needed:~%")) (format #t (_ "The following environment variable definitions may be needed:~%"))
(format #t "~{ ~a~%~}" settings)))) (format #t "~{ ~a~%~}" settings))))
@ -709,13 +788,14 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
(cons `(query list-available ,(or arg "")) (cons `(query list-available ,(or arg ""))
result))))) result)))))
(define (options->installable opts installed) (define (options->installable opts manifest)
"Given INSTALLED, the set of currently installed packages, and OPTS, the "Given MANIFEST, the current manifest, and OPTS, the result of 'args-fold',
result of 'args-fold', return two values: the new list of manifest entries, return two values: the new list of manifest entries, and the list of
and the list of derivations that need to be built." derivations that need to be built."
(define (canonicalize-deps deps) (define (canonicalize-deps deps)
;; Remove duplicate entries from DEPS, a list of propagated inputs, ;; 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) (define (same? d1 d2)
(match d1 (match d1
((_ p1) ((_ p1)
@ -729,21 +809,27 @@ and the list of derivations that need to be built."
(eq? p1 p2))) (eq? p1 p2)))
(_ #f))))) (_ #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) (define (package->manifest-entry p output)
;; Convert package P to a manifest tuple. ;; 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 ;; When given a package via `-e', install the first of its
;; outputs (XXX). ;; outputs (XXX).
(check-package-freshness p)
(let* ((output (or output (car (package-outputs p)))) (let* ((output (or output (car (package-outputs p))))
(path (package-output (%store) p output)) (path (package-output (%store) p output))
(deps (package-transitive-propagated-inputs p))) (deps (package-transitive-propagated-inputs p)))
`(,(package-name p) (manifest-entry
,(package-version p) (name (package-name p))
,output (version (package-version p))
,path (output output)
,(canonicalize-deps deps)))) (path path)
(dependencies (canonicalize-deps deps)))))
(define upgrade-regexps (define upgrade-regexps
(filter-map (match-lambda (filter-map (match-lambda
@ -759,7 +845,7 @@ and the list of derivations that need to be built."
((_ ...) ((_ ...)
(let ((newest (find-newest-available-packages))) (let ((newest (find-newest-available-packages)))
(filter-map (match-lambda (filter-map (match-lambda
((name version output path _) (($ <manifest-entry> name version output path _)
(and (any (cut regexp-exec <> name) (and (any (cut regexp-exec <> name)
upgrade-regexps) upgrade-regexps)
(upgradeable? name version path) (upgradeable? name version path)
@ -769,12 +855,12 @@ and the list of derivations that need to be built."
(specification->package+output name output)) (specification->package+output name output))
list)))) list))))
(_ #f)) (_ #f))
installed))))) (manifest-entries manifest))))))
(define to-upgrade (define to-upgrade
(map (match-lambda (map (match-lambda
((package output) ((package output)
(package->tuple package output))) (package->manifest-entry package output)))
packages-to-upgrade)) packages-to-upgrade))
(define packages-to-install (define packages-to-install
@ -792,7 +878,7 @@ and the list of derivations that need to be built."
(define to-install (define to-install
(append (map (match-lambda (append (map (match-lambda
((package output) ((package output)
(package->tuple package output))) (package->manifest-entry package output)))
packages-to-install) packages-to-install)
(filter-map (match-lambda (filter-map (match-lambda
(('install . (? package?)) (('install . (? package?))
@ -801,7 +887,11 @@ and the list of derivations that need to be built."
(let-values (((name version) (let-values (((name version)
(package-name->name+version (package-name->name+version
(store-path-package-name path)))) (store-path-package-name path))))
`(,name ,version #f ,path ()))) (manifest-entry
(name name)
(version version)
(output #f)
(path path))))
(_ #f)) (_ #f))
opts))) opts)))
@ -888,17 +978,17 @@ more information.~%"))
(define verbose? (assoc-ref opts 'verbose?)) (define verbose? (assoc-ref opts 'verbose?))
(define profile (assoc-ref opts 'profile)) (define profile (assoc-ref opts 'profile))
(define (same-package? tuple name out) (define (same-package? entry name output)
(match tuple (match entry
((tuple-name _ tuple-output _ ...) (($ <manifest-entry> entry-name _ entry-output _ ...)
(and (equal? name tuple-name) (and (equal? name entry-name)
(equal? out tuple-output))))) (equal? output entry-output)))))
(define (show-what-to-remove/install remove install dry-run?) (define (show-what-to-remove/install remove install dry-run?)
;; Tell the user what's going to happen in high-level terms. ;; Tell the user what's going to happen in high-level terms.
;; TODO: Report upgrades more clearly. ;; TODO: Report upgrades more clearly.
(match remove (match remove
(((name version _ path _) ..1) ((($ <manifest-entry> name version _ path _) ..1)
(let ((len (length name)) (let ((len (length name))
(remove (map (cut format #f " ~a-~a\t~a" <> <> <>) (remove (map (cut format #f " ~a-~a\t~a" <> <> <>)
name version path))) name version path)))
@ -915,7 +1005,7 @@ more information.~%"))
remove)))) remove))))
(_ #f)) (_ #f))
(match install (match install
(((name version output path _) ..1) ((($ <manifest-entry> name version output path _) ..1)
(let ((len (length name)) (let ((len (length name))
(install (map (cut format #f " ~a-~a\t~a\t~a" <> <> <> <>) (install (map (cut format #f " ~a-~a\t~a\t~a" <> <> <> <>)
name version output path))) name version output path)))
@ -999,26 +1089,28 @@ more information.~%"))
(_ #f)) (_ #f))
opts)) opts))
(else (else
(let*-values (((installed) (let*-values (((manifest)
(manifest-packages (profile-manifest profile))) (profile-manifest profile))
((install* drv) ((install* drv)
(options->installable opts installed))) (options->installable opts manifest)))
(let* ((remove (filter-map (match-lambda (let* ((remove (filter-map (match-lambda
(('remove . package) (('remove . package)
package) package)
(_ #f)) (_ #f))
opts)) opts))
(remove* (filter-map (cut assoc <> installed) remove)) (remove* (filter (cut manifest-installed? manifest <>)
(packages remove))
(entries
(append install* (append install*
(fold (lambda (package result) (fold (lambda (package result)
(match package (match package
((name _ out _ ...) (($ <manifest-entry> name _ out _ ...)
(filter (negate (filter (negate
(cut same-package? <> (cut same-package? <>
name out)) name out))
result)))) result))))
(fold alist-delete installed remove) (manifest-entries
(manifest-remove manifest remove))
install*)))) install*))))
(when (equal? profile %current-profile) (when (equal? profile %current-profile)
@ -1031,11 +1123,12 @@ more information.~%"))
(or dry-run? (or dry-run?
(and (build-derivations (%store) drv) (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)) (prof (derivation->output-path prof-drv))
(old-drv (profile-derivation (old-drv (profile-derivation
(%store) (manifest-packages (%store) (profile-manifest profile)))
(profile-manifest profile))))
(old-prof (derivation->output-path old-drv)) (old-prof (derivation->output-path old-drv))
(number (generation-number profile)) (number (generation-number profile))
@ -1055,14 +1148,14 @@ more information.~%"))
(current-error-port) (current-error-port)
(%make-void-port "w")))) (%make-void-port "w"))))
(build-derivations (%store) (list prof-drv))) (build-derivations (%store) (list prof-drv)))
(let ((count (length packages))) (let ((count (length entries)))
(switch-symlinks name prof) (switch-symlinks name prof)
(switch-symlinks profile name) (switch-symlinks profile name)
(format #t (N_ "~a package in profile~%" (format #t (N_ "~a package in profile~%"
"~a packages in profile~%" "~a packages in profile~%"
count) count)
count) count)
(display-search-paths packages (display-search-paths entries
profile)))))))))))) profile))))))))))))
(define (process-query opts) (define (process-query opts)
@ -1083,13 +1176,13 @@ more information.~%"))
(format #t (_ "~a\t(current)~%") header) (format #t (_ "~a\t(current)~%") header)
(format #t "~a~%" header))) (format #t "~a~%" header)))
(for-each (match-lambda (for-each (match-lambda
((name version output location _) (($ <manifest-entry> name version output location _)
(format #t " ~a\t~a\t~a\t~a~%" (format #t " ~a\t~a\t~a\t~a~%"
name version output location))) name version output location)))
;; Show most recently installed packages last. ;; Show most recently installed packages last.
(reverse (reverse
(manifest-packages (manifest-entries
(profile-manifest (profile-manifest
(format #f "~a-~a-link" profile number))))) (format #f "~a-~a-link" profile number)))))
(newline))) (newline)))
@ -1116,9 +1209,9 @@ more information.~%"))
(('list-installed regexp) (('list-installed regexp)
(let* ((regexp (and regexp (make-regexp regexp))) (let* ((regexp (and regexp (make-regexp regexp)))
(manifest (profile-manifest profile)) (manifest (profile-manifest profile))
(installed (manifest-packages manifest))) (installed (manifest-entries manifest)))
(for-each (match-lambda (for-each (match-lambda
((name version output path _) (($ <manifest-entry> name version output path _)
(when (or (not regexp) (when (or (not regexp)
(regexp-exec regexp name)) (regexp-exec regexp name))
(format #t "~a\t~a\t~a\t~a~%" (format #t "~a\t~a\t~a\t~a~%"
@ -1159,9 +1252,9 @@ more information.~%"))
(('search-paths) (('search-paths)
(let* ((manifest (profile-manifest profile)) (let* ((manifest (profile-manifest profile))
(packages (manifest-packages manifest)) (entries (manifest-entries manifest))
(settings (search-path-environment-variables packages (packages (map manifest-entry-name entries))
profile (settings (search-path-environment-variables entries profile
(const #f)))) (const #f))))
(format #t "~{~a~%~}" settings) (format #t "~{~a~%~}" settings)
#t)) #t))