Package: guix-patches;
Reported by: Sarah Morgensen <iskarian <at> mgsn.dev>
Date: Sun, 15 Aug 2021 23:17:02 UTC
Severity: normal
Tags: patch
Done: Ludovic Courtès <ludo <at> gnu.org>
Bug is archived. No further changes may be made.
View this message in rfc822 format
From: Maxime Devos <maximedevos <at> telenet.be> To: 50072 <at> debbugs.gnu.org Cc: Ludovic Courtès <ludo <at> gnu.org>, Sarah Morgensen <iskarian <at> mgsn.dev>, Maxime Devos <maximedevos <at> telenet.be> Subject: [bug#50072] [PATCH v3 1/4] guix hash: Extract file hashing procedures. Date: Tue, 4 Jan 2022 15:09:34 +0000
From: Sarah Morgensen <iskarian <at> mgsn.dev>
* guix/scripts/hash.scm (guix-hash)[vcs-file?] (nar-hash, default-hash):
Extract hashing logic to...
* guix/hash.scm (vcs-file?, file-hash*): ... these new procedures in this
new file.
Modified-by: Maxime Devos <maximedevos <at> telenet.be>
---
Makefile.am | 1 +
guix/hash.scm | 68 +++++++++++++++++++++++++++++++++++++++++++
guix/scripts/hash.scm | 22 +++-----------
3 files changed, 73 insertions(+), 18 deletions(-)
create mode 100644 guix/hash.scm
diff --git a/Makefile.am b/Makefile.am
index 8c5682a1c6..bc3d0087d0 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -99,6 +99,7 @@ MODULES = \
guix/extracting-download.scm \
guix/git-download.scm \
guix/hg-download.scm \
+ guix/hash.scm \
guix/swh.scm \
guix/monads.scm \
guix/monad-repl.scm \
diff --git a/guix/hash.scm b/guix/hash.scm
new file mode 100644
index 0000000000..19cbc41ad1
--- /dev/null
+++ b/guix/hash.scm
@@ -0,0 +1,68 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021 Sarah Morgensen <iskarian <at> mgsn.dev>
+;;; Copyright © 2022 Maxime Devos <maximedevos <at> telenet.be>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix hash)
+ #:use-module (gcrypt hash)
+ #:use-module (guix serialization)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
+ #:export (vcs-file?
+ file-hash*))
+
+(define (vcs-file? file stat)
+ "Returns true if FILE is a version control system file."
+ (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* (file-hash* file #:key
+ (algorithm (hash-algorithm sha256))
+ (recursive? 'auto)
+ (select? (negate vcs-file?)))
+ "Compute the hash of FILE with ALGORITHM. If RECURSIVE? is #true or 'auto',
+recurse into subdirectories of FILE, computing the combined hash (nar hash) of
+all files for which (SELECT? FILE STAT) returns true.
+
+Symbolic links are not dereferenced unless RECURSIVE? is false.
+
+This procedure must only be used under controlled circumstances;
+the detection of symbolic links in FILE is racy.
+
+Keep in mind that the hash of a regular file depends on RECURSIVE?:
+if the recursive hash is desired, it must be set to #true. Otherwise, it must
+be set to #false or 'auto'. In most situations, the non-recursive hash is desired
+for regular files."
+ (if (or (eq? recursive? #true)
+ (and (eq? recursive? 'auto)
+ ;; Don't change this to (eq? 'directory ...), because otherwise
+ ;; if 'file' denotes a symbolic link, the 'file-hash' below
+ ;; would dereference it -- dereferencing symbolic links would
+ ;; open an avoidable can of potential worms.
+ (not (eq? 'regular (stat:type (lstat file))))))
+ (let-values (((port get-hash)
+ (open-hash-port algorithm)))
+ (write-file file port #:select? select?)
+ (force-output port)
+ (get-hash))
+ (file-hash algorithm file)))
diff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scm
index d73e3d13dd..28d587b944 100644
--- a/guix/scripts/hash.scm
+++ b/guix/scripts/hash.scm
@@ -4,6 +4,7 @@
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke <at> gnu.org>
;;; Copyright © 2018 Tim Gesthuizen <tim.gesthuizen <at> yahoo.de>
;;; Copyright © 2021 Simon Tournier <zimon.toutoune <at> gmail.com>
+;;; Copyright © 2021 Sarah Morgensen <iskarian <at> mgsn.dev>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -24,6 +25,7 @@
#:use-module (gcrypt hash)
#:use-module (guix serialization)
#:use-module (guix ui)
+ #:use-module (guix hash)
#:use-module (guix scripts)
#:use-module (guix base16)
#:use-module (guix base32)
@@ -46,20 +48,14 @@
(define* (nar-hash file #:optional
(algorithm (assoc-ref %default-options 'hash-algorithm))
select?)
- (let-values (((port get-hash)
- (open-hash-port algorithm)))
- (write-file file port #:select? select?)
- (force-output port)
- (get-hash)))
+ (file-hash* file #:algorithm algorithm #:select? select? #:recursive? #true))
(define* (default-hash file #:optional
(algorithm (assoc-ref %default-options 'hash-algorithm))
select?)
(match file
("-" (port-hash algorithm (current-input-port)))
- (_
- (call-with-input-file file
- (cute port-hash algorithm <>)))))
+ (_ (file-hash* file #:algorithm algorithm #:recursive? #false))))
(define* (git-hash file #:optional
(algorithm (assoc-ref %default-options 'hash-algorithm))
@@ -181,16 +177,6 @@ use '--serializer' instead~%"))
(parse-command-line args %options (list %default-options)
#:build-options? #f))
- (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)))
-
(let* ((opts (parse-options))
(args (filter-map (match-lambda
(('argument . value)
--
2.30.2
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.