me/guix
Archived
1
0
Fork 0
Code Activity

install: Use (guix store database) instead of 'guix-register'.

Browse source 
* gnu/build/install.scm (register-closure): Add #:reset-timestamps? and
and #:schema; honor them.  Rewrite in terms of 'register-path'.
(populate-single-profile-directory): Add #:schema and honor it.  Make
/var/guix/profiles and /var/guix/gcroots.
* gnu/build/vm.scm (root-partition-initializer): Pass
 #:reset-timestamps? to 'register-closure'.
* gnu/system/vm.scm (not-config?): New procedure.
(guile-sqlite3&co): New variable.
(expression->derivation-in-linux-vm)[config]: New variable.
[builder]: Use 'with-extensions'.
(iso9660-image)[schema, config]: New variables.
Wrap build expression in 'with-extensions'; add 'sql-schema' call.
Remove GUIX from INPUTS.
(qemu-image)[schema, config]: New variables.
Wrap body in 'with-extensions'.
(system-docker-image)[not-config?]: Remove.
[config]: Use 'make-config.scm'.
[schema]: New variable.
[build]: Use 'with-extensions'.  Add call to 'sql-schema'.  Remove GUIX
from INPUTS.
* gnu/system/file-systems.scm (%store-prefix): Check whether
'%store-prefix' is defined.
* guix/scripts/pack.scm (self-contained-tarball)[not-config?]
[libgcrypt, schema]: New variables.
[build]: Wrap in 'with-extensions'.  Adjust imported module list to use
'make-config.scm' for (guix config).
This commit is contained in:
Ludovic Courtès 2018-06-06 23:58:18 +02:00
parent be43c08b17
commit c45477d2a1
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
5 changed files with 356 additions and 279 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

