Re: [PATCH] guix: lint: Check for version-only origin file names.

[Eric Bavier <ericbavier@openmailbox.org>]

[-- Attachment #1: Type: text/plain, Size: 3521 bytes --]

Something happened to the attachments.  Let's try that again.  Sorry 
about that.

`~Eric

On 2015-09-10 15:50, Eric Bavier wrote:
> On Fri, 28 Aug 2015 09:48:48 +0200
> ludo@gnu.org (Ludovic Courtès) wrote:
> 
>> Eric Bavier <ericbavier@openmailbox.org> skribis:
>> 
>> > From 0311d5b383003600ac43d3a9bfdec0ad3c398db2 Mon Sep 17 00:00:00 2001
>> > From: Eric Bavier <bavier@member.fsf.org>
>> > Date: Sun, 23 Aug 2015 18:00:45 -0500
>> > Subject: [PATCH] guix: lint: Check for version-only origin file names.
>> >
>> > * guix/scripts/lint.scm (check-source): Emit warning if source filename
>> >   contains only the version of the package.
>> > * tests/lint.scm ("source: filename", "source: filename v",
>> >   "source: filename valid"): New tests.
>> > * doc/guix.texi (Invoking guix lint): Mention file name check.
>> > Offending packages updated.
>> 
>> This is useful, thanks for looking into it.
> 
> Thanks for the review!
> 
>> I would prefer it to make a separate linter, like ‘source-file-name’.
>> The reason is that ‘source’ is a relatively expensive check, since it
>> needs to probe URLs (so you might want to skip it in some cases),
>> whereas the linter your propose is lightweight.
> 
> Makes sense.
> 
>> 
>> > --- a/gnu/packages/algebra.scm
>> > +++ b/gnu/packages/algebra.scm
>> > @@ -386,6 +386,7 @@ cosine/ sine transforms or DCT/DST).")
>> >                (method url-fetch)
>> >                (uri (string-append "https://bitbucket.org/eigen/eigen/get/"
>> >                                    version ".tar.bz2"))
>> > +              (file-name (string-append name "-" version ".tar.bz2"))
>> 
>> Could you make these package updates a separate patch?  Some may 
>> trigger
>> large rebuilds, so you may have to keep them for ‘core-updates’ or 
>> such.
> 
> I've left the package updates out of the attached patches.
> 
>> 
>> > +  (define (origin-version-name? origin)
>> > +    ;; Return #t if the source file name contains only a version; indicates
>> > +    ;; that the origin needs a 'file-name' field.
>> > +    (let ((filename (store-path-package-name
>> > +                     (with-store store
>> > +                       (derivation->output-path
>> > +                        (package-source-derivation store origin)))))
>> > +          (version (package-version package)))
>> > +      (or (string-prefix? version filename)
>> > +          ;; Common in many projects is for the filename to start with a "v"
>> > +          ;; followed by the version, e.g. "v3.2.0.tar.gz".
>> > +          (string-prefix? (string-append "v" version) filename))))
>> 
>> Opening a connection to the store in the middle of the code
>> (‘with-store’) is Bad Practice.  ;-)
>> 
>> I think this can actually be made simpler, with something akin to what
>> ‘node-full-name’ does in guix/scripts/graph.scm.  Maybe we could 
>> extract
>> an ‘origin-actual-file-name’ procedure from that and move it to (guix
>> packages).  WDYT?
> 
> The first attached patch does this.  Is using the basename of the
> source URI always accurate?  I.e. are there cases where the store file
> name might not match the URI's basename?  This uncertainty, I think, is
> what caused me to use store-path-package-name initially.
> 
> This revised patch might actually be considered "more accurate" in that
> the checker now flags origins from 'git-reference' et al where no
> 'file-name' field is declared.
> 
> `~Eric

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-guix-packages-Add-origin-actual-file-name.patch --]
[-- Type: text/x-diff; name=0001-guix-packages-Add-origin-actual-file-name.patch, Size: 3303 bytes --]

