From patchwork Wed May 20 21:47:24 2020 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: 22235 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 EBBFC27BBE3; Wed, 20 May 2020 22:48:12 +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.9 required=5.0 tests=BAYES_00,MAILING_LIST_MULTI, RCVD_IN_MSPIKE_H4,RCVD_IN_MSPIKE_WL 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 ESMTP id 7A40627BBE1 for ; Wed, 20 May 2020 22:48:12 +0100 (BST) Received: from localhost ([::1]:37956 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1jbWZP-0003U9-TS for patchwork@mira.cbaines.net; Wed, 20 May 2020 17:48:11 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:51430) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1jbWZH-0003Ph-45 for guix-patches@gnu.org; Wed, 20 May 2020 17:48:03 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:43004) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1jbWZG-0003NU-PB for guix-patches@gnu.org; Wed, 20 May 2020 17:48:02 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1jbWZG-00063a-O1 for guix-patches@gnu.org; Wed, 20 May 2020 17:48:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#41425] [PATCH 4/5] channels: 'latest-channel-instances' guards against non-forward updates. Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Wed, 20 May 2020 21:48:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 41425 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 41425@debbugs.gnu.org Cc: Ludovic =?utf-8?q?Court=C3=A8s?= Received: via spool by 41425-submit@debbugs.gnu.org id=B41425.159001127123232 (code B ref 41425); Wed, 20 May 2020 21:48:02 +0000 Received: (at 41425) by debbugs.gnu.org; 20 May 2020 21:47:51 +0000 Received: from localhost ([127.0.0.1]:54544 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1jbWZ4-00062c-Si for submit@debbugs.gnu.org; Wed, 20 May 2020 17:47:51 -0400 Received: from eggs.gnu.org ([209.51.188.92]:43970) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1jbWZ0-00061r-UV for 41425@debbugs.gnu.org; Wed, 20 May 2020 17:47:47 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:59461) by eggs.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1jbWYv-0003Lz-Js; Wed, 20 May 2020 17:47:41 -0400 Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=56656 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:DHE_RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1jbWYu-0007cZ-3e; Wed, 20 May 2020 17:47:40 -0400 From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Wed, 20 May 2020 23:47:24 +0200 Message-Id: <20200520214725.2437-4-ludo@gnu.org> X-Mailer: git-send-email 2.26.2 In-Reply-To: <20200520214725.2437-1-ludo@gnu.org> References: <20200520214725.2437-1-ludo@gnu.org> 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 * guix/channels.scm (latest-channel-instance): Add #:starting-commit and pass it to 'update-cached-checkout'. Return the commit relation as a second value. (ensure-forward-channel-update): New procedure. (latest-channel-instances): Add #:current-channels and #:validate-pull. [current-commit]: New procedure. Pass #:starting-commit to 'latest-channel-instance'. When the returned relation is true, call VALIDATE-PULL. (latest-channel-derivation): Add #:current-channels and #:validate-pull. Pass them to 'latest-channel-instances*'. * tests/channels.scm ("latest-channel-instances #:validate-pull"): New test. --- guix/channels.scm | 89 ++++++++++++++++++++++++++++++++++++++++------ tests/channels.scm | 35 ++++++++++++++++++ 2 files changed, 114 insertions(+), 10 deletions(-) diff --git a/guix/channels.scm b/guix/channels.scm index 75b767a94c..70e2d7f07c 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -73,6 +73,7 @@ channel-instances->manifest %channel-profile-hooks channel-instances->derivation + ensure-forward-channel-update profile-channels @@ -212,15 +213,18 @@ result is unspecified." (loop rest))))) (define* (latest-channel-instance store channel - #:key (patches %patches)) - "Return the latest channel instance for CHANNEL." + #:key (patches %patches) + starting-commit) + "Return two values: the latest channel instance for CHANNEL, and its +relation to STARTING-COMMIT when provided." (define (dot-git? file stat) (and (string=? (basename file) ".git") (eq? 'directory (stat:type stat)))) (let-values (((checkout commit relation) (update-cached-checkout (channel-url channel) - #:ref (channel-reference channel)))) + #:ref (channel-reference channel) + #:starting-commit starting-commit))) (when (guix-channel? channel) ;; Apply the relevant subset of PATCHES directly in CHECKOUT. This is ;; safe to do because 'switch-to-ref' eventually does a hard reset. @@ -229,11 +233,51 @@ result is unspecified." (let* ((name (url+commit->name (channel-url channel) commit)) (checkout (add-to-store store name #t "sha256" checkout #:select? (negate dot-git?)))) - (channel-instance channel commit checkout)))) + (values (channel-instance channel commit checkout) + relation)))) -(define* (latest-channel-instances store channels) +(define (ensure-forward-channel-update channel start instance relation) + "Raise an error if RELATION is not 'ancestor, meaning that START is not an +ancestor of the commit in INSTANCE, unless CHANNEL specifies a commit. + +This procedure implements a channel update policy meant to be used as a +#:validate-pull argument." + (match relation + ('ancestor #t) + ('self #t) + (_ + (raise (apply make-compound-condition + (condition + (&message (message + (format #f (G_ "\ +aborting update of channel '~a' to commit ~a, which is not a descendant of ~a") + (channel-name channel) + (channel-instance-commit instance) + start)))) + + ;; Don't show the hint when the user explicitly specified a + ;; commit in CHANNEL. + (if (channel-commit channel) + '() + (list (condition + (&fix-hint + (hint (G_ "This could indicate that the channel has +been tampered with and is trying to force a roll-back, preventing you from +getting the latest updates. If you think this is not the case, explicitly +allow non-forward updates."))))))))))) + +(define* (latest-channel-instances store channels + #:key + (current-channels '()) + (validate-pull + ensure-forward-channel-update)) "Return a list of channel instances corresponding to the latest checkouts of -CHANNELS and the channels on which they depend." +CHANNELS and the channels on which they depend. + +CURRENT-CHANNELS is the list of currently used channels. It is compared +against the newly-fetched instances of CHANNELS, and VALIDATE-PULL is called +for each channel update and can choose to emit warnings or raise an error, +depending on the policy it implements." ;; Only process channels that are unique, or that are more specific than a ;; previous channel specification. (define (ignore? channel others) @@ -244,6 +288,13 @@ CHANNELS and the channels on which they depend." (not (or (channel-commit a) (channel-commit b)))))))) + (define (current-commit name) + ;; Return the current commit for channel NAME. + (any (lambda (channel) + (and (eq? (channel-name channel) name) + (channel-commit channel))) + current-channels)) + (let loop ((channels channels) (previous-channels '())) ;; Accumulate a list of instances. A list of processed channels is also @@ -257,7 +308,15 @@ CHANNELS and the channels on which they depend." (G_ "Updating channel '~a' from Git repository at '~a'...~%") (channel-name channel) (channel-url channel)) - (let ((instance (latest-channel-instance store channel))) + (let*-values (((current) + (current-commit (channel-name channel))) + ((instance relation) + (latest-channel-instance store channel + #:starting-commit + current))) + (when relation + (validate-pull channel current instance relation)) + (let-values (((new-instances new-channels) (loop (channel-instance-dependencies instance) previous-channels))) @@ -617,10 +676,20 @@ channel instances." (define latest-channel-instances* (store-lift latest-channel-instances)) -(define* (latest-channel-derivation #:optional (channels %default-channels)) +(define* (latest-channel-derivation #:optional (channels %default-channels) + #:key + (current-channels '()) + (validate-pull + ensure-forward-channel-update)) "Return as a monadic value the derivation that builds the profile for the -latest instances of CHANNELS." - (mlet %store-monad ((instances (latest-channel-instances* channels))) +latest instances of CHANNELS. CURRENT-CHANNELS and VALIDATE-PULL are passed +to 'latest-channel-instances'." + (mlet %store-monad ((instances + (latest-channel-instances* channels + #:current-channels + current-channels + #:validate-pull + validate-pull))) (channel-instances->derivation instances))) (define (profile-channels profile) diff --git a/tests/channels.scm b/tests/channels.scm index 3578b57204..3b141428c8 100644 --- a/tests/channels.scm +++ b/tests/channels.scm @@ -37,6 +37,7 @@ #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:use-module (srfi srfi-64) + #:use-module (ice-9 control) #:use-module (ice-9 match)) (test-begin "channels") @@ -178,6 +179,40 @@ "abc1234"))) instances))))))) +(unless (which (git-command)) (test-skip 1)) +(test-equal "latest-channel-instances #:validate-pull" + 'descendant + + ;; Make sure the #:validate-pull procedure receives the right values. + (let/ec return + (with-temporary-git-repository directory + '((add "a.txt" "A") + (commit "first commit") + (add "b.scm" "#t") + (commit "second commit")) + (with-repository directory repository + (let* ((commit1 (find-commit repository "first")) + (commit2 (find-commit repository "second")) + (spec (channel (url (string-append "file://" directory)) + (name 'foo))) + (new (channel (inherit spec) + (commit (oid->string (commit-id commit2))))) + (old (channel (inherit spec) + (commit (oid->string (commit-id commit1)))))) + (define (validate-pull channel current instance relation) + (return (and (eq? channel old) + (string=? (oid->string (commit-id commit2)) + current) + (string=? (oid->string (commit-id commit1)) + (channel-instance-commit instance)) + relation))) + + (with-store store + ;; Attempt a downgrade from NEW to OLD. + (latest-channel-instances store (list old) + #:current-channels (list new) + #:validate-pull validate-pull))))))) + (test-assert "channel-instances->manifest" ;; Compute the manifest for a graph of instances and make sure we get a ;; derivation graph that mirrors the instance graph. This test also ensures