guix/hash.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (guix hash)
  20   #:use-module (guix gcrypt)
  21   #:use-module (rnrs bytevectors)
  22   #:use-module (rnrs io ports)
  23   #:use-module (system foreign)
  24   #:use-module ((guix build utils) #:select (dump-port))
  25   #:use-module (srfi srfi-11)
  26   #:export (sha256
  27             open-sha256-port
  28             port-sha256
  29             file-sha256
  30             open-sha256-input-port))
  31
  32 ;;; Commentary:
  33 ;;;
  34 ;;; Cryptographic hashes.
  35 ;;;
  36 ;;; Code:
  37
  38 \f
  39 ;;;
  40 ;;; Hash.
  41 ;;;
  42
  43 (define-syntax GCRY_MD_SHA256
  44   ;; Value as of Libgcrypt 1.5.2.
  45   (identifier-syntax 8))
  46
  47 (define sha256
  48   (let ((hash (pointer->procedure void
  49                                   (libgcrypt-func "gcry_md_hash_buffer")
  50                                   `(,int * * ,size_t))))
  51     (lambda (bv)
  52       "Return the SHA256 of BV as a bytevector."
  53       (let ((digest (make-bytevector (/ 256 8))))
  54         (hash GCRY_MD_SHA256 (bytevector->pointer digest)
  55               (bytevector->pointer bv) (bytevector-length bv))
  56         digest))))
  57
  58 (define open-sha256-md
  59   (let ((open (pointer->procedure int
  60                                   (libgcrypt-func "gcry_md_open")
  61                                   `(* ,int ,unsigned-int))))
  62     (lambda ()
  63       (let* ((md  (bytevector->pointer (make-bytevector (sizeof '*))))
  64              (err (open md GCRY_MD_SHA256 0)))
  65         (if (zero? err)
  66             (dereference-pointer md)
  67             (throw 'gcrypt-error err))))))
  68
  69 (define md-write
  70   (pointer->procedure void
  71                       (libgcrypt-func "gcry_md_write")
  72                       `(* * ,size_t)))
  73
  74 (define md-read
  75   (pointer->procedure '*
  76                       (libgcrypt-func "gcry_md_read")
  77                       `(* ,int)))
  78
  79 (define md-close
  80   (pointer->procedure void
  81                       (libgcrypt-func "gcry_md_close")
  82                       '(*)))
  83
  84
  85 (define (open-sha256-port)
  86   "Return two values: an output port, and a thunk.  When the thunk is called,
  87 it returns the SHA256 hash (a bytevector) of all the data written to the
  88 output port."
  89   (define sha256-md
  90     (open-sha256-md))
  91
  92   (define digest #f)
  93
  94   (define (finalize!)
  95     (let ((ptr (md-read sha256-md 0)))
  96       (set! digest (bytevector-copy (pointer->bytevector ptr 32)))
  97       (md-close sha256-md)))
  98
  99   (define (write! bv offset len)
 100     (if (zero? len)
 101         (begin
 102           (finalize!)
 103           0)
 104         (let ((ptr (bytevector->pointer bv offset)))
 105           (md-write sha256-md ptr len)
 106           len)))
 107
 108   (define (close)
 109     (unless digest
 110       (finalize!)))
 111
 112   (values (make-custom-binary-output-port "sha256"
 113                                           write! #f #f
 114                                           close)
 115           (lambda ()
 116             (unless digest
 117               (finalize!))
 118             digest)))
 119
 120 (define (port-sha256 port)
 121   "Return the SHA256 hash (a bytevector) of all the data drained from PORT."
 122   (let-values (((out get)
 123                 (open-sha256-port)))
 124     (dump-port port out)
 125     (close-port out)
 126     (get)))
 127
 128 (define (file-sha256 file)
 129   "Return the SHA256 hash (a bytevector) of FILE."
 130   (call-with-input-file file port-sha256))
 131
 132 (define (open-sha256-input-port port)
 133   "Return an input port that wraps PORT and a thunk to get the hash of all the
 134 data read from PORT.  The thunk always returns the same value."
 135   (define md
 136     (open-sha256-md))
 137
 138   (define (read! bv start count)
 139     (let ((n (get-bytevector-n! port bv start count)))
 140       (if (eof-object? n)
 141           0
 142           (begin
 143             (unless digest
 144               (let ((ptr (bytevector->pointer bv start)))
 145                 (md-write md ptr n)))
 146             n))))
 147
 148   (define digest #f)
 149
 150   (define (finalize!)
 151     (let ((ptr (md-read md 0)))
 152       (set! digest (bytevector-copy (pointer->bytevector ptr 32)))
 153       (md-close md)))
 154
 155   (define (get-hash)
 156     (unless digest
 157       (finalize!))
 158     digest)
 159
 160   (define (unbuffered port)
 161     ;; Guile <= 2.0.9 does not support 'setvbuf' on custom binary input ports.
 162     ;; If you get a wrong-type-arg error here, the fix is to upgrade Guile.  :-)
 163     (setvbuf port _IONBF)
 164     port)
 165
 166   (values (unbuffered (make-custom-binary-input-port "sha256" read! #f #f #f))
 167           get-hash))
 168
 169 ;;; hash.scm ends here