[bug#66961] [PATCH v4] scripts: hash: Handle repository with different VCS folders.

[Simon Tournier]

Fixes <https://issues.guix.gnu.org/issue/65979>.
Reported by Simon Tournier <zimon.toutoune@gmail.com>

* guix/hash.scm (%vcs-directories): New variable.
(vcs-file?): Add optional argument for passing VCS kind of the
file/repository.
(file-hash*): Adjust accordingly.
(vcs-file-predicate): New procedure and export it.
* guix/scripts/hash.scm (guix-hash)[file-hash]: Use it.

Change-Id: I8e286c3426ddefd664dc3a471d5a09e309824faa
---
 guix/hash.scm         | 35 +++++++++++++++++++++++++++++------
 guix/scripts/hash.scm | 10 +++++-----
 2 files changed, 34 insertions(+), 11 deletions(-)

diff --git a/guix/hash.scm b/guix/hash.scm
index 3cb68e5c44..81f35d63df 100644
--- a/guix/hash.scm
+++ b/guix/hash.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
 ;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be>
+;;; Copyright © 2023 Simon Tournier <zimon.toutoune@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -23,23 +24,45 @@ (define-module (guix hash)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
   #:export (vcs-file?
+            vcs-file-predicate
             file-hash*))
 
-(define (vcs-file? file stat)
-  "Returns true if FILE is a version control system file."
+(define %vcs-directories
+  ;; Directory used for determining the kind of VCS.
+  (list ".bzr" ".git" ".hg" ".svn" "CVS"))
+
+(define* (vcs-file? file stat
+                    #:optional
+                    (vcs-directories %vcs-directories))
+  "Return true if FILE matches a version control system from the list
+VCSES-DIRECTORIES."
   (case (stat:type stat)
     ((directory)
-     (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS")))
+     (member (basename file) vcs-directories))
     ((regular)
-     ;; Git sub-modules have a '.git' file that is a regular text file.
-     (string=? (basename file) ".git"))
+     (if (member ".git" vcs-directories)
+         ;; Git sub-modules have a '.git' file that is a regular text file.
+         (string=? (basename file) ".git")
+         #f))
     (else
      #f)))
 
+(define (vcs-file-predicate directory)
+  "Return a two-argument procedure that returns true when version-control
+metadata directories such as '.git' is found in DIRECTORY."
+  (define vcs-directories
+    (filter (lambda (vcs)
+              (file-exists? (in-vicinity directory vcs)))
+            %vcs-directories))
+
+  (lambda (file stat)
+    (vcs-file? file stat vcs-directories)))
+
 (define* (file-hash* file #:key
                      (algorithm (hash-algorithm sha256))
                      (recursive? 'auto)
-                     (select? (negate vcs-file?)))
+                     (select? (negate (lambda (file stat)
+                                        (vcs-file? file stat)))))
   "Compute the hash of FILE with ALGORITHM.
 
 Symbolic links are only dereferenced if RECURSIVE? is false.
diff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scm
index 7197d3965c..dec037ed3f 100644
--- a/guix/scripts/hash.scm
+++ b/guix/scripts/hash.scm
@@ -3,7 +3,7 @@
 ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
 ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
 ;;; Copyright © 2018 Tim Gesthuizen <tim.gesthuizen@yahoo.de>
-;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
+;;; Copyright © 2021, 2023 Simon Tournier <zimon.toutoune@gmail.com>
 ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -181,9 +181,6 @@ (define-command (guix-hash . args)
                             (_ #f))
                            (reverse opts)))
          (fmt  (assq-ref opts 'format))
-         (select? (if (assq-ref opts 'exclude-vcs?)
-                      (negate vcs-file?)
-                      (const #t)))
          (algorithm (assoc-ref opts 'hash-algorithm))
          (serializer (assoc-ref opts 'serializer)))
 
@@ -193,7 +190,10 @@ (define-command (guix-hash . args)
       (catch 'system-error
         (lambda _
           (with-error-handling
-            (serializer file algorithm select?)))
+            (let ((select? (if (assq-ref opts 'exclude-vcs?)
+                               (negate (vcs-file-predicate file))
+                               (const #t))))
+              (serializer file algorithm select?))))
         (lambda args
           (leave (G_ "~a ~a~%")
                  file

base-commit: aeb494322ca9dec4a4d66a7d063239c8536bd538
-- 
2.41.0