[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
01/01: DRAFT DRAFT 'guix package' applies grafts manually.
|
From: |
Ludovic Courtès |
|
Subject: |
01/01: DRAFT DRAFT 'guix package' applies grafts manually. |
|
Date: |
Sun, 8 Jan 2017 21:41:53 +0000 (UTC) |
civodul pushed a commit to branch wip-gexp-grafts
in repository guix.
commit d7483e3154776d74d7b85d0534dfbc4ccab5e706
Author: Ludovic Courtès <address@hidden>
Date: Sun Jan 8 22:40:10 2017 +0100
DRAFT DRAFT 'guix package' applies grafts manually.
Probably not the approach we'll end up taking, but it shows how 'guix
package' can (1) build the original ungrafted derivation, and (2) apply
the relevant grafts manually at the end.
---
guix/profiles.scm | 102 +++++++++++++++++++++++++++++-----------------
guix/scripts/package.scm | 76 ++++++++++++++++++++--------------
2 files changed, 110 insertions(+), 68 deletions(-)
diff --git a/guix/profiles.scm b/guix/profiles.scm
index e7707b6..ad7432a 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -32,6 +32,7 @@
#:use-module (guix search-paths)
#:use-module (guix gexp)
#:use-module (guix monads)
+ #:use-module (guix grafts)
#:use-module (guix store)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
@@ -94,6 +95,7 @@
packages->manifest
%default-profile-hooks
profile-derivation
+ profile-grafts
generation-number
generation-numbers
@@ -916,17 +918,11 @@ files for the truetype fonts of the @var{manifest}
entries."
xdg-desktop-database
xdg-mime-database))
-(define* (profile-derivation manifest
- #:key
- (hooks %default-profile-hooks)
- (locales? #t)
- system)
- "Return a derivation that builds a profile (aka. 'user environment') with
-the given MANIFEST. The profile includes additional derivations returned by
-the monadic procedures listed in HOOKS--such as an Info 'dir' file, etc.
-
-When LOCALES? is true, the build is performed under a UTF-8 locale; this adds
-a dependency on the 'glibc-utf8-locales' package."
+(define* (profile-build-expression manifest
+ #:key
+ (hooks %default-profile-hooks)
+ (locales? #t)
+ system)
(mlet %store-monad ((system (if system
(return system)
(current-system)))
@@ -956,37 +952,55 @@ a dependency on the 'glibc-utf8-locales' package."
(package-version glibc-utf8-locales)))
(setlocale LC_ALL "en_US.utf8")))
- (define builder
- (with-imported-modules '((guix build profiles)
- (guix build union)
- (guix build utils)
- (guix search-paths)
- (guix records))
- #~(begin
- (use-modules (guix build profiles)
- (guix search-paths)
- (srfi srfi-1))
+ (return
+ (with-imported-modules '((guix build profiles)
+ (guix build union)
+ (guix build utils)
+ (guix search-paths)
+ (guix records))
+ #~(begin
+ (use-modules (guix build profiles)
+ (guix search-paths)
+ (srfi srfi-1))
+
+ (setvbuf (current-output-port) _IOLBF)
+ (setvbuf (current-error-port) _IOLBF)
+
+ #+(if locales? set-utf8-locale #t)
+
+ (define search-paths
+ ;; Search paths of MANIFEST's packages, converted back to their
+ ;; record form.
+ (map sexp->search-path-specification
+ (delete-duplicates
+ '#$(map search-path-specification->sexp
+ (append-map manifest-entry-search-paths
+ (manifest-entries manifest))))))
+
+ (build-profile #$output '#$inputs
+ #:manifest '#$(manifest->gexp manifest)
+ #:search-paths search-paths))))))
- (setvbuf (current-output-port) _IOLBF)
- (setvbuf (current-error-port) _IOLBF)
-
- #+(if locales? set-utf8-locale #t)
-
- (define search-paths
- ;; Search paths of MANIFEST's packages, converted back to their
- ;; record form.
- (map sexp->search-path-specification
- (delete-duplicates
- '#$(map search-path-specification->sexp
- (append-map manifest-entry-search-paths
- (manifest-entries manifest))))))
-
- (build-profile #$output '#$inputs
- #:manifest '#$(manifest->gexp manifest)
- #:search-paths search-paths))))
+(define* (profile-derivation manifest
+ #:key
+ (graft? *unspecified*)
+ (hooks %default-profile-hooks)
+ (locales? #t)
+ system)
+ "Return a derivation that builds a profile (aka. 'user environment') with
+the given MANIFEST. The profile includes additional derivations returned by
+the monadic procedures listed in HOOKS--such as an Info 'dir' file, etc.
+When LOCALES? is true, the build is performed under a UTF-8 locale; this adds
+a dependency on the 'glibc-utf8-locales' package."
+ (mlet %store-monad ((builder (profile-build-expression manifest
+ #:hooks hooks
+ #:locales? locales?
+ #:system system))
+ (system (if system (return system) (current-system))))
(gexp->derivation "profile" builder
#:system system
+ #:graft? (if (boolean? graft?) graft? (%graft?))
;; Not worth offloading.
#:local-build? #t
@@ -996,6 +1010,18 @@ a dependency on the 'glibc-utf8-locales' package."
;; to have no substitute to offer.
#:substitutable? #f)))
+(define* (profile-grafts manifest
+ #:key
+ (hooks %default-profile-hooks)
+ (locales? #t)
+ system)
+ (mlet* %store-monad ((system (if system (return system) (current-system)))
+ (builder (profile-build-expression manifest
+ #:hooks hooks
+ #:locales? locales?
+ #:system system)))
+ (gexp-grafts builder system)))
+
(define (profile-regexp profile)
"Return a regular expression that matches PROFILE's name and number."
(make-regexp (string-append "^" (regexp-quote (basename profile))
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 90e7fa2..3222105 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -196,41 +196,57 @@ specified in MANIFEST, a manifest object."
(when (equal? profile %current-profile)
(ensure-default-profile))
- (let* ((prof-drv (run-with-store store
+ (let* ((hooks (if bootstrap?
+ '()
+ %default-profile-hooks))
+ (prof-drv (run-with-store store
(profile-derivation manifest
- #:hooks (if bootstrap?
- '()
- %default-profile-hooks)
- #:locales? (not bootstrap?))))
- (prof (derivation->output-path prof-drv)))
+ #:graft? #f
+ #:hooks hooks
+ #:locales? (not bootstrap?)))))
(show-what-to-build store (list prof-drv)
#:use-substitutes? use-substitutes?
#:dry-run? dry-run?)
- (cond
- (dry-run? #t)
- ((and (file-exists? profile)
- (and=> (readlink* profile) (cut string=? prof <>)))
- (format (current-error-port) (_ "nothing to be done~%")))
- (else
- (let* ((number (generation-number profile))
-
- ;; Always use NUMBER + 1 for the new profile, possibly
- ;; overwriting a "previous future generation".
- (name (generation-file-name profile (+ 1 number))))
- (and (build-derivations store (list prof-drv))
- (let* ((entries (manifest-entries manifest))
- (count (length entries)))
- (switch-symlinks name prof)
- (switch-symlinks profile name)
- (unless (string=? profile %current-profile)
- (register-gc-root store name))
- (format #t (N_ "~a package in profile~%"
- "~a packages in profile~%"
- count)
- count)
- (display-search-paths entries (list profile)
- #:kind 'prefix))))))))
+ (or dry-run?
+ (let* ((grafts (if (%graft?)
+ (run-with-store store
+ (profile-grafts manifest
+ #:hooks hooks
+ #:locales? (not bootstrap?)))
+ '()))
+ (prof-drv (if (null? grafts)
+ prof-drv
+ (graft-derivation store prof-drv grafts)))
+ (prof (derivation->output-path prof-drv)))
+ (cond
+ ((and (file-exists? profile)
+ (and=> (readlink* profile) (cut string=? prof <>)))
+ (format (current-error-port) (_ "nothing to be done~%")))
+ (else
+ (let* ((number (generation-number profile))
+
+ ;; Always use NUMBER + 1 for the new profile, possibly
+ ;; overwriting a "previous future generation".
+ (name (generation-file-name profile (+ 1 number))))
+ (and (build-derivations store (list prof-drv))
+ (let* ((entries (manifest-entries manifest))
+ (count (length entries)))
+ (switch-symlinks name prof)
+ (switch-symlinks profile name)
+ (unless (string=? profile %current-profile)
+ (register-gc-root store name))
+ (unless (null? grafts)
+ (format #t (N_ "applied ~a graft~%"
+ "applied ~a grafts~%"
+ (length grafts))
+ (length grafts)))
+ (format #t (N_ "~a package in profile~%"
+ "~a packages in profile~%"
+ count)
+ count)
+ (display-search-paths entries (list profile)
+ #:kind 'prefix))))))))))
;;;