diff options
Diffstat (limited to 'guix/scripts/hash.scm')
| -rw-r--r-- | guix/scripts/hash.scm | 116 |
1 files changed, 78 insertions, 38 deletions
diff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scm index b8622373cc..4e792c6a03 100644 --- a/guix/scripts/hash.scm +++ b/guix/scripts/hash.scm @@ -1,8 +1,10 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2016, 2017, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012-2014, 2016-2017, 2020-2022 Ludovic Courtès <ludo@gnu.org> ;;; 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 Sarah Morgensen <iskarian@mgsn.dev> ;;; ;;; This file is part of GNU Guix. ;;; @@ -23,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) @@ -34,17 +37,47 @@ #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-37) + #:autoload (disarchive git-hash) (git-hash-file git-hash-directory) #:export (guix-hash)) ;;; +;;; Serializers +;;; + +(define* (nar-hash file #:optional + (algorithm (assoc-ref %default-options 'hash-algorithm)) + select?) + (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))) + (_ (file-hash* file #:algorithm algorithm #:recursive? #false)))) + +(define* (git-hash file #:optional + (algorithm (assoc-ref %default-options 'hash-algorithm)) + select?) + (define directory? + (case (stat:type (stat file)) + ((directory) #t) + (else #f))) + (if directory? + (git-hash-directory file algorithm #:select? select?) + (git-hash-file file algorithm))) + + +;;; ;;; Command-line options. ;;; (define %default-options ;; Alist of default option values. `((format . ,bytevector->nix-base32-string) - (hash-algorithm . ,(hash-algorithm sha256)))) + (hash-algorithm . ,(hash-algorithm sha256)) + (serializer . ,default-hash))) (define (show-help) (display (G_ "Usage: guix hash [OPTION] FILE @@ -60,7 +93,7 @@ and 'base16' ('hex' and 'hexadecimal' can be used as well).\n")) (format #t (G_ " -f, --format=FMT write the hash in the given format")) (format #t (G_ " - -r, --recursive compute the hash on FILE recursively")) + -S, --serializer=TYPE compute the hash on FILE according to TYPE serialization")) (newline) (display (G_ " -h, --help display this help and exit")) @@ -101,7 +134,27 @@ and 'base16' ('hex' and 'hexadecimal' can be used as well).\n")) (alist-delete 'format result)))) (option '(#\r "recursive") #f #f (lambda (opt name arg result) - (alist-cons 'recursive? #t result))) + (unless (eqv? name #\r) + (warning (G_ "'--recursive' is deprecated, \ +use '--serializer=nar' instead~%"))) + (alist-cons 'serializer nar-hash + (alist-delete 'serializer result)))) + (option '(#\S "serializer") #t #f + (lambda (opt name arg result) + (define serializer-proc + (match arg + ("none" + default-hash) + ("nar" + nar-hash) + ("git" + git-hash) + (x + (leave (G_ "unsupported serializer type: ~a~%") + arg)))) + + (alist-cons 'serializer serializer-proc + (alist-delete 'serializer result)))) (option '(#\h "help") #f #f (lambda args (show-help) @@ -125,16 +178,6 @@ and 'base16' ('hex' and 'hexadecimal' can be used as well).\n")) (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) @@ -144,32 +187,29 @@ and 'base16' ('hex' and 'hexadecimal' can be used as well).\n")) (fmt (assq-ref opts 'format)) (select? (if (assq-ref opts 'exclude-vcs?) (negate vcs-file?) - (const #t)))) + (const #t))) + (algorithm (assoc-ref opts 'hash-algorithm)) + (serializer (assoc-ref opts 'serializer))) (define (file-hash file) ;; Compute the hash of FILE. - ;; Catch and gracefully report possible '&nar-error' conditions. - (with-error-handling - (if (assoc-ref opts 'recursive?) - (let-values (((port get-hash) - (open-hash-port (assoc-ref opts 'hash-algorithm)))) - (write-file file port #:select? select?) - (force-output port) - (get-hash)) - (match file - ("-" (port-hash (assoc-ref opts 'hash-algorithm) - (current-input-port))) - (_ (call-with-input-file file - (cute port-hash (assoc-ref opts 'hash-algorithm) - <>))))))) + ;; Catch and gracefully report possible error + (catch 'system-error + (lambda _ + (with-error-handling + (serializer file algorithm select?))) + (lambda args + (leave (G_ "~a ~a~%") + file + (strerror (system-error-errno args)))))) + + (define (formatted-hash thing) + (fmt (file-hash thing))) (match args - ((file) - (catch 'system-error - (lambda () - (format #t "~a~%" (fmt (file-hash file)))) - (lambda args - (leave (G_ "~a~%") - (strerror (system-error-errno args)))))) - (x - (leave (G_ "wrong number of arguments~%")))))) + (() + (leave (G_ "no arguments specified~%"))) + (_ + (for-each + (compose (cute format #t "~a~%" <>) formatted-hash) + args))))) |