From 8db3e5978394b99ad14d69494b00343b70f918e1 Mon Sep 17 00:00:00 2001
From: Eric Bavier <bavier@member.fsf.org>
Date: Thu, 10 Sep 2015 15:39:44 -0500
Subject: [PATCH 1/2] guix: packages: Add origin-actual-file-name.

* guix/scripts/graph.scm (uri->file-name, node-full-name): Move origin file
  name logic to...
* guix/packages.scm (origin-actual-file-name): ...here.
---
 guix/packages.scm      | 22 ++++++++++++++++++++++
 guix/scripts/graph.scm | 15 +--------------
 2 files changed, 23 insertions(+), 14 deletions(-)

diff --git a/guix/packages.scm b/guix/packages.scm
index e466ffe..edcb53e 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -37,6 +37,7 @@
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
+  #:use-module (web uri)
   #:re-export (%current-system
                %current-target-system
                search-path-specification)         ;for convenience
@@ -46,6 +47,7 @@
             origin-method
             origin-sha256
             origin-file-name
+            origin-actual-file-name
             origin-patches
             origin-patch-flags
             origin-patch-inputs
@@ -188,6 +190,26 @@ representation."
       ((_ str)
        #'(nix-base32-string->bytevector str)))))
 
+(define (origin-actual-file-name origin)
+  "Return the file name of ORIGIN, either its 'file-name' field or the file
+name of its URI."
+  (define (uri->file-name uri)
+    ;; Return the 'base name' of URI or URI itself, where URI is a string.
+    (let ((path (and=> (string->uri uri) uri-path)))
+      (if path
+          (basename path)
+          uri)))
+
+  (or (origin-file-name origin)
+      (match (origin-uri origin)
+        ((head . tail)
+         (uri->file-name head))
+        ((? string? uri)
+         (uri->file-name uri))
+        (else
+         ;; git, svn, cvs, etc. reference
+         #f))))
+
 (define %supported-systems
   ;; This is the list of system types that are supported.  By default, we
   ;; expect all packages to build successfully here.
diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm
index 2b671be..cddd63e 100644
--- a/guix/scripts/graph.scm
+++ b/guix/scripts/graph.scm
@@ -33,7 +33,6 @@
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-37)
   #:use-module (ice-9 match)
-  #:use-module (web uri)
   #:export (%package-node-type
             %bag-node-type
             %bag-emerged-node-type
@@ -78,25 +77,13 @@
 ;;; Package DAG.
 ;;;
 
-(define (uri->file-name uri)
-  "Return the 'base name' of URI or URI itself, where URI is a string."
-  (let ((path (and=> (string->uri uri) uri-path)))
-    (if path
-        (basename path)
-        uri)))
-
 (define (node-full-name thing)
   "Return a human-readable name to denote THING, a package, origin, or file
 name."
   (cond ((package? thing)
          (package-full-name thing))
         ((origin? thing)
-         (or (origin-file-name thing)
-             (match (origin-uri thing)
-               ((head . tail)
-                (uri->file-name head))
-               ((? string? uri)
-                (uri->file-name uri)))))
+         (origin-actual-file-name thing))
         ((string? thing)                          ;file name
          (or (basename thing)
              (error "basename" thing)))
-- 
2.4.3


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #3: 0002-guix-lint-Check-for-meaningful-origin-file-names.patch --]
[-- Type: text/x-diff; name=0002-guix-lint-Check-for-meaningful-origin-file-names.patch, Size: 9697 bytes --]

From 03c3f2b21a2467675092830aea2ddf192e133ff5 Mon Sep 17 00:00:00 2001
From: Eric Bavier <bavier@member.fsf.org>
Date: Thu, 10 Sep 2015 15:34:58 -0500
Subject: [PATCH 2/2] guix: lint: Check for meaningful origin file names.

* guix/scripts/lint.scm (check-source-file-name): New procedure.
  (%checkers): Add 'source-file-name' checker.
* tests/lint.scm ("source: file name", "source: file name v")
  ("source: file name valid", "source: file name bad checkout")
  ("source: file name good checkout"): New tests.
* doc/guix.texi (Invoking guix lint): Mention file name check.
---
 doc/guix.texi         |  5 +++-
 guix/scripts/lint.scm | 75 +++++++++++++++++++++++++++++++----------------
 tests/lint.scm        | 80 ++++++++++++++++++++++++++++++++++++++++++++++++++-
 3 files changed, 133 insertions(+), 27 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 9ae91a8..6c563a9 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -4217,8 +4217,11 @@ Identify inputs that should most likely be native inputs.
 
 @item source
 @itemx home-page
+@itemx source-file-name
 Probe @code{home-page} and @code{source} URLs and report those that are
-invalid.
+invalid.  Check that the source file name is meaningful, e.g. is not
+just a version number or ``git-checkout'', and should not have a
+@code{file-name} declared (@pxref{origin Reference}).
 
 @item formatting
 Warn about obvious source code formatting issues: trailing white space,
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index 2a618c9..6adea14 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014 Cyril Roelandt <tipecaml@gmail.com>
-;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
+;;; Copyright © 2014, 2015 Eric Bavier <bavier@member.fsf.org>
 ;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -57,6 +57,7 @@
             check-derivation
             check-home-page
             check-source
+            check-source-file-name
             check-license
             check-formatting
 
@@ -476,30 +477,50 @@ descriptions maintained upstream."
       '()))
 
   (let ((origin (package-source package)))
-    (when (and origin
-               (eqv? (origin-method origin) url-fetch))
-      (let* ((strings (origin-uri origin))
-             (uris (if (list? strings)
-                       (map string->uri strings)
-                       (list (string->uri strings)))))
-
-        ;; Just make sure that at least one of the URIs is valid.
-        (call-with-values
-            (lambda () (try-uris uris))
-          (lambda (success? warnings)
-            ;; When everything fails, report all of WARNINGS, otherwise don't
-            ;; report anything.
-            ;;
-            ;; XXX: Ideally we'd still allow warnings to be raised if *some*
-            ;; URIs are unreachable, but distinguish that from the error case
-            ;; where *all* the URIs are unreachable.
-            (unless success?
-              (emit-warning package
-                            (_ "all the source URIs are unreachable:")
-                            'source)
-              (for-each (lambda (warning)
-                          (display warning (guix-warning-port)))
-                        (reverse warnings)))))))))
+    (when origin
+      (if (eqv? (origin-method origin) url-fetch)
+          (let* ((strings (origin-uri origin))
+                 (uris (if (list? strings)
+                           (map string->uri strings)
+                           (list (string->uri strings)))))
+
+            ;; Just make sure that at least one of the URIs is valid.
+            (call-with-values
+                (lambda () (try-uris uris))
+              (lambda (success? warnings)
+                ;; When everything fails, report all of WARNINGS, otherwise don't
+                ;; report anything.
+                ;;
+                ;; XXX: Ideally we'd still allow warnings to be raised if *some*
+                ;; URIs are unreachable, but distinguish that from the error case
+                ;; where *all* the URIs are unreachable.
+                (unless success?
+                  (emit-warning package
+                                (_ "all the source URIs are unreachable:")
+                                'source)
+                  (for-each (lambda (warning)
+                              (display warning (guix-warning-port)))
+                            (reverse warnings))))))))))
+
+(define (check-source-file-name package)
+  "Emit a warning if PACKAGE's origin has a version-only file name."
+  (define (origin-file-name-valid? origin)
+    ;; Return #t if the source file name contains only a version; indicates
+    ;; that the origin needs a 'file-name' field.
+    (let ((file-name (origin-actual-file-name origin))
+          (version (package-version package)))
+      (and file-name
+           (not (or (string-prefix? version file-name)
+                    ;; Common in many projects is for the filename to start
+                    ;; with a "v" followed by the version,
+                    ;; e.g. "v3.2.0.tar.gz".
+                    (string-prefix? (string-append "v" version) file-name))))))
+
+  (let ((origin (package-source package)))
+    (unless (or (not origin) (origin-file-name-valid? origin))
+      (emit-warning package
+                    (_ "the source file name should contain the package name")
+                    'source))))
 
 (define (check-derivation package)
   "Emit a warning if we fail to compile PACKAGE to a derivation."
@@ -643,6 +664,10 @@ or a list thereof")
      (description "Validate source URLs")
      (check       check-source))
    (lint-checker
+     (name        'source-file-name)
+     (description "Validate file names of sources")
+     (check       check-source-file-name))
+   (lint-checker
      (name        'derivation)
      (description "Report failure to compile a package to a derivation")
      (check       check-derivation))
diff --git a/tests/lint.scm b/tests/lint.scm
index ac47dbb..2fac284 100644
--- a/tests/lint.scm
+++ b/tests/lint.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2012, 2013 Cyril Roelandt <tipecaml@gmail.com>
-;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
+;;; Copyright © 2014, 2015 Eric Bavier <bavier@member.fsf.org>
 ;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -21,6 +21,7 @@
 (define-module (test-lint)
   #:use-module (guix tests)
   #:use-module (guix download)
+  #:use-module (guix git-download)
   #:use-module (guix build-system gnu)
   #:use-module (guix packages)
   #:use-module (guix scripts lint)
@@ -398,6 +399,83 @@ requests."
           (check-home-page pkg))))
     "not reachable: 404")))
 
+(test-assert "source: file name"
+  (->bool
+   (string-contains
+    (with-warnings
+      (let ((pkg (dummy-package "x"
+                   (version "3.2.1")
+                   (source
+                    (origin
+                      (method url-fetch)
+                      (uri "http://www.example.com/3.2.1.tar.gz")
+                      (sha256 %null-sha256))))))
+        (check-source-file-name pkg)))
+    "file name should contain the package name")))
+
+(test-assert "source: file name v"
+  (->bool
+   (string-contains
+    (with-warnings
+      (let ((pkg (dummy-package "x"
+                   (version "3.2.1")
+                   (source
+                    (origin
+                      (method url-fetch)
+                      (uri "http://www.example.com/v3.2.1.tar.gz")
+                      (sha256 %null-sha256))))))
+        (check-source-file-name pkg)))
+    "file name should contain the package name")))
+
+(test-assert "source: file name bad checkout"
+  (->bool
+   (string-contains
+    (with-warnings
+      (let ((pkg (dummy-package "x"
+                   (version "3.2.1")
+                   (source
+                    (origin
+                      (method git-fetch)
+                      (uri (git-reference
+                            (url "http://www.example.com/x.git")
+                            (commit "0")))
+                      (sha256 %null-sha256))))))
+        (check-source-file-name pkg)))
+    "file name should contain the package name")))
+
+(test-assert "source: file name good checkout"
+  (not
+   (->bool
+    (string-contains
+     (with-warnings
+       (let ((pkg (dummy-package "x"
+                    (version "3.2.1")
+                    (source
+                     (origin
+                       (method git-fetch)
+                       (uri (git-reference
+                             (url "http://git.example.com/x.git")
+                             (commit "0")))
+                       (file-name (string-append "x-" version))
+                       (sha256 %null-sha256))))))
+         (check-source-file-name pkg)))
+     "file name should contain the package name"))))
+
+(test-assert "source: file name valid"
+  (not
+   (->bool
+    (string-contains
+     (with-warnings
+       (let ((pkg (dummy-package "x"
+                    (version "3.2.1")
+                    (source
+                     (origin
+                       (method url-fetch)
+                       (uri "http://www.example.com/x-3.2.1.tar.gz")
+                       (sha256 %null-sha256))))))
+         (check-source-file-name pkg)))
+     "file name should contain the package name"))))
+
 (test-skip (if %http-server-socket 0 1))
 (test-equal "source: 200"
   ""
-- 
2.4.3