From patchwork Sun Nov 4 22:10:29 2018 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: =?utf-8?q?Ludovic_Court=C3=A8s?= X-Patchwork-Id: 113 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id 189BC167B2; Sun, 4 Nov 2018 22:21:54 +0000 (GMT) X-Spam-Checker-Version: SpamAssassin 3.4.0 (2014-02-07) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-6.9 required=5.0 tests=BAYES_00,RCVD_IN_DNSWL_HI, URIBL_BLOCKED autolearn=ham autolearn_force=no version=3.4.0 Received: from lists.gnu.org (lists.gnu.org [IPv6:2001:4830:134:3::11]) by mira.cbaines.net (Postfix) with ESMTPS id 8E03B167B0 for ; Sun, 4 Nov 2018 22:21:53 +0000 (GMT) Received: from localhost ([::1]:60384 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1gJQmG-0000oB-Rh for patchwork@mira.cbaines.net; Sun, 04 Nov 2018 17:21:52 -0500 Received: from eggs.gnu.org ([2001:4830:134:3::10]:35862) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1gJQl4-0007qJ-24 for guix-patches@gnu.org; Sun, 04 Nov 2018 17:20:41 -0500 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1gJQcl-0000w3-8g for guix-patches@gnu.org; Sun, 04 Nov 2018 17:12:05 -0500 Received: from debbugs.gnu.org ([208.118.235.43]:58337) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1gJQck-0000va-TG for guix-patches@gnu.org; Sun, 04 Nov 2018 17:12:03 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1gJQck-0001gM-Nd for guix-patches@gnu.org; Sun, 04 Nov 2018 17:12:02 -0500 X-Loop: help-debbugs@gnu.org Subject: [bug#33259] [PATCH 1/8] pack: Move store database creation to a separate derivation. References: <20181104220130.4551-1-ludo@gnu.org> In-Reply-To: <20181104220130.4551-1-ludo@gnu.org> Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Sun, 04 Nov 2018 22:12:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 33259 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 33259@debbugs.gnu.org Received: via spool by 33259-submit@debbugs.gnu.org id=B33259.15413694736346 (code B ref 33259); Sun, 04 Nov 2018 22:12:02 +0000 Received: (at 33259) by debbugs.gnu.org; 4 Nov 2018 22:11:13 +0000 Received: from localhost ([127.0.0.1]:34349 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1gJQbw-0001e1-6a for submit@debbugs.gnu.org; Sun, 04 Nov 2018 17:11:12 -0500 Received: from eggs.gnu.org ([208.118.235.92]:53268) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1gJQbt-0001dH-Jk for 33259@debbugs.gnu.org; Sun, 04 Nov 2018 17:11:10 -0500 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1gJQbm-0006SZ-Lt for 33259@debbugs.gnu.org; Sun, 04 Nov 2018 17:11:04 -0500 Received: from fencepost.gnu.org ([2001:4830:134:3::e]:40143) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1gJQbj-0006IK-HP; Sun, 04 Nov 2018 17:10:59 -0500 Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=33966 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:DHE_RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1gJQbj-0004TQ-6W; Sun, 04 Nov 2018 17:10:59 -0500 From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Sun, 4 Nov 2018 23:10:29 +0100 Message-Id: <20181104221036.4776-1-ludo@gnu.org> X-Mailer: git-send-email 2.19.1 MIME-Version: 1.0 X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 208.118.235.43 X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches * 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. --- gnu/build/install.scm | 17 ++--- guix/scripts/pack.scm | 170 +++++++++++++++++++++++++----------------- 2 files changed, 109 insertions(+), 78 deletions(-) diff --git a/gnu/build/install.scm b/gnu/build/install.scm index 98c547f2e4..9f9a6aba0f 100644 --- a/gnu/build/install.scm +++ b/gnu/build/install.scm @@ -161,14 +161,13 @@ deduplicates files common to CLOSURE and the rest of PREFIX." (define* (populate-single-profile-directory directory #:key profile closure (profile-name "guix-profile") - deduplicate? - register? schema) + database) "Populate DIRECTORY with a store containing PROFILE, whose closure is given in the file called CLOSURE (as generated by #:references-graphs.) DIRECTORY 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 -the store. + +When DATABASE is true, copy it to DIRECTORY/var/guix/db and create +DIRECTORY/var/guix/gcroots and friends. PROFILE-NAME is the name of the profile being created under /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-store (list closure) directory) - (when register? - (register-closure (canonicalize-path directory) closure - #:deduplicate? deduplicate? - #:schema schema) - + (when database + (install-file database (scope "/var/guix/db/")) + (chmod (scope "/var/guix/db/db.sqlite") #o644) (mkdir-p* "/var/guix/profiles") (mkdir-p* "/var/guix/gcroots") (symlink* "/var/guix/profiles" diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 83bfa4ce00..faeea68426 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -103,6 +103,47 @@ found." (package-transitive-propagated-inputs package))) (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 + ;; : 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 #:key target deduplicate? @@ -117,10 +158,10 @@ with a properly initialized store database. SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be added to the pack." - (define schema + (define database (and localstatedir? - (local-file (search-path %load-path - "guix/store/schema.sql")))) + (file-append (store-database (list profile)) + "/db/db.sqlite"))) (define build (with-imported-modules `(((guix config) => ,(make-config.scm)) @@ -181,9 +222,7 @@ added to the pack." (populate-single-profile-directory %root #:profile #$profile #:closure "profile" - #:deduplicate? #f - #:register? #$localstatedir? - #:schema #$schema) + #:database #+database) ;; Create SYMLINKS. (for-each (cut evaluate-populate-directive <> %root) @@ -240,7 +279,6 @@ added to the pack." (define* (squashfs-image name profile #:key target - deduplicate? (compressor (first %compressors)) localstatedir? (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 added to the pack." (define build - (with-imported-modules `(((guix config) => ,(make-config.scm)) - ,@(source-module-closure - '((guix build utils) - (guix build store-copy) - (gnu build install)) - #:select? not-config?)) - (with-extensions gcrypt-sqlite3&co - #~(begin - (use-modules (guix build utils) - (gnu build install) - (guix build store-copy) - (srfi srfi-1) - (srfi srfi-26) - (ice-9 match)) + (with-imported-modules (source-module-closure + '((guix build utils) + (guix build store-copy)) + #:select? not-config?) + #~(begin + (use-modules (guix build utils) + (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 reparent the root file system. Read on for why that's - ;; necessary. - (with-output-to-file ".empty" (lambda () (display ""))) + ;; 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 + ;; necessary. + (with-output-to-file ".empty" (lambda () (display ""))) - ;; Create the squashfs image in several steps. - ;; Add all store items. Unfortunately mksquashfs throws away all - ;; ancestor directories and only keeps the basename. We fix this - ;; in the following invocations of mksquashfs. - (apply invoke "mksquashfs" - `(,@(map store-info-item - (call-with-input-file "profile" - read-reference-graph)) - ,#$output + ;; Create the squashfs image in several steps. + ;; Add all store items. Unfortunately mksquashfs throws away all + ;; ancestor directories and only keeps the basename. We fix this + ;; in the following invocations of mksquashfs. + (apply invoke "mksquashfs" + `(,@(map store-info-item + (call-with-input-file "profile" + read-reference-graph)) + ,#$output - ;; Do not perform duplicate checking because we - ;; don't have any dupes. - "-no-duplicates" - "-comp" - ,#+(compressor-name compressor))) + ;; Do not perform duplicate checking because we + ;; don't have any dupes. + "-no-duplicates" + "-comp" + ,#+(compressor-name compressor))) - ;; Here we reparent the store items. For each sub-directory of - ;; the store prefix we need one invocation of "mksquashfs". - (for-each (lambda (dir) - (apply invoke "mksquashfs" - `(".empty" - ,#$output - "-root-becomes" ,dir))) - (reverse (string-tokenize (%store-directory) - (char-set-complement (char-set #\/))))) + ;; Here we reparent the store items. For each sub-directory of + ;; the store prefix we need one invocation of "mksquashfs". + (for-each (lambda (dir) + (apply invoke "mksquashfs" + `(".empty" + ,#$output + "-root-becomes" ,dir))) + (reverse (string-tokenize (%store-directory) + (char-set-complement (char-set #\/))))) - ;; Add symlinks and mount points. - (apply invoke "mksquashfs" - `(".empty" - ,#$output - ;; Create SYMLINKS via pseudo file definitions. - ,@(append-map - (match-lambda - ((source '-> target) - (list "-p" - (string-join - ;; name s mode uid gid symlink - (list source - "s" "777" "0" "0" - (string-append #$profile "/" target)))))) - '#$symlinks) + ;; Add symlinks and mount points. + (apply invoke "mksquashfs" + `(".empty" + ,#$output + ;; Create SYMLINKS via pseudo file definitions. + ,@(append-map + (match-lambda + ((source '-> target) + (list "-p" + (string-join + ;; name s mode uid gid symlink + (list source + "s" "777" "0" "0" + (string-append #$profile "/" target)))))) + '#$symlinks) - ;; Create empty mount points. - "-p" "/proc d 555 0 0" - "-p" "/sys d 555 0 0" - "-p" "/dev d 555 0 0")))))) + ;; Create empty mount points. + "-p" "/proc d 555 0 0" + "-p" "/sys d 555 0 0" + "-p" "/dev d 555 0 0"))))) (gexp->derivation (string-append name (compressor-extension compressor)