Commit | Line | Data |
---|---|---|
72626a71 | 1 | ;;; GNU Guix --- Functional package management for GNU |
1d84d7bf | 2 | ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018 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) |
2535635f | 22 | #:use-module (ice-9 binary-ports) |
72626a71 | 23 | #:use-module (system foreign) |
69927e78 LC |
24 | #:use-module ((guix build utils) #:select (dump-port)) |
25 | #:use-module (srfi srfi-11) | |
33286075 LC |
26 | #:use-module (srfi srfi-26) |
27 | #:export (sha1 | |
28 | sha256 | |
69927e78 | 29 | open-sha256-port |
045111e1 | 30 | port-sha256 |
1ff2619b | 31 | file-sha256 |
045111e1 | 32 | open-sha256-input-port)) |
72626a71 LC |
33 | |
34 | ;;; Commentary: | |
35 | ;;; | |
36 | ;;; Cryptographic hashes. | |
37 | ;;; | |
38 | ;;; Code: | |
39 | ||
40 | \f | |
41 | ;;; | |
42 | ;;; Hash. | |
43 | ;;; | |
44 | ||
69927e78 LC |
45 | (define-syntax GCRY_MD_SHA256 |
46 | ;; Value as of Libgcrypt 1.5.2. | |
47 | (identifier-syntax 8)) | |
48 | ||
33286075 LC |
49 | (define-syntax GCRY_MD_SHA1 |
50 | (identifier-syntax 2)) | |
51 | ||
52 | (define bytevector-hash | |
69927e78 | 53 | (let ((hash (pointer->procedure void |
19a45444 | 54 | (libgcrypt-func "gcry_md_hash_buffer") |
69927e78 | 55 | `(,int * * ,size_t)))) |
33286075 LC |
56 | (lambda (bv type size) |
57 | "Return the hash TYPE, of SIZE bytes, of BV as a bytevector." | |
58 | (let ((digest (make-bytevector size))) | |
59 | (hash type (bytevector->pointer digest) | |
72626a71 LC |
60 | (bytevector->pointer bv) (bytevector-length bv)) |
61 | digest)))) | |
62 | ||
33286075 LC |
63 | (define sha1 |
64 | (cut bytevector-hash <> GCRY_MD_SHA1 20)) | |
65 | ||
66 | (define sha256 | |
67 | (cut bytevector-hash <> GCRY_MD_SHA256 (/ 256 8))) | |
68 | ||
69927e78 LC |
69 | (define open-sha256-md |
70 | (let ((open (pointer->procedure int | |
19a45444 | 71 | (libgcrypt-func "gcry_md_open") |
69927e78 LC |
72 | `(* ,int ,unsigned-int)))) |
73 | (lambda () | |
74 | (let* ((md (bytevector->pointer (make-bytevector (sizeof '*)))) | |
75 | (err (open md GCRY_MD_SHA256 0))) | |
76 | (if (zero? err) | |
77 | (dereference-pointer md) | |
78 | (throw 'gcrypt-error err)))))) | |
79 | ||
80 | (define md-write | |
81 | (pointer->procedure void | |
19a45444 | 82 | (libgcrypt-func "gcry_md_write") |
69927e78 LC |
83 | `(* * ,size_t))) |
84 | ||
85 | (define md-read | |
86 | (pointer->procedure '* | |
19a45444 | 87 | (libgcrypt-func "gcry_md_read") |
69927e78 LC |
88 | `(* ,int))) |
89 | ||
90 | (define md-close | |
91 | (pointer->procedure void | |
19a45444 | 92 | (libgcrypt-func "gcry_md_close") |
69927e78 LC |
93 | '(*))) |
94 | ||
95 | ||
96 | (define (open-sha256-port) | |
97 | "Return two values: an output port, and a thunk. When the thunk is called, | |
98 | it returns the SHA256 hash (a bytevector) of all the data written to the | |
99 | output port." | |
100 | (define sha256-md | |
101 | (open-sha256-md)) | |
102 | ||
103 | (define digest #f) | |
104 | ||
105 | (define (finalize!) | |
106 | (let ((ptr (md-read sha256-md 0))) | |
107 | (set! digest (bytevector-copy (pointer->bytevector ptr 32))) | |
108 | (md-close sha256-md))) | |
109 | ||
110 | (define (write! bv offset len) | |
111 | (if (zero? len) | |
112 | (begin | |
113 | (finalize!) | |
114 | 0) | |
115 | (let ((ptr (bytevector->pointer bv offset))) | |
116 | (md-write sha256-md ptr len) | |
117 | len))) | |
118 | ||
119 | (define (close) | |
120 | (unless digest | |
121 | (finalize!))) | |
122 | ||
123 | (values (make-custom-binary-output-port "sha256" | |
124 | write! #f #f | |
125 | close) | |
126 | (lambda () | |
127 | (unless digest | |
128 | (finalize!)) | |
129 | digest))) | |
130 | ||
131 | (define (port-sha256 port) | |
132 | "Return the SHA256 hash (a bytevector) of all the data drained from PORT." | |
133 | (let-values (((out get) | |
134 | (open-sha256-port))) | |
135 | (dump-port port out) | |
136 | (close-port out) | |
137 | (get))) | |
138 | ||
1ff2619b EB |
139 | (define (file-sha256 file) |
140 | "Return the SHA256 hash (a bytevector) of FILE." | |
141 | (call-with-input-file file port-sha256)) | |
142 | ||
045111e1 LC |
143 | (define (open-sha256-input-port port) |
144 | "Return an input port that wraps PORT and a thunk to get the hash of all the | |
145 | data read from PORT. The thunk always returns the same value." | |
146 | (define md | |
147 | (open-sha256-md)) | |
148 | ||
149 | (define (read! bv start count) | |
150 | (let ((n (get-bytevector-n! port bv start count))) | |
151 | (if (eof-object? n) | |
152 | 0 | |
153 | (begin | |
154 | (unless digest | |
155 | (let ((ptr (bytevector->pointer bv start))) | |
156 | (md-write md ptr n))) | |
157 | n)))) | |
158 | ||
159 | (define digest #f) | |
160 | ||
161 | (define (finalize!) | |
162 | (let ((ptr (md-read md 0))) | |
163 | (set! digest (bytevector-copy (pointer->bytevector ptr 32))) | |
164 | (md-close md))) | |
165 | ||
166 | (define (get-hash) | |
167 | (unless digest | |
168 | (finalize!)) | |
169 | digest) | |
170 | ||
171 | (define (unbuffered port) | |
172 | ;; Guile <= 2.0.9 does not support 'setvbuf' on custom binary input ports. | |
045111e1 LC |
173 | (setvbuf port _IONBF) |
174 | port) | |
175 | ||
176 | (values (unbuffered (make-custom-binary-input-port "sha256" read! #f #f #f)) | |
177 | get-hash)) | |
178 | ||
72626a71 | 179 | ;;; hash.scm ends here |