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

pack: Move store database creation to a separate derivation. 

* guix/scripts/pack.scm (store-database): New procedure.
(self-contained-tarball): Use it when LOCALSTATEDIR? is true.
Remove 'schema' and add 'database'.
[build]: Pass DATABASE to 'populate-single-profile-directory'.
(squashfs-image): Remove #:deduplicate? parameter.
[build]: Remove (gnu build install) and (guix config) from the imported
modules.  Remove 'with-extensions'.
* gnu/build/install.scm (populate-single-profile-directory): Remove
 #:deduplicate?, #:register?, and #:schema; add #:database.  Remove call
to 'register-closure' and simply copy DATABASE instead.
This commit is contained in:
Ludovic Courtès 2018-10-27 23:47:59 +02:00
parent c6b05bacc0
commit ec4c81fe32
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 109 additions and 78 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
gnu/build/install.scm
View File

@ -161,14 +161,13 @@ deduplicates files common to CLOSURE and the rest of PREFIX."
(define* (populate-single-profile-directory directory (define* (populate-single-profile-directory directory
#:key profile closure #:key profile closure
(profile-name "guix-profile") (profile-name "guix-profile")
deduplicate? database)
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.
When REGISTER? is true, initialize DIRECTORY/var/guix/db to reflect the
contents of the store; DEDUPLICATE? determines whether to deduplicate files in When DATABASE is true, copy it to DIRECTORY/var/guix/db and create
the store. DIRECTORY/var/guix/gcroots and friends.
PROFILE-NAME is the name of the profile being created under PROFILE-NAME is the name of the profile being created under
/var/guix/profiles, typically either \"guix-profile\" or \"current-guix\". /var/guix/profiles, typically either \"guix-profile\" or \"current-guix\".
@ -189,11 +188,9 @@ This is used to create the self-contained tarballs with 'guix pack'."
;; Populate the store. ;; Populate the store.
(populate-store (list closure) directory) (populate-store (list closure) directory)
(when register? (when database
(register-closure (canonicalize-path directory) closure (install-file database (scope "/var/guix/db/"))
#:deduplicate? deduplicate? (chmod (scope "/var/guix/db/db.sqlite") #o644)
#:schema schema)
(mkdir-p* "/var/guix/profiles") (mkdir-p* "/var/guix/profiles")
(mkdir-p* "/var/guix/gcroots") (mkdir-p* "/var/guix/gcroots")
(symlink* "/var/guix/profiles" (symlink* "/var/guix/profiles"

170
guix/scripts/pack.scm
View File

@ -103,6 +103,47 @@ found."
(package-transitive-propagated-inputs package))) (package-transitive-propagated-inputs package)))
(list guile-gcrypt guile-sqlite3))) (list guile-gcrypt guile-sqlite3)))
(define (store-database items)
"Return a directory containing a store database where all of ITEMS and their
dependencies are registered."
(define schema
(local-file (search-path %load-path
"guix/store/schema.sql")))
(define labels
(map (lambda (n)
(string-append "closure" (number->string n)))
(iota (length items))))
(define build
(with-extensions gcrypt-sqlite3&co
;; XXX: Adding (gnu build install) just to work around
;; <https://bugs.gnu.org/15602>: that way, (guix build store-copy) is
;; copied last and the 'store-info-XXX' macros are correctly expanded.
(with-imported-modules (source-module-closure
'((guix build store-copy)
(guix store database)
(gnu build install)))
#~(begin
(use-modules (guix store database)
(guix build store-copy)
(srfi srfi-1))
(define (read-closure closure)
(call-with-input-file closure read-reference-graph))
(let ((items (append-map read-closure '#$labels)))
(register-items items
#:state-directory #$output
#:deduplicate? #f
#:reset-timestamps? #f
#:registration-time %epoch
#:schema #$schema))))))
(computed-file "store-database" build
#:options `(#:references-graphs ,(zip labels items))))
(define* (self-contained-tarball name profile (define* (self-contained-tarball name profile
#:key target #:key target
deduplicate? deduplicate?
@ -117,10 +158,10 @@ 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 schema (define database
(and localstatedir? (and localstatedir?
(local-file (search-path %load-path (file-append (store-database (list profile))
"guix/store/schema.sql")))) "/db/db.sqlite")))
(define build (define build
(with-imported-modules `(((guix config) => ,(make-config.scm)) (with-imported-modules `(((guix config) => ,(make-config.scm))
@ -181,9 +222,7 @@ added to the pack."
(populate-single-profile-directory %root (populate-single-profile-directory %root
#:profile #$profile #:profile #$profile
#:closure "profile" #:closure "profile"
#:deduplicate? #f #:database #+database)
#:register? #$localstatedir?
#:schema #$schema)
;; Create SYMLINKS. ;; Create SYMLINKS.
(for-each (cut evaluate-populate-directive <> %root) (for-each (cut evaluate-populate-directive <> %root)
@ -240,7 +279,6 @@ added to the pack."
(define* (squashfs-image name profile (define* (squashfs-image name profile
#:key target #:key target
deduplicate?
(compressor (first %compressors)) (compressor (first %compressors))
localstatedir? localstatedir?
(symlinks '()) (symlinks '())
@ -252,74 +290,70 @@ points for virtual file systems (like procfs), and optional symlinks.
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 build (define build
(with-imported-modules `(((guix config) => ,(make-config.scm)) (with-imported-modules (source-module-closure
,@(source-module-closure '((guix build utils)
'((guix build utils) (guix build store-copy))
(guix build store-copy) #:select? not-config?)
(gnu build install)) #~(begin
#:select? not-config?)) (use-modules (guix build utils)
(with-extensions gcrypt-sqlite3&co (guix build store-copy)
#~(begin (srfi srfi-1)
(use-modules (guix build utils) (srfi srfi-26)
(gnu build install) (ice-9 match))
(guix build store-copy)
(srfi srfi-1)
(srfi srfi-26)
(ice-9 match))
(setenv "PATH" (string-append #$archiver "/bin")) (setenv "PATH" (string-append #$archiver "/bin"))
;; We need an empty file in order to have a valid file argument when ;; We need an empty file in order to have a valid file argument when
;; we reparent the root file system. Read on for why that's ;; we reparent the root file system. Read on for why that's
;; necessary. ;; necessary.
(with-output-to-file ".empty" (lambda () (display ""))) (with-output-to-file ".empty" (lambda () (display "")))
;; Create the squashfs image in several steps. ;; Create the squashfs image in several steps.
;; Add all store items. Unfortunately mksquashfs throws away all ;; Add all store items. Unfortunately mksquashfs throws away all
;; ancestor directories and only keeps the basename. We fix this ;; ancestor directories and only keeps the basename. We fix this
;; in the following invocations of mksquashfs. ;; in the following invocations of mksquashfs.
(apply invoke "mksquashfs" (apply invoke "mksquashfs"
`(,@(map store-info-item `(,@(map store-info-item
(call-with-input-file "profile" (call-with-input-file "profile"
read-reference-graph)) read-reference-graph))
,#$output ,#$output
;; Do not perform duplicate checking because we ;; Do not perform duplicate checking because we
;; don't have any dupes. ;; don't have any dupes.
"-no-duplicates" "-no-duplicates"
"-comp" "-comp"
,#+(compressor-name compressor))) ,#+(compressor-name compressor)))
;; Here we reparent the store items. For each sub-directory of ;; Here we reparent the store items. For each sub-directory of
;; the store prefix we need one invocation of "mksquashfs". ;; the store prefix we need one invocation of "mksquashfs".
(for-each (lambda (dir) (for-each (lambda (dir)
(apply invoke "mksquashfs" (apply invoke "mksquashfs"
`(".empty" `(".empty"
,#$output ,#$output
"-root-becomes" ,dir))) "-root-becomes" ,dir)))
(reverse (string-tokenize (%store-directory) (reverse (string-tokenize (%store-directory)
(char-set-complement (char-set #\/))))) (char-set-complement (char-set #\/)))))
;; Add symlinks and mount points. ;; Add symlinks and mount points.
(apply invoke "mksquashfs" (apply invoke "mksquashfs"
`(".empty" `(".empty"
,#$output ,#$output
;; Create SYMLINKS via pseudo file definitions. ;; Create SYMLINKS via pseudo file definitions.
,@(append-map ,@(append-map
(match-lambda (match-lambda
((source '-> target) ((source '-> target)
(list "-p" (list "-p"
(string-join (string-join
;; name s mode uid gid symlink ;; name s mode uid gid symlink
(list source (list source
"s" "777" "0" "0" "s" "777" "0" "0"
(string-append #$profile "/" target)))))) (string-append #$profile "/" target))))))
'#$symlinks) '#$symlinks)
;; Create empty mount points. ;; Create empty mount points.
"-p" "/proc d 555 0 0" "-p" "/proc d 555 0 0"
"-p" "/sys d 555 0 0" "-p" "/sys d 555 0 0"
"-p" "/dev d 555 0 0")))))) "-p" "/dev d 555 0 0")))))
(gexp->derivation (string-append name (gexp->derivation (string-append name
(compressor-extension compressor) (compressor-extension compressor)