From patchwork Wed Mar 13 10:47:47 2019 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: 1415 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 09AB316CED; Wed, 13 Mar 2019 11:05:09 +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=-1.9 required=5.0 tests=BAYES_00 autolearn=unavailable autolearn_force=no version=3.4.0 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTP id 6E77916CBB for ; Wed, 13 Mar 2019 11:05:08 +0000 (GMT) Received: from localhost ([127.0.0.1]:42300 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1h41h6-0006sm-1k for patchwork@mira.cbaines.net; Wed, 13 Mar 2019 07:05:08 -0400 Received: from eggs.gnu.org ([209.51.188.92]:42807) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1h41gu-0006cY-3a for guix-patches@gnu.org; Wed, 13 Mar 2019 07:04:57 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1h41Qa-0008MK-49 for guix-patches@gnu.org; Wed, 13 Mar 2019 06:48:07 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:55779) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1h41QZ-0008Lm-HE for guix-patches@gnu.org; Wed, 13 Mar 2019 06:48:03 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1h41QZ-0002OT-EV for guix-patches@gnu.org; Wed, 13 Mar 2019 06:48:03 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#34838] [PATCH 2/6] packages: Add 'package-input-rewriting/spec'. Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Wed, 13 Mar 2019 10:48:03 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 34838 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 34838@debbugs.gnu.org Received: via spool by 34838-submit@debbugs.gnu.org id=B34838.15524740829188 (code B ref 34838); Wed, 13 Mar 2019 10:48:03 +0000 Received: (at 34838) by debbugs.gnu.org; 13 Mar 2019 10:48:02 +0000 Received: from localhost ([127.0.0.1]:41088 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1h41QX-0002Ns-JM for submit@debbugs.gnu.org; Wed, 13 Mar 2019 06:48:02 -0400 Received: from hera.aquilenet.fr ([185.233.100.1]:38382) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1h41QV-0002NL-2M for 34838@debbugs.gnu.org; Wed, 13 Mar 2019 06:47:59 -0400 Received: from localhost (localhost [127.0.0.1]) by hera.aquilenet.fr (Postfix) with ESMTP id 8D681D628; Wed, 13 Mar 2019 11:47:57 +0100 (CET) X-Virus-Scanned: Debian amavisd-new at aquilenet.fr Received: from hera.aquilenet.fr ([127.0.0.1]) by localhost (hera.aquilenet.fr [127.0.0.1]) (amavisd-new, port 10024) with ESMTP id JRGTHzxghOnu; Wed, 13 Mar 2019 11:47:56 +0100 (CET) Received: from gnu.org (unknown [IPv6:2a01:e0a:1d:7270:af76:b9b:ca24:c465]) by hera.aquilenet.fr (Postfix) with ESMTPSA id 4DF75D624; Wed, 13 Mar 2019 11:47:56 +0100 (CET) From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Wed, 13 Mar 2019 11:47:47 +0100 Message-Id: <20190313104751.20758-2-ludo@gnu.org> X-Mailer: git-send-email 2.21.0 In-Reply-To: <20190313104751.20758-1-ludo@gnu.org> References: <20190313104751.20758-1-ludo@gnu.org> MIME-Version: 1.0 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: 209.51.188.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/packages.scm (package-input-rewriting/spec): New procedure. * tests/packages.scm ("package-input-rewriting/spec") ("package-input-rewriting/spec, partial match"): New tests. * doc/guix.texi (Defining Packages): Document it. --- doc/guix.texi | 23 +++++++++++++++++++++ guix/packages.scm | 38 ++++++++++++++++++++++++++++++++++ tests/packages.scm | 51 ++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 112 insertions(+) diff --git a/doc/guix.texi b/doc/guix.texi index 42885577be..b0b7ee5dd0 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -5155,6 +5155,29 @@ with @var{libressl}. Then we use it to define a @dfn{variant} of the This is exactly what the @option{--with-input} command-line option does (@pxref{Package Transformation Options, @option{--with-input}}). +The following variant of @code{package-input-rewriting} can match packages to +be replaced by name rather than by identity. + +@deffn {Scheme Procedure} package-input-rewriting/spec @var{replacements} +Return a procedure that, given a package, applies the given @var{replacements} to +all the package graph (excluding implicit inputs). @var{replacements} is a list of +spec/procedures pair; each spec is a package specification such as @code{"gcc"} or +@code{"guile@@2"}, and each procedure takes a matching package and returns a +replacement for that package. +@end deffn + +The example above could be rewritten this way: + +@example +(define libressl-instead-of-openssl + ;; Replace all the packages called "openssl" with LibreSSL. + (package-input-rewriting/spec `(("openssl" . ,(const libressl))))) +@end example + +The key difference here is that, this time, packages are matched by spec and +not by identity. In other words, any package in the graph that is called +@code{openssl} will be replaced. + A more generic procedure to rewrite a package dependency graph is @code{package-mapping}: it supports arbitrary changes to nodes in the graph. diff --git a/guix/packages.scm b/guix/packages.scm index f191327718..d20a2562c3 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -102,6 +102,7 @@ package-transitive-supported-systems package-mapping package-input-rewriting + package-input-rewriting/spec package-source-derivation package-derivation package-cross-derivation @@ -869,6 +870,43 @@ package and returns its new name after rewrite." (package-mapping rewrite (cut assq <> replacements))) +(define (package-input-rewriting/spec replacements) + "Return a procedure that, given a package, applies the given REPLACEMENTS to +all the package graph (excluding implicit inputs). REPLACEMENTS is a list of +spec/procedures pair; each spec is a package specification such as \"gcc\" or +\"guile@2\", and each procedure takes a matching package and returns a +replacement for that package." + (define table + (fold (lambda (replacement table) + (match replacement + ((spec . proc) + (let-values (((name version) + (package-name->name+version spec))) + (vhash-cons name (list version proc) table))))) + vlist-null + replacements)) + + (define (find-replacement package) + (vhash-fold* (lambda (item proc) + (or proc + (match item + ((#f proc) + proc) + ((version proc) + (and (version-prefix? version + (package-version package)) + proc))))) + #f + (package-name package) + table)) + + (define (rewrite package) + (match (find-replacement package) + (#f package) + (proc (proc package)))) + + (package-mapping rewrite find-replacement)) + (define-syntax-rule (package/inherit p overrides ...) "Like (package (inherit P) OVERRIDES ...), except that the same transformation is done to the package replacement, if any. P must be a bare diff --git a/tests/packages.scm b/tests/packages.scm index 4e4bffc48c..613b2f1221 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -981,6 +981,57 @@ ((("x" dep)) (eq? dep findutils))))))))) +(test-assert "package-input-rewriting/spec" + (let* ((dep (dummy-package "chbouib" + (native-inputs `(("x" ,grep))))) + (p0 (dummy-package "example" + (inputs `(("foo" ,coreutils) + ("bar" ,grep) + ("baz" ,dep))))) + (rewrite (package-input-rewriting/spec + `(("coreutils" . ,(const sed)) + ("grep" . ,(const findutils))))) + (p1 (rewrite p0)) + (p2 (rewrite p0))) + (and (not (eq? p1 p0)) + (eq? p1 p2) ;memoization + (string=? "example" (package-name p1)) + (match (package-inputs p1) + ((("foo" dep1) ("bar" dep2) ("baz" dep3)) + (and (string=? (package-full-name dep1) + (package-full-name sed)) + (string=? (package-full-name dep2) + (package-full-name findutils)) + (string=? (package-name dep3) "chbouib") + (eq? dep3 (rewrite dep)) ;memoization + (match (package-native-inputs dep3) + ((("x" dep)) + (string=? (package-full-name dep) + (package-full-name findutils)))))))))) + +(test-assert "package-input-rewriting/spec, partial match" + (let* ((dep (dummy-package "chbouib" + (version "1") + (native-inputs `(("x" ,grep))))) + (p0 (dummy-package "example" + (inputs `(("foo" ,coreutils) + ("bar" ,dep))))) + (rewrite (package-input-rewriting/spec + `(("chbouib@123" . ,(const sed)) ;not matched + ("grep" . ,(const findutils))))) + (p1 (rewrite p0))) + (and (not (eq? p1 p0)) + (string=? "example" (package-name p1)) + (match (package-inputs p1) + ((("foo" dep1) ("bar" dep2)) + (and (string=? (package-full-name dep1) + (package-full-name coreutils)) + (eq? dep2 (rewrite dep)) ;memoization + (match (package-native-inputs dep2) + ((("x" dep)) + (string=? (package-full-name dep) + (package-full-name findutils)))))))))) + (test-equal "package-patched-vulnerabilities" '(("CVE-2015-1234") ("CVE-2016-1234" "CVE-2018-4567")