ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 07:26:13 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

guix hash: Extract file hashing procedures.

Browse source 
* 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>
Signed-off-by: Ludovic Courtès <ludo@gnu.org>
This commit is contained in:
Sarah Morgensen 2022-01-05 14:07:47 +00:00 committed by Ludovic Courtès
parent 0701efb351
commit 064c367716
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
3 changed files with 78 additions and 18 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
Makefile.am
View file

@ -100,6 +100,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 \

73
guix/hash.scm Normal file
View file

@ -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)))

22
guix/scripts/hash.scm
View 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 @@ (define-module (guix scripts hash)
#: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-module (guix scripts hash)
(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 @@ (define (parse-options)
(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)