02/02: guix: lint: Check for meaningful origin file names.

[Eric Bavier]

bavier pushed a commit to branch master
in repository guix.

commit 50f5c46d0674eb68201c56bef17b2a41c7744404
Author: Eric Bavier <address@hidden>
Date:   Thu Sep 10 15:34:58 2015 -0500

    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 prefix")
      ("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 |   27 ++++++++++++++++-
 tests/lint.scm        |   80 ++++++++++++++++++++++++++++++++++++++++++++++++-
 3 files changed, 109 insertions(+), 3 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 51f7cb2..b70be01 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -4219,8 +4219,11 @@ Identify inputs that should most likely be native inputs.
 
 @item source
 @itemx home-page
address@hidden 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
address@hidden 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..ab7d7c6 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 <address@hidden>
-;;; Copyright © 2014 Eric Bavier <address@hidden>
+;;; Copyright © 2014, 2015 Eric Bavier <address@hidden>
 ;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <address@hidden>
 ;;;
 ;;; 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
 
@@ -501,6 +502,26 @@ descriptions maintained upstream."
                           (display warning (guix-warning-port)))
                         (reverse warnings)))))))))
 
+(define (check-source-file-name package)
+  "Emit a warning if PACKAGE's origin has no meaningful file name."
+  (define (origin-file-name-valid? origin)
+    ;; Return #t if the source file name contains only a version or is #f;
+    ;; 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."
   (catch #t
@@ -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..76040c1 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 <address@hidden>
-;;; Copyright © 2014 Eric Bavier <address@hidden>
+;;; Copyright © 2014, 2015 Eric Bavier <address@hidden>
 ;;; Copyright © 2014, 2015 Ludovic Courtès <address@hidden>
 ;;;
 ;;; 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 prefix"
+  (->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"
   ""