45
gnu/build/install.scm
View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com> ;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
@ -18,6 +18,7 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu build install) (define-module (gnu build install)
#:use-module (guix store database)
#:use-module (guix build utils) #:use-module (guix build utils)
#:use-module (guix build store-copy) #:use-module (guix build store-copy)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
@ -158,23 +159,31 @@ as created and modified at the Epoch."
(utime file 0 0 0 0)))) (utime file 0 0 0 0))))
(find-files directory #:directories? #t))) (find-files directory #:directories? #t)))
(define* (register-closure store closure (define* (register-closure prefix closure
#:key (deduplicate? #t)) #:key
"Register CLOSURE in STORE, where STORE is the directory name of the target (deduplicate? #t) (reset-timestamps? #t)
store and CLOSURE is the name of a file containing a reference graph as used (schema (sql-schema)))
by 'guix-register'. As a side effect, this resets timestamps on store files "Register CLOSURE in PREFIX, where PREFIX is the directory name of the
and, if DEDUPLICATE? is true, deduplicates files common to CLOSURE and the target store and CLOSURE is the name of a file containing a reference graph as
rest of STORE." produced by #:references-graphs.. As a side effect, if RESET-TIMESTAMPS? is
(let ((status (apply system* "guix-register" "--prefix" store true, reset timestamps on store files and, if DEDUPLICATE? is true,
(append (if deduplicate? '() '("--no-deduplication")) deduplicates files common to CLOSURE and the rest of PREFIX."
(list closure))))) (let ((items (call-with-input-file closure read-reference-graph)))
(unless (zero? status) ;; TODO: Add a procedure to register all of ITEMS at once.
(error "failed to register store items" closure)))) (for-each (lambda (item)
(register-path (store-info-item item)
#:references (store-info-references item)
#:deriver (store-info-deriver item)
#:prefix prefix
#:deduplicate? deduplicate?
#:reset-timestamps? reset-timestamps?
#:schema schema))
items)))
(define* (populate-single-profile-directory directory (define* (populate-single-profile-directory directory
#:key profile closure #:key profile closure
deduplicate? deduplicate?
register?) register? schema)
"Populate DIRECTORY with a store containing PROFILE, whose closure is given "Populate DIRECTORY with a store containing PROFILE, whose closure is given
in the file called CLOSURE (as generated by #:references-graphs.) DIRECTORY in the file called CLOSURE (as generated by #:references-graphs.) DIRECTORY
is initialized to contain a single profile under /root pointing to PROFILE. is initialized to contain a single profile under /root pointing to PROFILE.
@ -200,11 +209,11 @@ This is used to create the self-contained tarballs with 'guix pack'."
(when register? (when register?
(register-closure (canonicalize-path directory) closure (register-closure (canonicalize-path directory) closure
#:deduplicate? deduplicate?) #:deduplicate? deduplicate?
#:schema schema)
;; XXX: 'guix-register' registers profiles as GC roots but the symlink (mkdir-p* "/var/guix/profiles")
;; target uses $TMPDIR. Fix that. (mkdir-p* "/var/guix/gcroots")
(delete-file (scope "/var/guix/gcroots/profiles"))
(symlink* "/var/guix/profiles" (symlink* "/var/guix/profiles"
"/var/guix/gcroots/profiles")) "/var/guix/gcroots/profiles"))

1
gnu/build/vm.scm
View file

@ -354,6 +354,7 @@ SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation."
(for-each (lambda (closure) (for-each (lambda (closure)
(register-closure target (register-closure target
(string-append "/xchg/" closure) (string-append "/xchg/" closure)
#:reset-timestamps? copy-closures?
#:deduplicate? deduplicate?)) #:deduplicate? deduplicate?))
closures) closures)
(unless copy-closures? (unless copy-closures?

11
gnu/system/file-systems.scm
View file

@ -194,10 +194,15 @@
;; differs from user to user. ;; differs from user to user.
(define (%store-prefix) (define (%store-prefix)
"Return the store prefix." "Return the store prefix."
(cond ((resolve-module '(guix store) #:ensure #f) ;; Note: If we have (guix store database) in the search path and we do *not*
=> ;; have (guix store) proper, 'resolve-module' returns an empty (guix store)
;; with one sub-module.
(cond ((and=> (resolve-module '(guix store) #:ensure #f)
(lambda (store) (lambda (store)
((module-ref store '%store-prefix)))) (module-variable store '%store-prefix)))
=>
(lambda (variable)
((variable-ref variable))))
((getenv "NIX_STORE") ((getenv "NIX_STORE")
=> identity) => identity)
(else (else

121
gnu/system/vm.scm
View file

@ -34,6 +34,7 @@
#:use-module (guix utils) #:use-module (guix utils)
#:use-module (guix hash) #:use-module (guix hash)
#:use-module (guix base32) #:use-module (guix base32)
#:use-module ((guix self) #:select (make-config.scm))
#:use-module ((gnu build vm) #:use-module ((gnu build vm)
#:select (qemu-command)) #:select (qemu-command))
@ -50,7 +51,6 @@
#:use-module (gnu packages disk) #:use-module (gnu packages disk)
#:use-module (gnu packages zile) #:use-module (gnu packages zile)
#:use-module (gnu packages linux) #:use-module (gnu packages linux)
#:use-module (gnu packages package-management)
#:use-module ((gnu packages make-bootstrap) #:use-module ((gnu packages make-bootstrap)
#:select (%guile-static-stripped)) #:select (%guile-static-stripped))
#:use-module (gnu packages admin) #:use-module (gnu packages admin)
@ -116,6 +116,19 @@
(options "trans=virtio") (options "trans=virtio")
(check? #f)))) (check? #f))))
(define not-config?
;; Select (guix …) and (gnu …) modules, except (guix config).
(match-lambda
(('guix 'config) #f)
(('guix rest ...) #t)
(('gnu rest ...) #t)
(rest #f)))
(define guile-sqlite3&co
;; Guile-SQLite3 and its propagated inputs.
(cons guile-sqlite3
(package-transitive-propagated-inputs guile-sqlite3)))
(define* (expression->derivation-in-linux-vm name exp (define* (expression->derivation-in-linux-vm name exp
#:key #:key
(system (%current-system)) (system (%current-system))
@ -151,6 +164,10 @@ based on the size of the closure of REFERENCES-GRAPHS.
When REFERENCES-GRAPHS is true, it must be a list of file name/store path When REFERENCES-GRAPHS is true, it must be a list of file name/store path
pairs, as for `derivation'. The files containing the reference graphs are pairs, as for `derivation'. The files containing the reference graphs are
made available under the /xchg CIFS share." made available under the /xchg CIFS share."
(define config
;; (guix config) module for consumption by (guix gcrypt).
(make-config.scm #:libgcrypt libgcrypt))
(define user-builder (define user-builder
(program-file "builder-in-linux-vm" exp)) (program-file "builder-in-linux-vm" exp))
@ -178,13 +195,17 @@ made available under the /xchg CIFS share."
(define builder (define builder
;; Code that launches the VM that evaluates EXP. ;; Code that launches the VM that evaluates EXP.
(with-imported-modules (source-module-closure '((guix build utils) (with-extensions guile-sqlite3&co
(gnu build vm))) (with-imported-modules `(,@(source-module-closure
'((guix build utils)
(gnu build vm))
#:select? not-config?)
((guix config) => ,config))
#~(begin #~(begin
(use-modules (guix build utils) (use-modules (guix build utils)
(gnu build vm)) (gnu build vm))
(let* ((inputs '#$(list qemu coreutils)) (let* ((inputs '#$(list qemu (canonical-package coreutils)))
(linux (string-append #$linux "/" (linux (string-append #$linux "/"
#$(system-linux-image-file-name))) #$(system-linux-image-file-name)))
(initrd (string-append #$initrd "/initrd")) (initrd (string-append #$initrd "/initrd"))
@ -211,7 +232,7 @@ made available under the /xchg CIFS share."
#:target-arm32? #$(target-arm32?) #:target-arm32? #$(target-arm32?)
#:disk-image-format #$disk-image-format #:disk-image-format #$disk-image-format
#:disk-image-size size #:disk-image-size size
#:references-graphs graphs))))) #:references-graphs graphs))))))
(gexp->derivation name builder (gexp->derivation name builder
;; TODO: Require the "kvm" feature. ;; TODO: Require the "kvm" feature.
@ -234,19 +255,33 @@ made available under the /xchg CIFS share."
"Return a bootable, stand-alone iso9660 image. "Return a bootable, stand-alone iso9660 image.
INPUTS is a list of inputs (as for packages)." INPUTS is a list of inputs (as for packages)."
(define config
(make-config.scm #:libgcrypt libgcrypt))
(define schema
(and register-closures?
(local-file (search-path %load-path
"guix/store/schema.sql"))))
(expression->derivation-in-linux-vm (expression->derivation-in-linux-vm
name name
(with-imported-modules (source-module-closure '((gnu build vm) (with-extensions guile-sqlite3&co
(guix build utils))) (with-imported-modules `(,@(source-module-closure '((gnu build vm)
(guix store database)
(guix build utils))
#:select? not-config?)
((guix config) => ,config))
#~(begin #~(begin
(use-modules (gnu build vm) (use-modules (gnu build vm)
(guix store database)
(guix build utils)) (guix build utils))
(sql-schema #$schema)
(let ((inputs (let ((inputs
'#$(append (list qemu parted e2fsprogs dosfstools xorriso) '#$(append (list qemu parted e2fsprogs dosfstools xorriso)
(map canonical-package (map canonical-package
(list sed grep coreutils findutils gawk)) (list sed grep coreutils findutils gawk))))
(if register-closures? (list guix) '())))
(graphs '#$(match inputs (graphs '#$(match inputs
@ -269,7 +304,7 @@ INPUTS is a list of inputs (as for packages)."
#:closures graphs #:closures graphs
#:volume-id #$file-system-label #:volume-id #$file-system-label
#:volume-uuid #$(and=> file-system-uuid #:volume-uuid #$(and=> file-system-uuid
uuid-bytevector))))) uuid-bytevector))))))
#:system system #:system system
;; Keep a local file system for /tmp so that we can populate it directly as ;; Keep a local file system for /tmp so that we can populate it directly as
@ -312,23 +347,37 @@ INPUTS is a list of inputs (as for packages). When COPY-INPUTS? is true, copy
all of INPUTS into the image being built. When REGISTER-CLOSURES? is true, all of INPUTS into the image being built. When REGISTER-CLOSURES? is true,
register INPUTS in the store database of the image so that Guix can be used in register INPUTS in the store database of the image so that Guix can be used in
the image." the image."
(define config
(make-config.scm #:libgcrypt libgcrypt))
(define schema
(and register-closures?
(local-file (search-path %load-path
"guix/store/schema.sql"))))
(expression->derivation-in-linux-vm (expression->derivation-in-linux-vm
name name
(with-imported-modules (source-module-closure '((gnu build bootloader) (with-extensions guile-sqlite3&co
(gnu build vm) (with-imported-modules `(,@(source-module-closure '((gnu build vm)
(guix build utils))) (gnu build bootloader)
(guix store database)
(guix build utils))
#:select? not-config?)
((guix config) => ,config))
#~(begin #~(begin
(use-modules (gnu build bootloader) (use-modules (gnu build bootloader)
(gnu build vm) (gnu build vm)
(guix store database)
(guix build utils) (guix build utils)
(srfi srfi-26) (srfi srfi-26)
(ice-9 binary-ports)) (ice-9 binary-ports))
(sql-schema #$schema)
(let ((inputs (let ((inputs
'#$(append (list qemu parted e2fsprogs dosfstools) '#$(append (list qemu parted e2fsprogs dosfstools)
(map canonical-package (map canonical-package
(list sed grep coreutils findutils gawk)) (list sed grep coreutils findutils gawk))))
(if register-closures? (list guix) '())))
;; This variable is unused but allows us to add INPUTS-TO-COPY ;; This variable is unused but allows us to add INPUTS-TO-COPY
;; as inputs. ;; as inputs.
@ -395,7 +444,7 @@ the image."
#:bootcfg-location #:bootcfg-location
#$(bootloader-configuration-file bootloader) #$(bootloader-configuration-file bootloader)
#:bootloader-installer #:bootloader-installer
#$(bootloader-installer bootloader)))))) #$(bootloader-installer bootloader)))))))
#:system system #:system system
#:make-disk-image? #t #:make-disk-image? #t
#:disk-image-size disk-image-size #:disk-image-size disk-image-size
@ -413,49 +462,41 @@ makes sense when you want to build a GuixSD Docker image that has Guix
installed inside of it. If you don't need Guix (e.g., your GuixSD Docker installed inside of it. If you don't need Guix (e.g., your GuixSD Docker
image just contains a web server that is started by the Shepherd), then you image just contains a web server that is started by the Shepherd), then you
should set REGISTER-CLOSURES? to #f." should set REGISTER-CLOSURES? to #f."
(define not-config?
(match-lambda
(('guix 'config) #f)
(('guix rest ...) #t)
(('gnu rest ...) #t)
(rest #f)))
(define config (define config
;; (guix config) module for consumption by (guix gcrypt). ;; (guix config) module for consumption by (guix gcrypt).
(scheme-file "gcrypt-config.scm" (make-config.scm #:libgcrypt libgcrypt))
#~(begin
(define-module (guix config)
#:export (%libgcrypt))
;; XXX: Work around <http://bugs.gnu.org/15602>. (define schema
(eval-when (expand load eval) (and register-closures?
(define %libgcrypt (local-file (search-path %load-path
#+(file-append libgcrypt "/lib/libgcrypt")))))) "guix/store/schema.sql"))))
(mlet %store-monad ((os-drv (operating-system-derivation os #:container? #t)) (mlet %store-monad ((os-drv (operating-system-derivation os #:container? #t))
(name -> (string-append name ".tar.gz")) (name -> (string-append name ".tar.gz"))
(graph -> "system-graph")) (graph -> "system-graph"))
(define build (define build
(with-extensions (list guile-json) ;for (guix docker) (with-extensions (cons guile-json ;for (guix docker)
guile-sqlite3&co) ;for (guix store database)
(with-imported-modules `(,@(source-module-closure (with-imported-modules `(,@(source-module-closure
'((guix docker) '((guix docker)
(guix store database)
(guix build utils) (guix build utils)
(guix build store-copy)
(gnu build vm)) (gnu build vm))
#:select? not-config?) #:select? not-config?)
(guix build store-copy)
((guix config) => ,config)) ((guix config) => ,config))
#~(begin #~(begin
(use-modules (guix docker) (use-modules (guix docker)
(guix build utils) (guix build utils)
(gnu build vm) (gnu build vm)
(srfi srfi-19) (srfi srfi-19)
(guix build store-copy)) (guix build store-copy)
(guix store database))
(let* ((inputs '#$(append (list tar) ;; Set the SQL schema location.
(if register-closures? (sql-schema #$schema)
(list guix)
'()))) (let* (;; This initializer requires elevated privileges that are
;; This initializer requires elevated privileges that are
;; not normally available in the build environment (e.g., ;; not normally available in the build environment (e.g.,
;; it needs to create device nodes). In order to obtain ;; it needs to create device nodes). In order to obtain
;; such privileges, we run it as root in a VM. ;; such privileges, we run it as root in a VM.
@ -470,7 +511,7 @@ should set REGISTER-CLOSURES? to #f."
;; lack of privileges if we use a root-directory that is on ;; lack of privileges if we use a root-directory that is on
;; a file system that is shared with the host (e.g., /tmp). ;; a file system that is shared with the host (e.g., /tmp).
(root-directory "/guixsd-system-root")) (root-directory "/guixsd-system-root"))
(set-path-environment-variable "PATH" '("bin" "sbin") inputs) (set-path-environment-variable "PATH" '("bin" "sbin") '(#+tar))
(mkdir root-directory) (mkdir root-directory)
(initialize root-directory) (initialize root-directory)
(build-docker-image (build-docker-image

43
guix/scripts/pack.scm
View file

@ -35,6 +35,7 @@
#:use-module (guix search-paths) #:use-module (guix search-paths)
#:use-module (guix build-system gnu) #:use-module (guix build-system gnu)
#:use-module (guix scripts build) #:use-module (guix scripts build)
#:use-module ((guix self) #:select (make-config.scm))
#:use-module (gnu packages) #:use-module (gnu packages)
#:use-module (gnu packages bootstrap) #:use-module (gnu packages bootstrap)
#:use-module (gnu packages compression) #:use-module (gnu packages compression)
@ -101,12 +102,35 @@ with a properly initialized store database.
SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be
added to the pack." added to the pack."
(define not-config?
(match-lambda
(('guix 'config) #f)
(('guix _ ...) #t)
(('gnu _ ...) #t)
(_ #f)))
(define libgcrypt
(module-ref (resolve-interface '(gnu packages gnupg))
'libgcrypt))
(define schema
(and localstatedir?
(local-file (search-path %load-path
"guix/store/schema.sql"))))
(define build (define build
(with-imported-modules (source-module-closure (with-imported-modules `(((guix config)
'((guix build utils) => ,(make-config.scm
#:libgcrypt libgcrypt))
,@(source-module-closure
`((guix build utils)
(guix build union) (guix build union)
(guix build store-copy) (guix build store-copy)
(gnu build install))) (gnu build install))
#:select? not-config?))
(with-extensions (cons guile-sqlite3
(package-transitive-propagated-inputs
guile-sqlite3))
#~(begin #~(begin
(use-modules (guix build utils) (use-modules (guix build utils)
((guix build union) #:select (relative-file-name)) ((guix build union) #:select (relative-file-name))
@ -146,12 +170,8 @@ added to the pack."
"cf" "/dev/null" "--files-from=/dev/null" "cf" "/dev/null" "--files-from=/dev/null"
"--sort=name"))) "--sort=name")))
;; We need Guix here for 'guix-register'. ;; Add 'tar' to the search path.
(setenv "PATH" (setenv "PATH" #+(file-append archiver "/bin"))
(string-append #$(if localstatedir?
(file-append guix "/sbin:")
"")
#$archiver "/bin"))
;; Note: there is not much to gain here with deduplication and there ;; Note: there is not much to gain here with deduplication and there
;; is the overhead of the '.links' directory, so turn it off. ;; is the overhead of the '.links' directory, so turn it off.
@ -162,7 +182,8 @@ added to the pack."
#:profile #$profile #:profile #$profile
#:closure "profile" #:closure "profile"
#:deduplicate? #f #:deduplicate? #f
#:register? #$localstatedir?) #:register? #$localstatedir?
#:schema #$schema)
;; Create SYMLINKS. ;; Create SYMLINKS.
(for-each (cut evaluate-populate-directive <> %root) (for-each (cut evaluate-populate-directive <> %root)
@ -207,7 +228,7 @@ added to the pack."
((source '-> _) ((source '-> _)
(string-append "." source)) (string-append "." source))
(_ #f)) (_ #f))
directives))))))))) directives))))))))))
(gexp->derivation (string-append name ".tar" (gexp->derivation (string-append name ".tar"
(compressor-extension compressor)) (compressor-extension compressor))