[bug#50072] [PATCH WIP 2/4] import: Factorize file hashing.

[Sarah Morgensen]

* guix/import/cran.scm (vcs-file?, file-hash): Remove procedures.
(description->package): Use 'file-hash*' instead.
* guix/import/elpa.scm (vcs-file?, file-hash): Remove procedures.
(git-repository->origin, elpa-package->sexp): Use 'file-hash* instead'.
* guix/import/go.scm (vcs-file?, file-hash): Remove procedures.
(git-checkout-hash): Use 'file-hash*' instead.
---
 guix/import/cran.scm | 32 +++-----------------------------
 guix/import/elpa.scm | 28 ++++------------------------
 guix/import/go.scm   | 26 +++-----------------------
 3 files changed, 10 insertions(+), 76 deletions(-)

diff --git a/guix/import/cran.scm b/guix/import/cran.scm
index f649928c5a..ac24bc117e 100644
--- a/guix/import/cran.scm
+++ b/guix/import/cran.scm
@@ -3,6 +3,7 @@
 ;;; Copyright © 2015, 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net>
+;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -34,9 +35,8 @@
   #:use-module (web uri)
   #:use-module (guix memoization)
   #:use-module (guix http-client)
-  #:use-module (gcrypt hash)
+  #:use-module (guix hash)
   #:use-module (guix store)
-  #:use-module ((guix serialization) #:select (write-file))
   #:use-module (guix base32)
   #:use-module ((guix download) #:select (download-to-store))
   #:use-module (guix import utils)
@@ -194,17 +194,6 @@ bioconductor package NAME, or #F if the package is 
unknown."
                (bioconductor-packages-list type))
          (cut assoc-ref <> "Version")))
 
