Commit | Line | Data |
---|---|---|
72626a71 | 1 | ;;; GNU Guix --- Functional package management for GNU |
19a45444 | 2 | ;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> |
72626a71 LC |
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) | |
19a45444 | 20 | #:use-module (guix gcrypt) |
72626a71 | 21 | #:use-module (rnrs bytevectors) |
69927e78 | 22 | #:use-module (rnrs io ports) |
72626a71 | 23 | #:use-module (system foreign) |
69927e78 LC |
24 | #:use-module ((guix build utils) #:select (dump-port)) |
25 | #:use-module (srfi srfi-11) | |
26 | #:export (sha256 | |
27 | open-sha256-port | |
045111e1 | 28 | port-sha256 |
1ff2619b | 29 | file-sha256 |
045111e1 | 30 | open-sha256-input-port)) |
72626a71 LC |
31 | |
32 | ;;; Commentary: | |
33 | ;;; | |
34 | ;;; Cryptographic hashes. | |
35 | ;;; | |
36 | ;;; Code: | |
37 | ||
38 | \f | |
39 | ;;; | |
40 | ;;; Hash. | |
41 | ;;; | |
42 | ||
69927e78 LC |
43 | (define-syntax GCRY_MD_SHA256 |
44 | ;; Value as of Libgcrypt 1.5.2. | |
45 | (identifier-syntax 8)) | |
46 | ||
72626a71 | 47 | (define sha256 |
69927e78 | 48 | (let ((hash (pointer->procedure void |
19a45444 | 49 | (libgcrypt-func "gcry_md_hash_buffer") |
69927e78 | 50 | `(,int * * ,size_t)))) |
72626a71 LC |
51 | (lambda (bv) |
52 | "Return the SHA256 of BV as a bytevector." | |
53 | (let ((digest (make-bytevector (/ 256 8)))) | |
69927e78 | 54 | (hash GCRY_MD_SHA256 (bytevector->pointer digest) |
72626a71 LC |
55 | (bytevector->pointer bv) (bytevector-length bv)) |
56 | digest)))) | |
57 | ||
69927e78 LC |
58 | (define open-sha256-md |
59 | (let ((open (pointer->procedure int | |
19a45444 | 60 | (libgcrypt-func "gcry_md_open") |
69927e78 LC |
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 | |
19a45444 | 71 | (libgcrypt-func "gcry_md_write") |
69927e78 LC |
72 | `(* * ,size_t))) |
73 | ||
74 | (define md-read | |
75 | (pointer->procedure '* | |
19a45444 | 76 | (libgcrypt-func "gcry_md_read") |
69927e78 LC |
77 | `(* ,int))) |
78 | ||
79 | (define md-close | |
80 | (pointer->procedure void | |
19a45444 | 81 | (libgcrypt-func "gcry_md_close") |
69927e78 LC |
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 | ||
1ff2619b EB |
128 | (define (file-sha256 file) |
129 | "Return the SHA256 hash (a bytevector) of FILE." | |
130 | (call-with-input-file file port-sha256)) | |
131 | ||
045111e1 LC |
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 | ||
72626a71 | 169 | ;;; hash.scm ends here |