From mboxrd@z Thu Jan 1 00:00:00 1970 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 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-Message-ID: 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> MIME-Version: 1.0 Content-Transfer-Encoding: 8bit List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+kyle=kyleam.com@gnu.org Sender: "Guix-patches" To: 36699@debbugs.gnu.org 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)))) -- 2.22.0