-;; XXX taken from (guix scripts hash)
-(define (vcs-file? file stat)
-  (case (stat:type stat)
-    ((directory)
-     (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS")))
-    ((regular)
-     ;; Git sub-modules have a '.git' file that is a regular text file.
-     (string=? (basename file) ".git"))
-    (else
-     #f)))
-
 ;; Little helper to download URLs only once.
 (define download
   (memoize
@@ -437,16 +426,6 @@ reference the pkg-config tool."
 (define (needs-knitr? meta)
   (member "knitr" (listify meta "VignetteBuilder")))
 
-;; XXX adapted from (guix scripts hash)
-(define (file-hash file select? recursive?)
-  ;; Compute the hash of FILE.
-  (if recursive?
-      (let-values (((port get-hash) (open-sha256-port)))
-        (write-file file port #:select? select?)
-        (force-output port)
-        (get-hash))
-      (call-with-input-file file port-sha256)))
-
 (define (description->package repository meta)
   "Return the `package' s-expression for an R package published on REPOSITORY
 from the alist META, which was derived from the R package's DESCRIPTION file."
@@ -544,12 +523,7 @@ from the alist META, which was derived from the R 
package's DESCRIPTION file."
                         (sha256
                          (base32
                           ,(bytevector->nix-base32-string
-                            (case repository
-                              ((git)
-                               (file-hash source (negate vcs-file?) #t))
-                              ((hg)
-                               (file-hash source (negate vcs-file?) #t))
-                              (else (file-sha256 source))))))))
+                            (file-hash* source))))))
               ,@(if (not (and git? hg?
                               (equal? (string-append "r-" name)
                                       (cran-guix-name name))))
diff --git a/guix/import/elpa.scm b/guix/import/elpa.scm
index c0dc5acf51..22c937ca5f 100644
--- a/guix/import/elpa.scm
+++ b/guix/import/elpa.scm
@@ -4,6 +4,7 @@
 ;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com>
 ;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net>
 ;;; Copyright © 2020 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -36,10 +37,10 @@
   #:use-module (guix import utils)
   #:use-module (guix http-client)
   #:use-module (guix git)
+  #:use-module (guix hash)
   #:use-module ((guix serialization) #:select (write-file))
   #:use-module (guix store)
   #:use-module (guix ui)
-  #:use-module (gcrypt hash)
   #:use-module (guix base32)
   #:use-module (guix upstream)
   #:use-module (guix packages)
@@ -226,27 +227,6 @@ keywords to values."
     (close-port port)
     (data->recipe (cons ':name data))))
 
-;; XXX adapted from (guix scripts hash)
-(define (file-hash file select? recursive?)
-  ;; Compute the hash of FILE.
-  (if recursive?
-      (let-values (((port get-hash) (open-sha256-port)))
-        (write-file file port #:select? select?)
-        (force-output port)
-        (get-hash))
-      (call-with-input-file file port-sha256)))
-
-;; XXX taken from (guix scripts hash)
-(define (vcs-file? file stat)
-  (case (stat:type stat)
-    ((directory)
-     (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS")))
-    ((regular)
-     ;; Git sub-modules have a '.git' file that is a regular text file.
-     (string=? (basename file) ".git"))
-    (else
-     #f)))
-
 (define (git-repository->origin recipe url)
   "Fetch origin details from the Git repository at URL for the provided MELPA
 RECIPE."
@@ -268,7 +248,7 @@ RECIPE."
        (sha256
         (base32
          ,(bytevector->nix-base32-string
-           (file-hash directory (negate vcs-file?) #t)))))))
+           (file-hash* directory)))))))
 
 (define* (melpa-recipe->origin recipe)
   "Fetch origin details from the MELPA recipe and associated repository for
@@ -379,7 +359,7 @@ type '<elpa-package>'."
                         (sha256
                          (base32
                           ,(if tarball
-                               (bytevector->nix-base32-string (file-sha256 
tarball))
+                               (bytevector->nix-base32-string (file-hash* 
tarball))
                                "failed to download package")))))))
       (build-system emacs-build-system)
       ,@(maybe-inputs 'propagated-inputs dependencies)
diff --git a/guix/import/go.scm b/guix/import/go.scm
index 617a0d0e23..c6425667f8 100644
--- a/guix/import/go.scm
+++ b/guix/import/go.scm
@@ -25,6 +25,7 @@
 (define-module (guix import go)
   #:use-module (guix build-system go)
   #:use-module (guix git)
+  #:use-module (guix hash)
   #:use-module (guix i18n)
   #:use-module (guix diagnostics)
   #:use-module (guix import utils)
@@ -35,9 +36,7 @@
   #:use-module ((guix licenses) #:prefix license:)
   #:use-module (guix memoization)
   #:autoload   (htmlprag) (html->sxml)            ;from Guile-Lib
-  #:autoload   (guix git) (update-cached-checkout)
-  #:autoload   (gcrypt hash) (open-hash-port hash-algorithm sha256)
-  #:autoload   (guix serialization) (write-file)
+  #:autoload   (gcrypt hash) (hash-algorithm sha256)
   #:autoload   (guix base32) (bytevector->nix-base32-string)
   #:autoload   (guix build utils) (mkdir-p)
   #:use-module (ice-9 match)
@@ -494,25 +493,6 @@ source."
       goproxy
       (module-meta-repo-root meta-data)))
 
-;; XXX: Copied from (guix scripts hash).
-(define (vcs-file? file stat)
-  (case (stat:type stat)
-    ((directory)
-     (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS")))
-    ((regular)
-     ;; Git sub-modules have a '.git' file that is a regular text file.
-     (string=? (basename file) ".git"))
-    (else
-     #f)))
-
-;; XXX: Adapted from 'file-hash' in (guix scripts hash).
-(define* (file-hash file #:optional (algorithm (hash-algorithm sha256)))
-  ;; Compute the hash of FILE.
-  (let-values (((port get-hash) (open-hash-port algorithm)))
-    (write-file file port #:select? (negate vcs-file?))
-    (force-output port)
-    (get-hash)))
-
 (define* (git-checkout-hash url reference algorithm)
   "Return the ALGORITHM hash of the checkout of URL at REFERENCE, a commit or
 tag."
@@ -531,7 +511,7 @@ tag."
                   (update-cached-checkout url
                                           #:ref
                                           `(tag-or-commit . ,reference)))))
-    (file-hash checkout algorithm)))
+    (file-hash* checkout #:algorithm algorithm)))
 
 (define (vcs->origin vcs-type vcs-repo-url version)
   "Generate the `origin' block of a package depending on what type of source
-- 
2.31.1