From patchwork Sun Apr 17 21:04:42 2022 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: 38637 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 824A027BBE9; Sun, 17 Apr 2022 22:06:24 +0100 (BST) X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-2.7 required=5.0 tests=BAYES_00,DKIM_INVALID, DKIM_SIGNED,MAILING_LIST_MULTI,SPF_HELO_PASS autolearn=unavailable autolearn_force=no version=3.4.6 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id F34A727BBEA for ; Sun, 17 Apr 2022 22:06:23 +0100 (BST) Received: from localhost ([::1]:39188 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1ngC6B-0006vG-2u for patchwork@mira.cbaines.net; Sun, 17 Apr 2022 17:06:23 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:32870) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1ngC5r-0006Fl-J1 for guix-patches@gnu.org; Sun, 17 Apr 2022 17:06:03 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:43543) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1ngC5q-0000Xj-K7 for guix-patches@gnu.org; Sun, 17 Apr 2022 17:06:03 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1ngC5q-00025v-Ef for guix-patches@gnu.org; Sun, 17 Apr 2022 17:06:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#54997] [PATCH 01/12] gexp: Add 'references-file'. References: <20220417210107.27263-1-ludo@gnu.org> In-Reply-To: <20220417210107.27263-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, 17 Apr 2022 21:06:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 54997 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 54997@debbugs.gnu.org Cc: Ludovic =?utf-8?q?Court=C3=A8s?= Received: via spool by 54997-submit@debbugs.gnu.org id=B54997.16502295507927 (code B ref 54997); Sun, 17 Apr 2022 21:06:02 +0000 Received: (at 54997) by debbugs.gnu.org; 17 Apr 2022 21:05:50 +0000 Received: from localhost ([127.0.0.1]:37409 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1ngC5c-00023K-0C for submit@debbugs.gnu.org; Sun, 17 Apr 2022 17:05:49 -0400 Received: from eggs.gnu.org ([209.51.188.92]:39436) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1ngC5Y-00022O-H3 for 54997@debbugs.gnu.org; Sun, 17 Apr 2022 17:05:45 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:58426) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1ngC5R-0000Uy-Cc; Sun, 17 Apr 2022 17:05:37 -0400 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=gnu.org; s=fencepost-gnu-org; h=MIME-Version:Date:Subject:To:From:in-reply-to: references; bh=wbpXxlHeJZdI+lfL7OeHJxEDNXMLl91/Te59oUDq9Vk=; b=gmXw2AhRnWgnYn R+gRkp4FYtd3li8SFrdEf+NbR7XlLXX2UuqvCcvVPXNN4nBPdIirPn17Tz8kEX1Rrfbh8xf9HuRns L/sXu4m/OZUzInfJlgC3SvOJi6yrmuD7t04TR318ZSlgf1KZiuLr5k4XsGx3FbwICvAW2xgUEou3R KHQsUx6WCi9sA/sB7uZ+QkHyKe+h9Yb2Leoh/NftlPWURHzY7T2LO8bbqUv1viZXFQ5gceu9wowCg 0ihMxAL7ULwOMY97zjyypSdBE/zDAeOsGygk/Pxx3+d5gO2O6UZyKTs6SjEP4v8SD2aYRfMA+qvLW K9wyek48YpQricuOjFBg==; Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=38870 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1ngC4u-000268-9q; Sun, 17 Apr 2022 17:05:24 -0400 From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Sun, 17 Apr 2022 23:04:42 +0200 Message-Id: <20220417210453.27884-1-ludo@gnu.org> X-Mailer: git-send-email 2.35.1 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 * gnu/services/base.scm (references-file): Remove. * guix/gexp.scm (references-file): New procedure. * tests/gexp.scm ("references-file"): New test. --- gnu/services/base.scm | 22 ---------------------- guix/gexp.scm | 43 +++++++++++++++++++++++++++++++++++++++++++ tests/gexp.scm | 18 ++++++++++++++++++ 3 files changed, 61 insertions(+), 22 deletions(-) diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 5d7c69a9cd..182badd97f 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -219,8 +219,6 @@ (define-module (gnu services base) pam-limits-service-type pam-limits-service - references-file - %base-services)) ;;; Commentary: @@ -1768,26 +1766,6 @@ (define (guix-activation config) (substitute-key-authorization authorized-keys guix) #~#f)))) -(define* (references-file item #:optional (name "references")) - "Return a file that contains the list of references of ITEM." - (if (struct? item) ;lowerable object - (computed-file name - (with-extensions (list guile-gcrypt) ;for store-copy - (with-imported-modules (source-module-closure - '((guix build store-copy))) - #~(begin - (use-modules (guix build store-copy)) - - (call-with-output-file #$output - (lambda (port) - (write (map store-info-item - (call-with-input-file "graph" - read-reference-graph)) - port)))))) - #:options `(#:local-build? #f - #:references-graphs (("graph" ,item)))) - (plain-file name "()"))) - (define guix-service-type (service-type (name 'guix) diff --git a/guix/gexp.scm b/guix/gexp.scm index 9fdb7a30be..9ef7622062 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -118,6 +118,7 @@ (define-module (guix gexp) mixed-text-file file-union directory-union + references-file imported-files imported-modules @@ -2173,6 +2174,48 @@ (define log-port #:resolve-collision (ungexp resolve-collision))))))))) +(define* (references-file item #:optional (name "references") + #:key guile) + "Return a file that contains the list of direct and indirect references (the +closure) of ITEM." + (if (struct? item) ;lowerable object + (computed-file name + (gexp (begin + (use-modules (ice-9 rdelim) + (ice-9 match)) + + (define (drop-lines port n) + ;; Drop N lines read from PORT. + (let loop ((n n)) + (unless (zero? n) + (read-line port) + (loop (- n 1))))) + + (define (read-graph port) + ;; Return the list of references read from + ;; PORT. This is a stripped-down version of + ;; 'read-reference-graph'. + (let loop ((items '())) + (match (read-line port) + ((? eof-object?) + items) + ((? string? item) + (let ((deriver (read-line port)) + (count + (string->number (read-line port)))) + (drop-lines port count) + (loop (cons item items))))))) + + (call-with-output-file (ungexp output) + (lambda (port) + (write (call-with-input-file "graph" + read-graph) + port))))) + #:guile guile + #:options `(#:local-build? #t + #:references-graphs (("graph" ,item)))) + (plain-file name "()"))) + ;;; ;;; Syntactic sugar. diff --git a/tests/gexp.scm b/tests/gexp.scm index c80ca13fab..35bd99e6d4 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -1606,6 +1606,24 @@ (define (contents=? file str) (not (member (derivation-file-name native) refs)) (member (derivation-file-name cross) refs)))))) +(test-assertm "references-file" + (let* ((exp #~(symlink #$%bootstrap-guile #$output)) + (computed (computed-file "computed" exp + #:guile %bootstrap-guile)) + (refs (references-file computed "refs" + #:guile %bootstrap-guile))) + (mlet* %store-monad ((drv0 (lower-object %bootstrap-guile)) + (drv1 (lower-object computed)) + (drv2 (lower-object refs))) + (mbegin %store-monad + (built-derivations (list drv2)) + (mlet %store-monad ((refs ((store-lift requisites) + (list (derivation->output-path drv1))))) + (return (lset= string=? + (call-with-input-file (derivation->output-path drv2) + read) + refs))))))) + (test-assert "lower-object & gexp-input-error?" (guard (c ((gexp-input-error? c) (gexp-error-invalid-input c)))