From patchwork Thu Jun 24 04:40:46 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Maxim Cournoyer X-Patchwork-Id: 30661 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 81F5127BC83; Thu, 24 Jun 2021 05:42:25 +0100 (BST) X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-2.8 required=5.0 tests=BAYES_00,DKIM_ADSP_CUSTOM_MED, DKIM_SIGNED,FREEMAIL_FROM,MAILING_LIST_MULTI,SPF_HELO_PASS, T_DKIM_INVALID autolearn=unavailable autolearn_force=no version=3.4.2 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id 15E1827BC78 for ; Thu, 24 Jun 2021 05:42:25 +0100 (BST) Received: from localhost ([::1]:49266 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1lwHC4-00065o-3f for patchwork@mira.cbaines.net; Thu, 24 Jun 2021 00:42:24 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:56970) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1lwHBj-0005xl-FF for guix-patches@gnu.org; Thu, 24 Jun 2021 00:42:03 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:58869) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1lwHBj-0002xN-7k for guix-patches@gnu.org; Thu, 24 Jun 2021 00:42:03 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1lwHBj-0002Qv-6K for guix-patches@gnu.org; Thu, 24 Jun 2021 00:42:03 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#49149] [PATCH v2 4/7] pack: Improve naming of the packs store file names. Resent-From: Maxim Cournoyer Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Thu, 24 Jun 2021 04:42:03 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 49149 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 49149@debbugs.gnu.org Cc: Maxim Cournoyer Received: via spool by 49149-submit@debbugs.gnu.org id=B49149.16245096859254 (code B ref 49149); Thu, 24 Jun 2021 04:42:03 +0000 Received: (at 49149) by debbugs.gnu.org; 24 Jun 2021 04:41:25 +0000 Received: from localhost ([127.0.0.1]:42172 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1lwHB6-0002P6-KN for submit@debbugs.gnu.org; Thu, 24 Jun 2021 00:41:24 -0400 Received: from mail-qv1-f49.google.com ([209.85.219.49]:46865) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1lwHB1-0002O0-Jc for 49149@debbugs.gnu.org; Thu, 24 Jun 2021 00:41:20 -0400 Received: by mail-qv1-f49.google.com with SMTP id u2so2642690qvp.13 for <49149@debbugs.gnu.org>; Wed, 23 Jun 2021 21:41:19 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20161025; h=from:to:cc:subject:date:message-id:in-reply-to:references :mime-version:content-transfer-encoding; bh=kE7TyvdDvkatZ9Rb0jmWVOLl69bHGgulZpTCfUj3VEk=; b=a+Fo45O/NqkS0dfS7FawrG8up4eVV/R4/+d80kV35LolIvrs+WmbKelkkfpkN2vKm5 GRu+qINk47N3PwNP1qcm3CrWQquw8BhPDsRc+rQoMrpGIHb88efgwI+aYadcgmWi//zm oqKsKXpC0c3bdQM7pYcqIxsym9Uo0cOpZ9nwau1HCipi5R8CYZjbzPOMOtSD9BZOvTPc OSDz73MJPu2s9rH7HoOtdzmCftfbpTprxL+TUtgaDXm/E/lukAVMAscxPj8VP0Nj8w/X FyY8WRB9KbTBBFgDtjRzHMNZP6TFdU4QYqLYNEvwVm1cq0fbxHbbEyGU9LPuZUHRYoxj zloQ== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20161025; h=x-gm-message-state:from:to:cc:subject:date:message-id:in-reply-to :references:mime-version:content-transfer-encoding; bh=kE7TyvdDvkatZ9Rb0jmWVOLl69bHGgulZpTCfUj3VEk=; b=dp3tQV5/9d1uzJVQC6Dvo6sdUTCWmGRjA/kQxSATrnvS0wbHt61ZPMGlB1cpBPoqsw NW8FIcZUH3YV536wwipkLjPcuKKky7bgqyRA2BonuRyDks3qKV/Hhh3BbR2XOWWoy9V1 pFjKGBdAv7hhgqlePukSlKq5iYQ3jAiVv4Be2a6085DQVCcqetCazGCAzN0CS5meUikk lYsBbj9YS0+dhZWFlDjWw8irqrJNpD1F25wiV2ROU9ZnJD+qEJOyYS5PpYdGQ02XoJqM DISWcianyOsPBzxtwznp7u11Lsbm+a2d7H9JEzzOFyfGZo7O0y/lkRt3NzRQj8847oGp dZzA== X-Gm-Message-State: AOAM533AhQLKoQdjCWTa/r1Ab+rFILoCptdWfUpj0T34ZX4Ts7ARDkr/ mVQi/hXncgQrInJaqskQETFrZpdYZ7N3tw== X-Google-Smtp-Source: ABdhPJy6kxFYDEYjxL3zkHtFPRVBBfBqtuWNSEMgsV8X5FGQqrjWjCIUu/rzXlisHzPLaQrn3eIIzw== X-Received: by 2002:ad4:55eb:: with SMTP id bu11mr3620611qvb.2.1624509674035; Wed, 23 Jun 2021 21:41:14 -0700 (PDT) Received: from localhost.localdomain ([207.35.95.2]) by smtp.gmail.com with ESMTPSA id q199sm1603880qka.112.2021.06.23.21.41.13 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Wed, 23 Jun 2021 21:41:13 -0700 (PDT) From: Maxim Cournoyer Date: Thu, 24 Jun 2021 00:40:46 -0400 Message-Id: <20210624044049.17906-4-maxim.cournoyer@gmail.com> X-Mailer: git-send-email 2.32.0 In-Reply-To: <20210624044049.17906-1-maxim.cournoyer@gmail.com> References: <20210624044049.17906-1-maxim.cournoyer@gmail.com> MIME-Version: 1.0 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list 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 Instead of just naming them by their pack type, add information from the package(s) they contain to make it easier to differentiate them. * guix/scripts/pack.scm (define-with-source): New macro. (manifest->friendly-name): Extract procedure from ... (docker-image): ... here, now defined via the above macro. Adjust REPOSITORY argument value accordingly. (guix-pack): Derive NAME using MANIFEST->FRIENDLY-NAME. --- guix/scripts/pack.scm | 49 +++++++++++++++++++++++++++---------------- 1 file changed, 31 insertions(+), 18 deletions(-) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 7ea97a4b7a..ad432f2b63 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -172,6 +172,28 @@ dependencies are registered." (computed-file "store-database" build #:options `(#:references-graphs ,(zip labels items)))) +(define-syntax-rule (define-with-source (variable args ...) body body* ...) + "Bind VARIABLE to a procedure accepting ARGS defined as BODY, also setting +its source property." + (begin + (define (variable args ...) + body) + (eval-when (load eval) + (set-procedure-property! variable 'source + '(define (variable args ...) body body* ...))))) + +(define-with-source (manifest->friendly-name manifest) + "Return a friendly name computed from the entries in MANIFEST, a + object." + (let loop ((names (map manifest-entry-name + (manifest-entries manifest)))) + (define str (string-join names "-")) + (if (< (string-length str) 40) + str + (match names + ((_) str) + ((names ... _) (loop names)))))) + ;;; ;;; Tarball format. @@ -540,7 +562,7 @@ the image." (file-append (store-database (list profile)) "/db/db.sqlite"))) - (define defmod 'define-module) ;trick Geiser + (define defmod 'define-module) ;trick Geiser (define build ;; Guile-JSON and Guile-Gcrypt are required by (guix docker). @@ -558,6 +580,8 @@ the image." (srfi srfi-1) (srfi srfi-19) (ice-9 match)) + #$(procedure-source manifest->friendly-name) + (define environment (map (match-lambda ((spec . value) @@ -581,19 +605,6 @@ the image." `((directory "/tmp" ,(getuid) ,(getgid) #o1777) ,@(append-map symlink->directives '#$symlinks))) - (define tag - ;; Compute a meaningful "repository" name, which will show up in - ;; the output of "docker images". - (let ((manifest (profile-manifest #$profile))) - (let loop ((names (map manifest-entry-name - (manifest-entries manifest)))) - (define str (string-join names "-")) - (if (< (string-length str) 40) - str - (match names - ((_) str) - ((names ... _) (loop names))))))) ;drop one entry - (setenv "PATH" #+(file-append archiver "/bin")) (build-docker-image #$output @@ -601,7 +612,8 @@ the image." (call-with-input-file "profile" read-reference-graph)) #$profile - #:repository tag + #:repository (manifest->friendly-name + (profile-manifest #$profile)) #:database #+database #:system (or #$target %host-type) #:environment environment @@ -1209,8 +1221,6 @@ Create a bundle of PACKAGE.\n")) manifest) manifest))) (pack-format (assoc-ref opts 'format)) - (name (string-append (symbol->string pack-format) - "-pack")) (target (assoc-ref opts 'target)) (bootstrap? (assoc-ref opts 'bootstrap?)) (compressor (if bootstrap? @@ -1244,7 +1254,10 @@ Create a bundle of PACKAGE.\n")) (hooks (if bootstrap? '() %default-profile-hooks)) - (locales? (not bootstrap?))))) + (locales? (not bootstrap?)))) + (name (string-append (manifest->friendly-name manifest) + "-" (symbol->string pack-format) + "-pack"))) (define (lookup-package package) (manifest-lookup manifest (manifest-pattern (name package))))