@@ -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 \
new file mode 100644
@@ -0,0 +1,73 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
+;;; Copyright © 2022 Maxime Devos <maximedevos@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.
+
+Symbolic links are only dereferenced if RECURSIVE? is false.
+Directories are only supported if RECURSIVE? is #true or 'auto'.
+The executable bit is only recorded if RECURSIVE? is #true.
+If FILE is a symbolic link, it is only followed if RECURSIVE? is false.
+
+For regular files, there are two different hashes when the executable
+hash isn't recorded: the regular hash and the nar hash. In most situations,
+the regular hash is desired and setting RECURSIVE? to 'auto' does the right
+thing for both regular files and directories.
+
+This procedure must only be used under controlled circumstances;
+the detection of symbolic links in FILE is racy.
+
+When FILE is a directory, the procedure SELECT? called as (SELECT? FILE STAT)
+decides which files to include. By default, version control files are
+excluded. To include everything, SELECT? can be set to (const #true)."
+ (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)))
@@ -4,6 +4,7 @@
;;; 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 Sarah Morgensen <iskarian@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)
From: Sarah Morgensen <iskarian@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@telenet.be> --- Makefile.am | 1 + guix/hash.scm | 73 +++++++++++++++++++++++++++++++++++++++++++ guix/scripts/hash.scm | 22 +++---------- 3 files changed, 78 insertions(+), 18 deletions(-) create mode 100644 guix/hash.scm base-commit: 9708681f1a9f221ae6cad64625ba8309b6742653