You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 
 
 

170 lines
5.1 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2012, 2013, 2014 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. (define-module (guix hash)
  19. #:use-module (guix config)
  20. #:use-module (rnrs bytevectors)
  21. #:use-module (rnrs io ports)
  22. #:use-module (system foreign)
  23. #:use-module ((guix build utils) #:select (dump-port))
  24. #:use-module (srfi srfi-11)
  25. #:export (sha256
  26. open-sha256-port
  27. port-sha256
  28. open-sha256-input-port))
  29. ;;; Commentary:
  30. ;;;
  31. ;;; Cryptographic hashes.
  32. ;;;
  33. ;;; Code:
  34. ;;;
  35. ;;; Hash.
  36. ;;;
  37. (define-syntax GCRY_MD_SHA256
  38. ;; Value as of Libgcrypt 1.5.2.
  39. (identifier-syntax 8))
  40. (define sha256
  41. (let ((hash (pointer->procedure void
  42. (dynamic-func "gcry_md_hash_buffer"
  43. (dynamic-link %libgcrypt))
  44. `(,int * * ,size_t))))
  45. (lambda (bv)
  46. "Return the SHA256 of BV as a bytevector."
  47. (let ((digest (make-bytevector (/ 256 8))))
  48. (hash GCRY_MD_SHA256 (bytevector->pointer digest)
  49. (bytevector->pointer bv) (bytevector-length bv))
  50. digest))))
  51. (define open-sha256-md
  52. (let ((open (pointer->procedure int
  53. (dynamic-func "gcry_md_open"
  54. (dynamic-link %libgcrypt))
  55. `(* ,int ,unsigned-int))))
  56. (lambda ()
  57. (let* ((md (bytevector->pointer (make-bytevector (sizeof '*))))
  58. (err (open md GCRY_MD_SHA256 0)))
  59. (if (zero? err)
  60. (dereference-pointer md)
  61. (throw 'gcrypt-error err))))))
  62. (define md-write
  63. (pointer->procedure void
  64. (dynamic-func "gcry_md_write"
  65. (dynamic-link %libgcrypt))
  66. `(* * ,size_t)))
  67. (define md-read
  68. (pointer->procedure '*
  69. (dynamic-func "gcry_md_read"
  70. (dynamic-link %libgcrypt))
  71. `(* ,int)))
  72. (define md-close
  73. (pointer->procedure void
  74. (dynamic-func "gcry_md_close"
  75. (dynamic-link %libgcrypt))
  76. '(*)))
  77. (define (open-sha256-port)
  78. "Return two values: an output port, and a thunk. When the thunk is called,
  79. it returns the SHA256 hash (a bytevector) of all the data written to the
  80. output port."
  81. (define sha256-md
  82. (open-sha256-md))
  83. (define digest #f)
  84. (define (finalize!)
  85. (let ((ptr (md-read sha256-md 0)))
  86. (set! digest (bytevector-copy (pointer->bytevector ptr 32)))
  87. (md-close sha256-md)))
  88. (define (write! bv offset len)
  89. (if (zero? len)
  90. (begin
  91. (finalize!)
  92. 0)
  93. (let ((ptr (bytevector->pointer bv offset)))
  94. (md-write sha256-md ptr len)
  95. len)))
  96. (define (close)
  97. (unless digest
  98. (finalize!)))
  99. (values (make-custom-binary-output-port "sha256"
  100. write! #f #f
  101. close)
  102. (lambda ()
  103. (unless digest
  104. (finalize!))
  105. digest)))
  106. (define (port-sha256 port)
  107. "Return the SHA256 hash (a bytevector) of all the data drained from PORT."
  108. (let-values (((out get)
  109. (open-sha256-port)))
  110. (dump-port port out)
  111. (close-port out)
  112. (get)))
  113. (define (open-sha256-input-port port)
  114. "Return an input port that wraps PORT and a thunk to get the hash of all the
  115. data read from PORT. The thunk always returns the same value."
  116. (define md
  117. (open-sha256-md))
  118. (define (read! bv start count)
  119. (let ((n (get-bytevector-n! port bv start count)))
  120. (if (eof-object? n)
  121. 0
  122. (begin
  123. (unless digest
  124. (let ((ptr (bytevector->pointer bv start)))
  125. (md-write md ptr n)))
  126. n))))
  127. (define digest #f)
  128. (define (finalize!)
  129. (let ((ptr (md-read md 0)))
  130. (set! digest (bytevector-copy (pointer->bytevector ptr 32)))
  131. (md-close md)))
  132. (define (get-hash)
  133. (unless digest
  134. (finalize!))
  135. digest)
  136. (define (unbuffered port)
  137. ;; Guile <= 2.0.9 does not support 'setvbuf' on custom binary input ports.
  138. ;; If you get a wrong-type-arg error here, the fix is to upgrade Guile. :-)
  139. (setvbuf port _IONBF)
  140. port)
  141. (values (unbuffered (make-custom-binary-input-port "sha256" read! #f #f #f))
  142. get-hash))
  143. ;;; hash.scm ends here