Commit | Line | Data |
---|---|---|
72626a71 | 1 | ;;; GNU Guix --- Functional package management for GNU |
045111e1 | 2 | ;;; Copyright © 2012, 2013, 2014 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) | |
20 | #:use-module (guix config) | |
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 LC |
28 | port-sha256 |
29 | open-sha256-input-port)) | |
72626a71 LC |
30 | |
31 | ;;; Commentary: | |
32 | ;;; | |
33 | ;;; Cryptographic hashes. | |
34 | ;;; | |
35 | ;;; Code: | |
36 | ||
37 | \f | |
38 | ;;; | |
39 | ;;; Hash. | |
40 | ;;; | |
41 | ||
69927e78 LC |
42 | (define-syntax GCRY_MD_SHA256 |
43 | ;; Value as of Libgcrypt 1.5.2. | |
44 | (identifier-syntax 8)) | |
45 | ||
72626a71 | 46 | (define sha256 |
69927e78 LC |
47 | (let ((hash (pointer->procedure void |
48 | (dynamic-func "gcry_md_hash_buffer" | |
49 | (dynamic-link %libgcrypt)) | |
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 | |
60 | (dynamic-func "gcry_md_open" | |
61 | (dynamic-link %libgcrypt)) | |
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 | ||
70 | (define md-write | |
71 | (pointer->procedure void | |
72 | (dynamic-func "gcry_md_write" | |
73 | (dynamic-link %libgcrypt)) | |
74 | `(* * ,size_t))) | |
75 | ||
76 | (define md-read | |
77 | (pointer->procedure '* | |
78 | (dynamic-func "gcry_md_read" | |
79 | (dynamic-link %libgcrypt)) | |
80 | `(* ,int))) | |
81 | ||
82 | (define md-close | |
83 | (pointer->procedure void | |
84 | (dynamic-func "gcry_md_close" | |
85 | (dynamic-link %libgcrypt)) | |
86 | '(*))) | |
87 | ||
88 | ||
89 | (define (open-sha256-port) | |
90 | "Return two values: an output port, and a thunk. When the thunk is called, | |
91 | it returns the SHA256 hash (a bytevector) of all the data written to the | |
92 | output port." | |
93 | (define sha256-md | |
94 | (open-sha256-md)) | |
95 | ||
96 | (define digest #f) | |
97 | ||
98 | (define (finalize!) | |
99 | (let ((ptr (md-read sha256-md 0))) | |
100 | (set! digest (bytevector-copy (pointer->bytevector ptr 32))) | |
101 | (md-close sha256-md))) | |
102 | ||
103 | (define (write! bv offset len) | |
104 | (if (zero? len) | |
105 | (begin | |
106 | (finalize!) | |
107 | 0) | |
108 | (let ((ptr (bytevector->pointer bv offset))) | |
109 | (md-write sha256-md ptr len) | |
110 | len))) | |
111 | ||
112 | (define (close) | |
113 | (unless digest | |
114 | (finalize!))) | |
115 | ||
116 | (values (make-custom-binary-output-port "sha256" | |
117 | write! #f #f | |
118 | close) | |
119 | (lambda () | |
120 | (unless digest | |
121 | (finalize!)) | |
122 | digest))) | |
123 | ||
124 | (define (port-sha256 port) | |
125 | "Return the SHA256 hash (a bytevector) of all the data drained from PORT." | |
126 | (let-values (((out get) | |
127 | (open-sha256-port))) | |
128 | (dump-port port out) | |
129 | (close-port out) | |
130 | (get))) | |
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 |