hash.scm 5.2 KB

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