From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mp1 ([2001:41d0:2:4a6f::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by ms11 with LMTPS id YDSaHII8t14WCgAA0tVLHw (envelope-from ) for ; Sat, 09 May 2020 23:28:02 +0000 Received: from aspmx1.migadu.com ([2001:41d0:2:4a6f::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by mp1 with LMTPS id EGIsLY88t16JXAAAbx9fmQ (envelope-from ) for ; Sat, 09 May 2020 23:28:15 +0000 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by aspmx1.migadu.com (Postfix) with ESMTPS id 972939400EF for ; Sat, 9 May 2020 23:28:13 +0000 (UTC) Received: from localhost ([::1]:50142 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1jXYtC-0007Eu-CL for larch@yhetil.org; Sat, 09 May 2020 19:28:14 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:50734) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1jXYt1-00075O-89 for guix-patches@gnu.org; Sat, 09 May 2020 19:28:03 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:37043) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1jXYt0-00081g-VG for guix-patches@gnu.org; Sat, 09 May 2020 19:28:02 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1jXYt0-00055Y-S7 for guix-patches@gnu.org; Sat, 09 May 2020 19:28:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#41164] [PATCH 1/3] graph: reference/referrer node types work with graph traversal. References: <20200509230401.28364-1-ludo@gnu.org> In-Reply-To: <20200509230401.28364-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: Sat, 09 May 2020 23:28:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 41164 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 41164@debbugs.gnu.org Cc: Ludovic =?UTF-8?Q?Court=C3=A8s?= Received: via spool by 41164-submit@debbugs.gnu.org id=B41164.158906687519531 (code B ref 41164); Sat, 09 May 2020 23:28:02 +0000 Received: (at 41164) by debbugs.gnu.org; 9 May 2020 23:27:55 +0000 Received: from localhost ([127.0.0.1]:48586 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1jXYst-00054r-A2 for submit@debbugs.gnu.org; Sat, 09 May 2020 19:27:55 -0400 Received: from eggs.gnu.org ([209.51.188.92]:47702) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1jXYsr-00054P-39 for 41164@debbugs.gnu.org; Sat, 09 May 2020 19:27:53 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:34093) by eggs.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1jXYsk-0007Ag-DC; Sat, 09 May 2020 19:27:46 -0400 Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=40868 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:DHE_RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1jXYsi-00020y-RK; Sat, 09 May 2020 19:27:45 -0400 From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Date: Sun, 10 May 2020 01:27:37 +0200 Message-Id: <20200509232739.29016-1-ludo@gnu.org> X-Mailer: git-send-email 2.26.2 MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Spam-Score: -2.3 (--) X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-Spam-Score: -3.3 (---) X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+larch=yhetil.org@gnu.org Sender: "Guix-patches" X-Scanner: scn0 X-Spam-Score: 5.49 Authentication-Results: aspmx1.migadu.com; dkim=none; dmarc=none; spf=pass (aspmx1.migadu.com: domain of guix-patches-bounces@gnu.org designates 209.51.188.17 as permitted sender) smtp.mailfrom=guix-patches-bounces@gnu.org X-Scan-Result: default: False [5.49 / 13.00]; RCVD_VIA_SMTP_AUTH(0.00)[]; GENERIC_REPUTATION(0.00)[-0.53962207109651]; MX_INVALID(1.00)[cached]; TO_DN_SOME(0.00)[]; R_SPF_ALLOW(-0.20)[+ip4:209.51.188.0/24:c]; R_MISSING_CHARSET(2.50)[]; DWL_DNSWL_FAIL(0.00)[209.51.188.17:server fail]; IP_REPUTATION_HAM(0.00)[asn: 22989(0.09), country: US(-0.00), ip: 209.51.188.17(-0.54)]; BROKEN_CONTENT_TYPE(1.50)[]; RCPT_COUNT_TWO(0.00)[2]; MAILLIST(-0.20)[mailman]; FORGED_RECIPIENTS_MAILLIST(0.00)[]; RCVD_TLS_LAST(0.00)[]; R_DKIM_NA(0.00)[]; ASN(0.00)[asn:22989, ipnet:209.51.188.0/24, country:US]; MIME_TRACE(0.00)[0:+]; TAGGED_FROM(0.00)[larch=yhetil.org]; ARC_NA(0.00)[]; FROM_NEQ_ENVFROM(0.00)[ludo@gnu.org,guix-patches-bounces@gnu.org]; FROM_HAS_DN(0.00)[]; MIME_GOOD(-0.10)[text/plain]; DMARC_NA(0.00)[gnu.org]; HAS_LIST_UNSUB(-0.01)[]; DNSWL_BLOCKED(0.00)[209.51.188.17:from]; MID_CONTAINS_FROM(1.00)[]; RWL_MAILSPIKE_POSSIBLE(0.00)[209.51.188.17:from]; RCVD_COUNT_SEVEN(0.00)[9]; FORGED_SENDER_MAILLIST(0.00)[] X-TUID: gCzWJRDE9hzB The graph traversal procedures in (guix graph) assume that nodes can be compared with 'eq?', which was not the case for nodes of %REFERENCE-NODE-TYPE and %REFERRER-NODE-TYPE (strings). * guix/scripts/graph.scm (intern): New procedure. (ensure-store-items, references*) (%reference-node-type, non-derivation-referrers) (%referrer-node-type): Use it on all store items. * tests/graph.scm ("node-transitive-edges, references"): New test. --- guix/scripts/graph.scm | 23 ++++++++++++++++------- tests/graph.scm | 27 +++++++++++++++++++++++++++ 2 files changed, 43 insertions(+), 7 deletions(-) diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index fca1e3777c..d69dace14f 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -307,6 +307,14 @@ derivation graph"))))))) ;;; DAG of residual references (aka. run-time dependencies). ;;; +(define intern + (mlambda (str) + "Intern STR, a string denoting a store item." + ;; This is necessary for %REFERENCE-NODE-TYPE and %REFERRER-NODE-TYPE + ;; because their nodes are strings but the (guix graph) traversal + ;; procedures expect to be able to compare nodes with 'eq?'. + str)) + (define ensure-store-items ;; Return a list of store items as a monadic value based on the given ;; argument, which may be a store item or a package. @@ -316,10 +324,10 @@ derivation graph"))))))) (mlet %store-monad ((drv (package->derivation package))) (return (match (derivation->output-paths drv) (((_ . file-names) ...) - file-names))))) + (map intern file-names)))))) ((? store-path? item) (with-monad %store-monad - (return (list item)))) + (return (list (intern item))))) (x (raise (condition (&message (message "unsupported argument for \ @@ -333,18 +341,19 @@ substitutes." (guard (c ((store-protocol-error? c) (match (substitutable-path-info store (list item)) ((info) - (values (substitutable-references info) store)) + (values (map intern (substitutable-references info)) + store)) (() (leave (G_ "references for '~a' are not known~%") item))))) - (values (references store item) store)))) + (values (map intern (references store item)) store)))) (define %reference-node-type (node-type (name "references") (description "the DAG of run-time dependencies (store references)") (convert ensure-store-items) - (identifier (lift1 identity %store-monad)) + (identifier (lift1 intern %store-monad)) (label store-path-package-name) (edges references*))) @@ -353,14 +362,14 @@ substitutes." (lambda (item) "Return the referrers of ITEM, except '.drv' files." (mlet %store-monad ((items (referrers item))) - (return (remove derivation-path? items)))))) + (return (map intern (remove derivation-path? items))))))) (define %referrer-node-type (node-type (name "referrers") (description "the DAG of referrers in the store") (convert ensure-store-items) - (identifier (lift1 identity %store-monad)) + (identifier (lift1 intern %store-monad)) (label store-path-package-name) (edges non-derivation-referrers))) diff --git a/tests/graph.scm b/tests/graph.scm index 402847102f..983a6ed654 100644 --- a/tests/graph.scm +++ b/tests/graph.scm @@ -31,6 +31,7 @@ #:use-module (guix utils) #:use-module (gnu packages) #:use-module (gnu packages base) + #:use-module (gnu packages bootstrap) #:use-module (gnu packages guile) #:use-module (gnu packages libunistring) #:use-module (gnu packages bootstrap) @@ -358,6 +359,32 @@ edges." (return (lset= eq? (node-transitive-edges (list p2) edges) (list p1a p1b p0))))))) +(test-assert "node-transitive-edges, references" + (run-with-store %store + (mlet* %store-monad ((d0 (package->derivation %bootstrap-guile)) + (d1 (gexp->derivation "d1" + #~(begin + (mkdir #$output) + (symlink #$%bootstrap-guile + (string-append + #$output "/l"))))) + (d2 (gexp->derivation "d2" + #~(begin + (mkdir #$output) + (symlink #$d1 + (string-append + #$output "/l"))))) + (_ (built-derivations (list d2))) + (->node -> (node-type-convert %reference-node-type)) + (o2 (->node (derivation->output-path d2))) + (o1 (->node (derivation->output-path d1))) + (o0 (->node (derivation->output-path d0))) + (edges (node-edges %reference-node-type + (append o0 o1 o2))) + (reqs ((store-lift requisites) o2))) + (return (lset= string=? + (append o2 (node-transitive-edges o2 edges)) reqs))))) + (test-equal "node-reachable-count" '(3 3) (run-with-store %store -- 2.26.2