guix/scripts/hash.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
   4 ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
   5 ;;; Copyright © 2018 Tim Gesthuizen <tim.gesthuizen@yahoo.de>
   6 ;;;
   7 ;;; This file is part of GNU Guix.
   8 ;;;
   9 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  10 ;;; under the terms of the GNU General Public License as published by
  11 ;;; the Free Software Foundation; either version 3 of the License, or (at
  12 ;;; your option) any later version.
  13 ;;;
  14 ;;; GNU Guix is distributed in the hope that it will be useful, but
  15 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;;; GNU General Public License for more details.
  18 ;;;
  19 ;;; You should have received a copy of the GNU General Public License
  20 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  21
  22 (define-module (guix scripts hash)
  23   #:use-module (guix base32)
  24   #:use-module (gcrypt hash)
  25   #:use-module (guix serialization)
  26   #:use-module (guix ui)
  27   #:use-module (guix scripts)
  28   #:use-module (guix base16)
  29   #:use-module (ice-9 binary-ports)
  30   #:use-module (rnrs files)
  31   #:use-module (ice-9 match)
  32   #:use-module (srfi srfi-1)
  33   #:use-module (srfi srfi-11)
  34   #:use-module (srfi srfi-26)
  35   #:use-module (srfi srfi-37)
  36   #:export (guix-hash))
  37
  38 \f
  39 ;;;
  40 ;;; Command-line options.
  41 ;;;
  42
  43 (define %default-options
  44   ;; Alist of default option values.
  45   `((format . ,bytevector->nix-base32-string)))
  46
  47 (define (show-help)
  48   (display (G_ "Usage: guix hash [OPTION] FILE
  49 Return the cryptographic hash of FILE.
  50
  51 Supported formats: 'nix-base32' (default), 'base32', and 'base16' ('hex'
  52 and 'hexadecimal' can be used as well).\n"))
  53   (format #t (G_ "
  54   -x, --exclude-vcs      exclude version control directories"))
  55   (format #t (G_ "
  56   -f, --format=FMT       write the hash in the given format"))
  57   (format #t (G_ "
  58   -r, --recursive        compute the hash on FILE recursively"))
  59   (newline)
  60   (display (G_ "
  61   -h, --help             display this help and exit"))
  62   (display (G_ "
  63   -V, --version          display version information and exit"))
  64   (newline)
  65   (show-bug-report-information))
  66
  67 (define %options
  68   ;; Specification of the command-line options.
  69   (list (option '(#\x "exclude-vcs") #f #f
  70                 (lambda (opt name arg result)
  71                   (alist-cons 'exclude-vcs? #t result)))
  72         (option '(#\f "format") #t #f
  73                 (lambda (opt name arg result)
  74                   (define fmt-proc
  75                     (match arg
  76                       ("nix-base32"
  77                        bytevector->nix-base32-string)
  78                       ("base32"
  79                        bytevector->base32-string)
  80                       ((or "base16" "hex" "hexadecimal")
  81                        bytevector->base16-string)
  82                       (x
  83                        (leave (G_ "unsupported hash format: ~a~%")
  84                               arg))))
  85
  86                   (alist-cons 'format fmt-proc
  87                               (alist-delete 'format result))))
  88         (option '(#\r "recursive") #f #f
  89                 (lambda (opt name arg result)
  90                   (alist-cons 'recursive? #t result)))
  91         (option '(#\h "help") #f #f
  92                 (lambda args
  93                   (show-help)
  94                   (exit 0)))
  95         (option '(#\V "version") #f #f
  96                 (lambda args
  97                   (show-version-and-exit "guix hash")))))
  98
  99
 100 \f
 101 ;;;
 102 ;;; Entry point.
 103 ;;;
 104
 105 (define (guix-hash . args)
 106   (define (parse-options)
 107     ;; Return the alist of option values.
 108     (parse-command-line args %options (list %default-options)
 109                         #:build-options? #f))
 110
 111   (define (vcs-file? file stat)
 112     (case (stat:type stat)
 113       ((directory)
 114        (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS")))
 115       ((regular)
 116        ;; Git sub-modules have a '.git' file that is a regular text file.
 117        (string=? (basename file) ".git"))
 118       (else
 119        #f)))
 120
 121   (let* ((opts (parse-options))
 122          (args (filter-map (match-lambda
 123                             (('argument . value)
 124                              value)
 125                             (_ #f))
 126                            (reverse opts)))
 127          (fmt  (assq-ref opts 'format))
 128          (select? (if (assq-ref opts 'exclude-vcs?)
 129                       (negate vcs-file?)
 130                       (const #t))))
 131
 132     (define (file-hash file)
 133       ;; Compute the hash of FILE.
 134       ;; Catch and gracefully report possible '&nar-error' conditions.
 135       (with-error-handling
 136         (if (assoc-ref opts 'recursive?)
 137             (let-values (((port get-hash) (open-sha256-port)))
 138               (write-file file port #:select? select?)
 139               (force-output port)
 140               (get-hash))
 141             (match file
 142               ("-" (port-sha256 (current-input-port)))
 143               (_   (call-with-input-file file port-sha256))))))
 144
 145     (match args
 146       ((file)
 147        (catch 'system-error
 148          (lambda ()
 149            (format #t "~a~%" (fmt (file-hash file))))
 150          (lambda args
 151            (leave (G_ "~a~%")
 152                   (strerror (system-error-errno args))))))
 153       (x
 154        (leave (G_ "wrong number of arguments~%"))))))