From patchwork Tue Jul 16 23:24:30 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: 14695 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 6FC9F17233; Wed, 17 Jul 2019 00:25:10 +0100 (BST) 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 2012D17231 for ; Wed, 17 Jul 2019 00:25:10 +0100 (BST) Received: from localhost ([::1]:52864 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hnWon-00069x-QF for patchwork@mira.cbaines.net; Tue, 16 Jul 2019 19:25:09 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:60023) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hnWok-00069o-Kn for guix-patches@gnu.org; Tue, 16 Jul 2019 19:25:08 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1hnWog-0002gR-No for guix-patches@gnu.org; Tue, 16 Jul 2019 19:25:04 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:42484) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1hnWog-0002g2-80 for guix-patches@gnu.org; Tue, 16 Jul 2019 19:25:02 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1hnWog-0003Ub-4I for guix-patches@gnu.org; Tue, 16 Jul 2019 19:25:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#36699] [PATCH 1/4] channels: Strictly check the version of '.guix-channel'. References: <20190716232016.16559-1-ludo@gnu.org> In-Reply-To: <20190716232016.16559-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: Tue, 16 Jul 2019 23:25:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 36699 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 36699@debbugs.gnu.org Received: via spool by 36699-submit@debbugs.gnu.org id=B36699.156331949213379 (code B ref 36699); Tue, 16 Jul 2019 23:25:02 +0000 Received: (at 36699) by debbugs.gnu.org; 16 Jul 2019 23:24:52 +0000 Received: from localhost ([127.0.0.1]:51298 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hnWoV-0003Te-H8 for submit@debbugs.gnu.org; Tue, 16 Jul 2019 19:24:52 -0400 Received: from eggs.gnu.org ([209.51.188.92]:47534) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hnWoT-0003TD-B0 for 36699@debbugs.gnu.org; Tue, 16 Jul 2019 19:24:49 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:48206) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1hnWoO-0002X3-6H; Tue, 16 Jul 2019 19:24:44 -0400 Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=60146 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:DHE_RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1hnWoN-0002ms-Gj; Tue, 16 Jul 2019 19:24:44 -0400 From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Wed, 17 Jul 2019 01:24:30 +0200 Message-Id: <20190716232433.16789-1-ludo@gnu.org> X-Mailer: git-send-email 2.22.0 MIME-Version: 1.0 X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] 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 Until now the 'version' field in '.guix-channel' could be omitted, or it could be any value. * guix/channels.scm (read-channel-metadata): Rename to... (channel-instance-metadata): ... this. (channel-instance-dependencies): Adjust accordingly. (read-channel-metadata): New procedure. Use 'match' to require a 'version' field. Provide proper error handling when the channel sexp is malformed or when given an unsupported version number. (read-channel-metadata-from-source): Use 'catch' and 'system-error-errno' instead of 'file-exists?'. * tests/channels.scm (instance--unsupported-version): New variable. (read-channel-metadata): Rename to... (channel-instance-metadata): ... this. Rename tests accordingly. ("channel-instance-metadata rejects unsupported version"): New test. --- guix/channels.scm | 69 ++++++++++++++++++++++++++++++---------------- tests/channels.scm | 29 +++++++++++++------ 2 files changed, 67 insertions(+), 31 deletions(-) diff --git a/guix/channels.scm b/guix/channels.scm index bfe6963418..e92148abf2 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -121,32 +121,55 @@ (#f `(branch . ,(channel-branch channel))) (commit `(commit . ,(channel-commit channel))))) +(define (read-channel-metadata port) + "Read from PORT channel metadata in the format expected for the +'.guix-channel' file. Return a record, or raise an error +if valid metadata could not be read from PORT." + (match (read port) + (('channel ('version 0) properties ...) + (let ((directory (and=> (assoc-ref properties 'directory) first)) + (dependencies (or (assoc-ref properties 'dependencies) '()))) + (channel-metadata + version + directory + (map (lambda (item) + (let ((get (lambda* (key #:optional default) + (or (and=> (assoc-ref item key) first) default)))) + (and-let* ((name (get 'name)) + (url (get 'url)) + (branch (get 'branch "master"))) + (channel + (name name) + (branch branch) + (url url) + (commit (get 'commit)))))) + dependencies)))) + ((and ('channel ('version version) _ ...) sexp) + (raise (condition + (&message (message "unsupported '.guix-channel' version")) + (&error-location + (location (source-properties->location + (source-properties sexp))))))) + (sexp + (raise (condition + (&message (message "invalid '.guix-channel' file")) + (&error-location + (location (source-properties->location + (source-properties sexp))))))))) + (define (read-channel-metadata-from-source source) "Return a channel-metadata record read from channel's SOURCE/.guix-channel description file, or return #F if SOURCE/.guix-channel does not exist." - (let ((meta-file (string-append source "/.guix-channel"))) - (and (file-exists? meta-file) - (let* ((raw (call-with-input-file meta-file read)) - (version (and=> (assoc-ref raw 'version) first)) - (directory (and=> (assoc-ref raw 'directory) first)) - (dependencies (or (assoc-ref raw 'dependencies) '()))) - (channel-metadata - version - directory - (map (lambda (item) - (let ((get (lambda* (key #:optional default) - (or (and=> (assoc-ref item key) first) default)))) - (and-let* ((name (get 'name)) - (url (get 'url)) - (branch (get 'branch "master"))) - (channel - (name name) - (branch branch) - (url url) - (commit (get 'commit)))))) - dependencies)))))) + (catch 'system-error + (lambda () + (call-with-input-file (string-append source "/.guix-channel") + read-channel-metadata)) + (lambda args + (if (= ENOENT (system-error-errno args)) + #f + (apply throw args))))) -(define (read-channel-metadata instance) +(define (channel-instance-metadata instance) "Return a channel-metadata record read from the channel INSTANCE's description file, or return #F if the channel instance does not include the file." @@ -155,7 +178,7 @@ file." (define (channel-instance-dependencies instance) "Return the list of channels that are declared as dependencies for the given channel INSTANCE." - (match (read-channel-metadata instance) + (match (channel-instance-metadata instance) (#f '()) (($ version directory dependencies) dependencies))) diff --git a/tests/channels.scm b/tests/channels.scm index 8540aef435..1f1357fca7 100644 --- a/tests/channels.scm +++ b/tests/channels.scm @@ -26,8 +26,12 @@ #:use-module (guix derivations) #:use-module (guix sets) #:use-module (guix gexp) + #:use-module ((guix utils) + #:select (error-location? error-location location-line)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module (srfi srfi-64) #:use-module (ice-9 match)) @@ -46,6 +50,9 @@ #:name name)) (define instance--boring (make-instance)) +(define instance--unsupported-version + (make-instance #:spec + '(channel (version 42) (dependencies whatever)))) (define instance--no-deps (make-instance #:spec '(channel @@ -78,24 +85,30 @@ (name test-channel) (url "https://example.com/test-channel-elsewhere")))))) -(define read-channel-metadata - (@@ (guix channels) read-channel-metadata)) +(define channel-instance-metadata + (@@ (guix channels) channel-instance-metadata)) -(test-equal "read-channel-metadata returns #f if .guix-channel does not exist" +(test-equal "channel-instance-metadata returns #f if .guix-channel does not exist" #f - (read-channel-metadata instance--boring)) + (channel-instance-metadata instance--boring)) -(test-assert "read-channel-metadata returns " +(test-equal "channel-instance-metadata rejects unsupported version" + 1 ;line number in the generated '.guix-channel' + (guard (c ((and (message-condition? c) (error-location? c)) + (location-line (error-location c)))) + (channel-instance-metadata instance--unsupported-version))) + +(test-assert "channel-instance-metadata returns " (every (@@ (guix channels) channel-metadata?) - (map read-channel-metadata + (map channel-instance-metadata (list instance--no-deps instance--simple instance--with-dupes)))) -(test-assert "read-channel-metadata dependencies are channels" +(test-assert "channel-instance-metadata dependencies are channels" (let ((deps ((@@ (guix channels) channel-metadata-dependencies) - (read-channel-metadata instance--simple)))) + (channel-instance-metadata instance--simple)))) (match deps (((? channel? dep)) #t) (_ #f)))) From patchwork Tue Jul 16 23:24:31 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: 14696 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 CB35617234; Wed, 17 Jul 2019 00:25:12 +0100 (BST) 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 747C117231 for ; Wed, 17 Jul 2019 00:25:12 +0100 (BST) Received: from localhost ([::1]:52872 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hnWoq-0006F9-1q for patchwork@mira.cbaines.net; Tue, 16 Jul 2019 19:25:12 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:60062) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hnWom-00069v-Md for guix-patches@gnu.org; Tue, 16 Jul 2019 19:25:09 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1hnWok-0002hf-Ku for guix-patches@gnu.org; Tue, 16 Jul 2019 19:25:08 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:42485) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1hnWog-0002gY-QK for guix-patches@gnu.org; Tue, 16 Jul 2019 19:25:04 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1hnWog-0003Uj-LS for guix-patches@gnu.org; Tue, 16 Jul 2019 19:25:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#36699] [PATCH 2/4] channels: Remove unneeded 'version' field of . Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Tue, 16 Jul 2019 23:25:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 36699 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 36699@debbugs.gnu.org Received: via spool by 36699-submit@debbugs.gnu.org id=B36699.156331949413395 (code B ref 36699); Tue, 16 Jul 2019 23:25:02 +0000 Received: (at 36699) by debbugs.gnu.org; 16 Jul 2019 23:24:54 +0000 Received: from localhost ([127.0.0.1]:51301 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hnWoY-0003Ty-5X for submit@debbugs.gnu.org; Tue, 16 Jul 2019 19:24:54 -0400 Received: from eggs.gnu.org ([209.51.188.92]:47542) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hnWoU-0003TF-Il for 36699@debbugs.gnu.org; Tue, 16 Jul 2019 19:24:50 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:48207) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1hnWoP-0002XR-4i; Tue, 16 Jul 2019 19:24:45 -0400 Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=60146 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:DHE_RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1hnWoO-0002ms-I2; Tue, 16 Jul 2019 19:24:44 -0400 From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Wed, 17 Jul 2019 01:24:31 +0200 Message-Id: <20190716232433.16789-2-ludo@gnu.org> X-Mailer: git-send-email 2.22.0 In-Reply-To: <20190716232433.16789-1-ludo@gnu.org> References: <20190716232433.16789-1-ludo@gnu.org> MIME-Version: 1.0 X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] 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 The idea is that 'read-channel-metadata' will take care of converting possibly older versions to the current data type. Thus, storing the version number is unnecessary. * guix/channels.scm ()[version]: Remove. (read-channel-metadata, channel-instance-dependencies): Adjust accordingly. --- guix/channels.scm | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/guix/channels.scm b/guix/channels.scm index e92148abf2..87ad729a70 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -108,9 +108,8 @@ (checkout channel-instance-checkout)) (define-record-type - (channel-metadata version directory dependencies) + (channel-metadata directory dependencies) channel-metadata? - (version channel-metadata-version) (directory channel-metadata-directory) (dependencies channel-metadata-dependencies)) @@ -130,7 +129,6 @@ if valid metadata could not be read from PORT." (let ((directory (and=> (assoc-ref properties 'directory) first)) (dependencies (or (assoc-ref properties 'dependencies) '()))) (channel-metadata - version directory (map (lambda (item) (let ((get (lambda* (key #:optional default) @@ -180,7 +178,7 @@ file." channel INSTANCE." (match (channel-instance-metadata instance) (#f '()) - (($ version directory dependencies) + (($ directory dependencies) dependencies))) (define* (latest-channel-instances store channels #:optional (previous-channels '())) From patchwork Tue Jul 16 23:24:32 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: 14697 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 0709C17233; Wed, 17 Jul 2019 00:25:13 +0100 (BST) 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 75CBB17232 for ; Wed, 17 Jul 2019 00:25:12 +0100 (BST) Received: from localhost ([::1]:52870 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hnWop-0006Ef-UT for patchwork@mira.cbaines.net; Tue, 16 Jul 2019 19:25:11 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:60064) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hnWom-00069w-NL for guix-patches@gnu.org; Tue, 16 Jul 2019 19:25:10 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1hnWok-0002hn-Kf for guix-patches@gnu.org; Tue, 16 Jul 2019 19:25:08 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:42486) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1hnWoh-0002gi-Bx for guix-patches@gnu.org; Tue, 16 Jul 2019 19:25:04 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1hnWoh-0003Uq-6x for guix-patches@gnu.org; Tue, 16 Jul 2019 19:25:03 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#36699] [PATCH 3/4] channels: Always provide a record. Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Tue, 16 Jul 2019 23:25:03 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 36699 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 36699@debbugs.gnu.org Received: via spool by 36699-submit@debbugs.gnu.org id=B36699.156331949513402 (code B ref 36699); Tue, 16 Jul 2019 23:25:03 +0000 Received: (at 36699) by debbugs.gnu.org; 16 Jul 2019 23:24:55 +0000 Received: from localhost ([127.0.0.1]:51303 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hnWoY-0003U0-EV for submit@debbugs.gnu.org; Tue, 16 Jul 2019 19:24:54 -0400 Received: from eggs.gnu.org ([209.51.188.92]:47544) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hnWoV-0003TI-Bw for 36699@debbugs.gnu.org; Tue, 16 Jul 2019 19:24:51 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:48208) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1hnWoQ-0002Xn-1I; Tue, 16 Jul 2019 19:24:46 -0400 Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=60146 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:DHE_RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1hnWoP-0002ms-Gk; Tue, 16 Jul 2019 19:24:45 -0400 From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Wed, 17 Jul 2019 01:24:32 +0200 Message-Id: <20190716232433.16789-3-ludo@gnu.org> X-Mailer: git-send-email 2.22.0 In-Reply-To: <20190716232433.16789-1-ludo@gnu.org> References: <20190716232433.16789-1-ludo@gnu.org> MIME-Version: 1.0 X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] 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 This simplifies the code since one no longer needs to think about whether '.guix-channel' was present. * guix/channels.scm (read-channel-metadata): Always pass a string as the first argument to 'channel-metadata'. (read-channel-metadata-from-source): Always return a record. (channel-instance-dependencies): Remove now unneeded 'match'. (standard-module-derivation): Assume DIRECTORY is never #f and contains a leading slash. * tests/channels.scm (channel-metadata-directory) (channel-metadata-dependencies): New procedures. ("channel-instance-metadata returns #f if .guix-channel does not exist"): Remove. ("channel-instance-metadata returns default if .guix-channel does not exist"): New test. (make-instance): Use 'write' instead of 'display' when creating '.guix-channel'. (instance--no-deps): Remove dependencies. (instance--sub-directory): New variable. ("channel-instance-metadata and default dependencies") ("channel-instance-metadata and directory"): New tests. ("latest-channel-instances excludes duplicate channel dependencies"): Expect 'channel-commit' to return a string and adjust accordingly. --- guix/channels.scm | 27 ++++++++++++--------------- tests/channels.scm | 45 +++++++++++++++++++++++++++++---------------- 2 files changed, 41 insertions(+), 31 deletions(-) diff --git a/guix/channels.scm b/guix/channels.scm index 87ad729a70..415246cbd1 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -110,8 +110,8 @@ (define-record-type (channel-metadata directory dependencies) channel-metadata? - (directory channel-metadata-directory) - (dependencies channel-metadata-dependencies)) + (directory channel-metadata-directory) ;string with leading slash + (dependencies channel-metadata-dependencies)) ;list of (define (channel-reference channel) "Return the \"reference\" for CHANNEL, an sexp suitable for @@ -129,7 +129,9 @@ if valid metadata could not be read from PORT." (let ((directory (and=> (assoc-ref properties 'directory) first)) (dependencies (or (assoc-ref properties 'dependencies) '()))) (channel-metadata - directory + (cond ((not directory) "/") + ((string-prefix? "/" directory) directory) + (else (string-append "/" directory))) (map (lambda (item) (let ((get (lambda* (key #:optional default) (or (and=> (assoc-ref item key) first) default)))) @@ -157,29 +159,26 @@ if valid metadata could not be read from PORT." (define (read-channel-metadata-from-source source) "Return a channel-metadata record read from channel's SOURCE/.guix-channel -description file, or return #F if SOURCE/.guix-channel does not exist." +description file, or return the default channel-metadata record if that file +doesn't exist." (catch 'system-error (lambda () (call-with-input-file (string-append source "/.guix-channel") read-channel-metadata)) (lambda args (if (= ENOENT (system-error-errno args)) - #f + (channel-metadata "/" '()) (apply throw args))))) (define (channel-instance-metadata instance) "Return a channel-metadata record read from the channel INSTANCE's -description file, or return #F if the channel instance does not include the -file." +description file or its default value." (read-channel-metadata-from-source (channel-instance-checkout instance))) (define (channel-instance-dependencies instance) "Return the list of channels that are declared as dependencies for the given channel INSTANCE." - (match (channel-instance-metadata instance) - (#f '()) - (($ directory dependencies) - dependencies))) + (channel-metadata-dependencies (channel-instance-metadata instance))) (define* (latest-channel-instances store channels #:optional (previous-channels '())) "Return a list of channel instances corresponding to the latest checkouts of @@ -261,7 +260,7 @@ objects. The assumption is that SOURCE contains package modules to be added to '%package-module-path'." (let* ((metadata (read-channel-metadata-from-source source)) - (directory (and=> metadata channel-metadata-directory))) + (directory (channel-metadata-directory metadata))) (define build ;; This is code that we'll run in CORE, a Guix instance, with its own @@ -281,9 +280,7 @@ to '%package-module-path'." (string-append #$output "/share/guile/site/" (effective-version))) - (let* ((subdir (if #$directory - (string-append "/" #$directory) - "")) + (let* ((subdir #$directory) (source (string-append #$source subdir))) (compile-files source go (find-files source "\\.scm$")) (mkdir-p (dirname scm)) diff --git a/tests/channels.scm b/tests/channels.scm index 1f1357fca7..e83b5437d3 100644 --- a/tests/channels.scm +++ b/tests/channels.scm @@ -42,9 +42,9 @@ (commit "cafebabe") (spec #f)) (define instance-dir (mkdtemp! "/tmp/checkout.XXXXXX")) - (and spec - (with-output-to-file (string-append instance-dir "/.guix-channel") - (lambda _ (format #t "~a" spec)))) + (when spec + (call-with-output-file (string-append instance-dir "/.guix-channel") + (lambda (port) (write spec port)))) (checkout->channel-instance instance-dir #:commit commit #:name name)) @@ -55,12 +55,10 @@ '(channel (version 42) (dependencies whatever)))) (define instance--no-deps (make-instance #:spec - '(channel - (version 0) - (dependencies - (channel - (name test-channel) - (url "https://example.com/test-channel")))))) + '(channel (version 0)))) +(define instance--sub-directory + (make-instance #:spec + '(channel (version 0) (directory "modules")))) (define instance--simple (make-instance #:spec '(channel @@ -87,11 +85,26 @@ (define channel-instance-metadata (@@ (guix channels) channel-instance-metadata)) +(define channel-metadata-directory + (@@ (guix channels) channel-metadata-directory)) +(define channel-metadata-dependencies + (@@ (guix channels) channel-metadata-dependencies)) -(test-equal "channel-instance-metadata returns #f if .guix-channel does not exist" - #f - (channel-instance-metadata instance--boring)) +(test-equal "channel-instance-metadata returns default if .guix-channel does not exist" + '("/" ()) + (let ((metadata (channel-instance-metadata instance--boring))) + (list (channel-metadata-directory metadata) + (channel-metadata-dependencies metadata)))) + +(test-equal "channel-instance-metadata and default dependencies" + '() + (channel-metadata-dependencies (channel-instance-metadata instance--no-deps))) + +(test-equal "channel-instance-metadata and directory" + "/modules" + (channel-metadata-directory + (channel-instance-metadata instance--sub-directory))) (test-equal "channel-instance-metadata rejects unsupported version" 1 ;line number in the generated '.guix-channel' @@ -141,7 +154,7 @@ ("test" (values test-dir 'whatever)) (_ (values "/not-important" 'not-important))))) (let ((instances (latest-channel-instances #f (list channel)))) - (and (eq? 2 (length instances)) + (and (= 2 (length instances)) (lset= eq? '(test test-channel) (map (compose channel-name channel-instance-channel) @@ -152,9 +165,9 @@ (and (eq? (channel-name (channel-instance-channel instance)) 'test-channel) - (eq? (channel-commit - (channel-instance-channel instance)) - 'abc1234))) + (string=? (channel-commit + (channel-instance-channel instance)) + "abc1234"))) instances)))))) (test-assert "channel-instances->manifest" From patchwork Tue Jul 16 23:24:33 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: 14698 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 7763C17233; Wed, 17 Jul 2019 00:25:14 +0100 (BST) 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 3351717231 for ; Wed, 17 Jul 2019 00:25:14 +0100 (BST) Received: from localhost ([::1]:52874 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hnWor-0006NA-TQ for patchwork@mira.cbaines.net; Tue, 16 Jul 2019 19:25:13 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:60083) by lists.gnu.org with esmtp (Exim 4.86_2) (envelope-from ) id 1hnWoo-0006Ed-RA for guix-patches@gnu.org; Tue, 16 Jul 2019 19:25:12 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1hnWok-0002hv-Kw for guix-patches@gnu.org; Tue, 16 Jul 2019 19:25:10 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:42487) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1hnWoh-0002gv-Rq for guix-patches@gnu.org; Tue, 16 Jul 2019 19:25:04 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1hnWoh-0003V1-Ml for guix-patches@gnu.org; Tue, 16 Jul 2019 19:25:03 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#36699] [PATCH 4/4] channels: Reject directories with '..' in '.guix-channel' file. Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Tue, 16 Jul 2019 23:25:03 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 36699 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 36699@debbugs.gnu.org Received: via spool by 36699-submit@debbugs.gnu.org id=B36699.156331949913414 (code B ref 36699); Tue, 16 Jul 2019 23:25:03 +0000 Received: (at 36699) by debbugs.gnu.org; 16 Jul 2019 23:24:59 +0000 Received: from localhost ([127.0.0.1]:51305 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hnWoc-0003UH-UZ for submit@debbugs.gnu.org; Tue, 16 Jul 2019 19:24:59 -0400 Received: from eggs.gnu.org ([209.51.188.92]:47551) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hnWoX-0003TN-I9 for 36699@debbugs.gnu.org; Tue, 16 Jul 2019 19:24:53 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:48209) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1hnWoR-0002Y8-8p; Tue, 16 Jul 2019 19:24:48 -0400 Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=60146 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:DHE_RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1hnWoQ-0002ms-DD; Tue, 16 Jul 2019 19:24:46 -0400 From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Wed, 17 Jul 2019 01:24:33 +0200 Message-Id: <20190716232433.16789-4-ludo@gnu.org> X-Mailer: git-send-email 2.22.0 In-Reply-To: <20190716232433.16789-1-ludo@gnu.org> References: <20190716232433.16789-1-ludo@gnu.org> MIME-Version: 1.0 X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] 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/channels.scm (read-channel-metadata)[sexp, location]: New variables. [sane-directory]: New procedure. Call it when DIRECTORY is true. * tests/channels.scm (instance--fishy-directory): New variable. ("channel-instance-metadata and fishy directory"): New test. --- guix/channels.scm | 30 ++++++++++++++++++++---------- tests/channels.scm | 11 +++++++++++ 2 files changed, 31 insertions(+), 10 deletions(-) diff --git a/guix/channels.scm b/guix/channels.scm index 415246cbd1..641dee8dbb 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -124,14 +124,28 @@ "Read from PORT channel metadata in the format expected for the '.guix-channel' file. Return a record, or raise an error if valid metadata could not be read from PORT." - (match (read port) + (define sexp + (read port)) + + (define location + (source-properties->location (source-properties sexp))) + + (define (sane-directory directory) + ;; If DIRECTORY contains '..', raise an error; otherwise return it. + (when (member ".." (string-split directory #\/)) + (raise (condition + (&message (message "channel sub-directory must not contain '..'")) + (&error-location (location location))))) + directory) + + (match sexp (('channel ('version 0) properties ...) (let ((directory (and=> (assoc-ref properties 'directory) first)) (dependencies (or (assoc-ref properties 'dependencies) '()))) (channel-metadata (cond ((not directory) "/") - ((string-prefix? "/" directory) directory) - (else (string-append "/" directory))) + ((string-prefix? "/" directory) (sane-directory directory)) + (else (string-append "/" (sane-directory directory)))) (map (lambda (item) (let ((get (lambda* (key #:optional default) (or (and=> (assoc-ref item key) first) default)))) @@ -144,18 +158,14 @@ if valid metadata could not be read from PORT." (url url) (commit (get 'commit)))))) dependencies)))) - ((and ('channel ('version version) _ ...) sexp) + (('channel ('version version) _ ...) (raise (condition (&message (message "unsupported '.guix-channel' version")) - (&error-location - (location (source-properties->location - (source-properties sexp))))))) + (&error-location (location location))))) (sexp (raise (condition (&message (message "invalid '.guix-channel' file")) - (&error-location - (location (source-properties->location - (source-properties sexp))))))))) + (&error-location (location location))))))) (define (read-channel-metadata-from-source source) "Return a channel-metadata record read from channel's SOURCE/.guix-channel diff --git a/tests/channels.scm b/tests/channels.scm index e83b5437d3..402025dea3 100644 --- a/tests/channels.scm +++ b/tests/channels.scm @@ -59,6 +59,11 @@ (define instance--sub-directory (make-instance #:spec '(channel (version 0) (directory "modules")))) +(define instance--fishy-directory + (make-instance #:spec + '(channel (version 0) + (directory "../../../../../etc")))) + (define instance--simple (make-instance #:spec '(channel @@ -106,6 +111,12 @@ (channel-metadata-directory (channel-instance-metadata instance--sub-directory))) +(test-assert "channel-instance-metadata and fishy directory" + (guard (c ((and (message-condition? c) (error-location? c)) + #t)) + (channel-instance-metadata instance--fishy-directory) + #f)) + (test-equal "channel-instance-metadata rejects unsupported version" 1 ;line number in the generated '.guix-channel' (guard (c ((and (message-condition? c) (error-location? c))