summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Makefile.am2
-rw-r--r--guix-download.in1
-rw-r--r--guix.scm3
-rw-r--r--guix/base32.scm288
-rw-r--r--guix/derivations.scm1
-rw-r--r--guix/packages.scm1
-rw-r--r--guix/snix.scm1
-rw-r--r--guix/utils.scm264
-rw-r--r--tests/base32.scm93
-rw-r--r--tests/builders.scm1
-rw-r--r--tests/derivations.scm1
-rw-r--r--tests/utils.scm58
12 files changed, 392 insertions, 322 deletions
diff --git a/Makefile.am b/Makefile.am
index b0fefae968a..b29bf6584b2 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -23,6 +23,7 @@ bin_SCRIPTS = \
23 guix-package 23 guix-package
24 24
25MODULES = \ 25MODULES = \
26 guix/base32.scm \
26 guix/utils.scm \ 27 guix/utils.scm \
27 guix/derivations.scm \ 28 guix/derivations.scm \
28 guix/build-system.scm \ 29 guix/build-system.scm \
@@ -137,6 +138,7 @@ distro/packages/bootstrap/i686-linux/guile-bootstrap-2.0.6.tar.xz:
137nobase_nodist_guilemodule_DATA = $(GOBJECTS) guix/config.scm 138nobase_nodist_guilemodule_DATA = $(GOBJECTS) guix/config.scm
138 139
139TESTS = \ 140TESTS = \
141 tests/base32.scm \
140 tests/builders.scm \ 142 tests/builders.scm \
141 tests/derivations.scm \ 143 tests/derivations.scm \
142 tests/utils.scm \ 144 tests/utils.scm \
diff --git a/guix-download.in b/guix-download.in
index 8a3c2c4100d..46efaa17e80 100644
--- a/guix-download.in
+++ b/guix-download.in
@@ -36,6 +36,7 @@ exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0" \
36 #:use-module (guix ui) 36 #:use-module (guix ui)
37 #:use-module (guix store) 37 #:use-module (guix store)
38 #:use-module (guix utils) 38 #:use-module (guix utils)
39 #:use-module (guix base32)
39 #:use-module (guix ftp-client) 40 #:use-module (guix ftp-client)
40 #:use-module (ice-9 match) 41 #:use-module (ice-9 match)
41 #:use-module (srfi srfi-1) 42 #:use-module (srfi srfi-1)
diff --git a/guix.scm b/guix.scm
index 8427780f470..1e136372bcb 100644
--- a/guix.scm
+++ b/guix.scm
@@ -23,7 +23,8 @@
23(eval-when (eval load compile) 23(eval-when (eval load compile)
24 (begin 24 (begin
25 (define %public-modules 25 (define %public-modules
26 '(build-system 26 '(base32
27 build-system
27 derivations 28 derivations
28 ftp-client 29 ftp-client
29 ftp 30 ftp
diff --git a/guix/base32.scm b/guix/base32.scm
new file mode 100644
index 00000000000..6f0a92bd999
--- /dev/null
+++ b/guix/base32.scm
@@ -0,0 +1,288 @@
1;;; Guix --- Nix package management from Guile. -*- coding: utf-8 -*-
2;;; Copyright (C) 2012 Ludovic Courtès <ludo@gnu.org>
3;;;
4;;; This file is part of Guix.
5;;;
6;;; 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;;; 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 Guix. If not, see <http://www.gnu.org/licenses/>.
18
19(define-module (guix base32)
20 #:use-module (srfi srfi-1)
21 #:use-module (srfi srfi-60)
22 #:use-module (rnrs bytevectors)
23 #:use-module (ice-9 vlist)
24 #:export (bytevector-quintet-length
25 bytevector->base32-string
26 bytevector->nix-base32-string
27 base32-string->bytevector
28 nix-base32-string->bytevector))
29
30;;; Commentary:
31;;;
32;;; A generic, customizable to convert bytevectors to/from a base32
33;;; representation.
34;;;
35;;; Code:
36
37(define bytevector-quintet-ref
38 (let* ((ref bytevector-u8-ref)
39 (ref+ (lambda (bv offset)
40 (let ((o (+ 1 offset)))
41 (if (>= o (bytevector-length bv))
42 0
43 (bytevector-u8-ref bv o)))))
44 (ref0 (lambda (bv offset)
45 (bit-field (ref bv offset) 3 8)))
46 (ref1 (lambda (bv offset)
47 (logior (ash (bit-field (ref bv offset) 0 3) 2)
48 (bit-field (ref+ bv offset) 6 8))))
49 (ref2 (lambda (bv offset)
50 (bit-field (ref bv offset) 1 6)))
51 (ref3 (lambda (bv offset)
52 (logior (ash (bit-field (ref bv offset) 0 1) 4)
53 (bit-field (ref+ bv offset) 4 8))))
54 (ref4 (lambda (bv offset)
55 (logior (ash (bit-field (ref bv offset) 0 4) 1)
56 (bit-field (ref+ bv offset) 7 8))))
57 (ref5 (lambda (bv offset)
58 (bit-field (ref bv offset) 2 7)))
59 (ref6 (lambda (bv offset)
60 (logior (ash (bit-field (ref bv offset) 0 2) 3)
61 (bit-field (ref+ bv offset) 5 8))))
62 (ref7 (lambda (bv offset)
63 (bit-field (ref bv offset) 0 5)))
64 (refs (vector ref0 ref1 ref2 ref3 ref4 ref5 ref6 ref7)))
65 (lambda (bv index)
66 "Return the INDEXth quintet of BV."
67 (let ((p (vector-ref refs (modulo index 8))))
68 (p bv (quotient (* index 5) 8))))))
69
70(define bytevector-quintet-ref-right
71 (let* ((ref bytevector-u8-ref)
72 (ref+ (lambda (bv offset)
73 (let ((o (+ 1 offset)))
74 (if (>= o (bytevector-length bv))
75 0
76 (bytevector-u8-ref bv o)))))
77 (ref0 (lambda (bv offset)
78 (bit-field (ref bv offset) 0 5)))
79 (ref1 (lambda (bv offset)
80 (logior (bit-field (ref bv offset) 5 8)
81 (ash (bit-field (ref+ bv offset) 0 2) 3))))
82 (ref2 (lambda (bv offset)
83 (bit-field (ref bv offset) 2 7)))
84 (ref3 (lambda (bv offset)
85 (logior (bit-field (ref bv offset) 7 8)
86 (ash (bit-field (ref+ bv offset) 0 4) 1))))
87 (ref4 (lambda (bv offset)
88 (logior (bit-field (ref bv offset) 4 8)
89 (ash (bit-field (ref+ bv offset) 0 1) 4))))
90 (ref5 (lambda (bv offset)
91 (bit-field (ref bv offset) 1 6)))
92 (ref6 (lambda (bv offset)
93 (logior (bit-field (ref bv offset) 6 8)
94 (ash (bit-field (ref+ bv offset) 0 3) 2))))
95 (ref7 (lambda (bv offset)
96 (bit-field (ref bv offset) 3 8)))
97 (refs (vector ref0 ref1 ref2 ref3 ref4 ref5 ref6 ref7)))
98 (lambda (bv index)
99 "Return the INDEXth quintet of BV, assuming quintets start from the
100least-significant bits, contrary to what RFC 4648 describes."
101 (let ((p (vector-ref refs (modulo index 8))))
102 (p bv (quotient (* index 5) 8))))))
103
104(define (bytevector-quintet-length bv)
105 "Return the number of quintets (including truncated ones) available in BV."
106 (ceiling (/ (* (bytevector-length bv) 8) 5)))
107
108(define (bytevector-quintet-fold proc init bv)
109 "Return the result of applying PROC to each quintet of BV and the result of
110the previous application or INIT."
111 (define len
112 (bytevector-quintet-length bv))
113
114 (let loop ((i 0)
115 (r init))
116 (if (= i len)
117 r
118 (loop (1+ i) (proc (bytevector-quintet-ref bv i) r)))))
119
120(define (bytevector-quintet-fold-right proc init bv)
121 "Return the result of applying PROC to each quintet of BV and the result of
122the previous application or INIT."
123 (define len
124 (bytevector-quintet-length bv))
125
126 (let loop ((i len)
127 (r init))
128 (if (zero? i)
129 r
130 (let ((j (- i 1)))
131 (loop j (proc (bytevector-quintet-ref-right bv j) r))))))
132
133(define (make-bytevector->base32-string quintet-fold base32-chars)
134 (lambda (bv)
135 "Return a base32 encoding of BV using BASE32-CHARS as the alphabet."
136 (let ((chars (quintet-fold (lambda (q r)
137 (cons (vector-ref base32-chars q)
138 r))
139 '()
140 bv)))
141 (list->string (reverse chars)))))
142
143(define %nix-base32-chars
144 ;; See `libutil/hash.cc'.
145 #(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9
146 #\a #\b #\c #\d #\f #\g #\h #\i #\j #\k #\l #\m #\n
147 #\p #\q #\r #\s #\v #\w #\x #\y #\z))
148
149(define %rfc4648-base32-chars
150 #(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m
151 #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z
152 #\2 #\3 #\4 #\5 #\6 #\7))
153
154(define bytevector->base32-string
155 (make-bytevector->base32-string bytevector-quintet-fold
156 %rfc4648-base32-chars))
157
158(define bytevector->nix-base32-string
159 (make-bytevector->base32-string bytevector-quintet-fold-right
160 %nix-base32-chars))
161
162
163(define bytevector-quintet-set!
164 (let* ((setq! (lambda (bv offset start stop value)
165 (let ((v (bytevector-u8-ref bv offset))
166 (w (arithmetic-shift value start))
167 (m (bitwise-xor (1- (expt 2 stop))
168 (1- (expt 2 start)))))
169 (bytevector-u8-set! bv offset
170 (bitwise-merge m w v)))))
171 (set0! (lambda (bv offset value)
172 (setq! bv offset 3 8 value)))
173 (set1! (lambda (bv offset value)
174 (setq! bv offset 0 3 (bit-field value 2 5))
175 (or (= (+ 1 offset) (bytevector-length bv))
176 (setq! bv (+ 1 offset) 6 8 (bit-field value 0 2)))))
177 (set2! (lambda (bv offset value)
178 (setq! bv offset 1 6 value)))
179 (set3! (lambda (bv offset value)
180 (setq! bv offset 0 1 (bit-field value 4 5))
181 (or (= (+ 1 offset) (bytevector-length bv))
182 (setq! bv (+ 1 offset) 4 8 (bit-field value 0 4)))))
183 (set4! (lambda (bv offset value)
184 (setq! bv offset 0 4 (bit-field value 1 5))
185 (or (= (+ 1 offset) (bytevector-length bv))
186 (setq! bv (+ 1 offset) 7 8 (bit-field value 0 1)))))
187 (set5! (lambda (bv offset value)
188 (setq! bv offset 2 7 value)))
189 (set6! (lambda (bv offset value)
190 (setq! bv offset 0 2 (bit-field value 3 5))
191 (or (= (+ 1 offset) (bytevector-length bv))
192 (setq! bv (+ 1 offset) 5 8 (bit-field value 0 3)))))
193 (set7! (lambda (bv offset value)
194 (setq! bv offset 0 5 value)))
195 (sets (vector set0! set1! set2! set3! set4! set5! set6! set7!)))
196 (lambda (bv index value)
197 "Set the INDEXth quintet of BV to VALUE."
198 (let ((p (vector-ref sets (modulo index 8))))
199 (p bv (quotient (* index 5) 8) (logand value #x1f))))))
200
201(define bytevector-quintet-set-right!
202 (let* ((setq! (lambda (bv offset start stop value)
203 (let ((v (bytevector-u8-ref bv offset))
204 (w (arithmetic-shift value start))
205 (m (bitwise-xor (1- (expt 2 stop))
206 (1- (expt 2 start)))))
207 (bytevector-u8-set! bv offset
208 (bitwise-merge m w v)))))
209 (set0! (lambda (bv offset value)
210 (setq! bv offset 0 5 value)))
211 (set1! (lambda (bv offset value)
212 (setq! bv offset 5 8 (bit-field value 0 3))
213 (or (= (+ 1 offset) (bytevector-length bv))
214 (setq! bv (+ 1 offset) 0 2 (bit-field value 3 5)))))
215 (set2! (lambda (bv offset value)
216 (setq! bv offset 2 7 value)))
217 (set3! (lambda (bv offset value)
218 (setq! bv offset 7 8 (bit-field value 0 1))
219 (or (= (+ 1 offset) (bytevector-length bv))
220 (setq! bv (+ 1 offset) 0 4 (bit-field value 1 5)))))
221 (set4! (lambda (bv offset value)
222 (setq! bv offset 4 8 (bit-field value 0 4))
223 (or (= (+ 1 offset) (bytevector-length bv))
224 (setq! bv (+ 1 offset) 0 1 (bit-field value 4 5)))))
225 (set5! (lambda (bv offset value)
226 (setq! bv offset 1 6 value)))
227 (set6! (lambda (bv offset value)
228 (setq! bv offset 6 8 (bit-field value 0 2))
229 (or (= (+ 1 offset) (bytevector-length bv))
230 (setq! bv (+ 1 offset) 0 3 (bit-field value 2 5)))))
231 (set7! (lambda (bv offset value)
232 (setq! bv offset 3 8 value)))
233 (sets (vector set0! set1! set2! set3! set4! set5! set6! set7!)))
234 (lambda (bv index value)
235 "Set the INDEXth quintet of BV to VALUE, assuming quintets start from
236the least-significant bits."
237 (let ((p (vector-ref sets (modulo index 8))))
238 (p bv (quotient (* index 5) 8) (logand value #x1f))))))
239
240(define (base32-string-unfold f s)
241 "Given procedure F which, when applied to a character, returns the
242corresponding quintet, return the bytevector corresponding to string S."
243 (define len (string-length s))
244
245 (let ((bv (make-bytevector (quotient (* len 5) 8))))
246 (string-fold (lambda (chr index)
247 (bytevector-quintet-set! bv index (f chr))
248 (+ 1 index))
249 0
250 s)
251 bv))
252
253(define (base32-string-unfold-right f s)
254 "Given procedure F which, when applied to a character, returns the
255corresponding quintet, return the bytevector corresponding to string S,
256starting from the right of S."
257 (define len (string-length s))
258
259 (let ((bv (make-bytevector (quotient (* len 5) 8))))
260 (string-fold-right (lambda (chr index)
261 (bytevector-quintet-set-right! bv index (f chr))
262 (+ 1 index))
263 0
264 s)
265 bv))
266
267(define (make-base32-string->bytevector base32-string-unfold base32-chars)
268 (let ((char->value (let loop ((i 0)
269 (v vlist-null))
270 (if (= i (vector-length base32-chars))
271 v
272 (loop (+ 1 i)
273 (vhash-consv (vector-ref base32-chars i)
274 i v))))))
275 (lambda (s)
276 "Return the binary representation of base32 string S as a bytevector."
277 (base32-string-unfold (lambda (chr)
278 (or (and=> (vhash-assv chr char->value) cdr)
279 (error "invalid base32 character" chr)))
280 s))))
281
282(define base32-string->bytevector
283 (make-base32-string->bytevector base32-string-unfold %rfc4648-base32-chars))
284
285(define nix-base32-string->bytevector
286 (make-base32-string->bytevector base32-string-unfold-right %nix-base32-chars))
287
288;;; base32.scm ends here
diff --git a/guix/derivations.scm b/guix/derivations.scm
index cbf755ab633..cda1f065d47 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -26,6 +26,7 @@
26 #:use-module (ice-9 rdelim) 26 #:use-module (ice-9 rdelim)
27 #:use-module (guix store) 27 #:use-module (guix store)
28 #:use-module (guix utils) 28 #:use-module (guix utils)
29 #:use-module (guix base32)
29 #:export (<derivation> 30 #:export (<derivation>
30 derivation? 31 derivation?
31 derivation-outputs 32 derivation-outputs
diff --git a/guix/packages.scm b/guix/packages.scm
index 9d1dbe7dc49..23761f41012 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -19,6 +19,7 @@
19(define-module (guix packages) 19(define-module (guix packages)
20 #:use-module (guix utils) 20 #:use-module (guix utils)
21 #:use-module (guix store) 21 #:use-module (guix store)
22 #:use-module (guix base32)
22 #:use-module (guix build-system) 23 #:use-module (guix build-system)
23 #:use-module (ice-9 match) 24 #:use-module (ice-9 match)
24 #:use-module (srfi srfi-1) 25 #:use-module (srfi srfi-1)
diff --git a/guix/snix.scm b/guix/snix.scm
index ef98eb42a07..c6a9bee6a72 100644
--- a/guix/snix.scm
+++ b/guix/snix.scm
@@ -32,6 +32,7 @@
32 #:use-module (system foreign) 32 #:use-module (system foreign)
33 #:use-module (rnrs bytevectors) 33 #:use-module (rnrs bytevectors)
34 #:use-module (guix utils) 34 #:use-module (guix utils)
35 #:use-module (guix base32)
35 #:use-module (guix config) 36 #:use-module (guix config)
36 #:export (open-nixpkgs 37 #:export (open-nixpkgs
37 xml->snix 38 xml->snix
diff --git a/guix/utils.scm b/guix/utils.scm
index fa5abadc7a9..ff8730aa632 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -33,12 +33,7 @@
33 #:use-module (ice-9 match) 33 #:use-module (ice-9 match)
34 #:use-module (ice-9 format) 34 #:use-module (ice-9 format)
35 #:autoload (system foreign) (pointer->procedure) 35 #:autoload (system foreign) (pointer->procedure)
36 #:export (bytevector-quintet-length 36 #:export (bytevector->base16-string
37 bytevector->base32-string
38 bytevector->nix-base32-string
39 bytevector->base16-string
40 base32-string->bytevector
41 nix-base32-string->bytevector
42 base16-string->bytevector 37 base16-string->bytevector
43 sha256 38 sha256
44 39
@@ -81,263 +76,6 @@ evaluate to a simple datum."
81 76
82 77
83;;; 78;;;
84;;; Base 32.
85;;;
86
87(define bytevector-quintet-ref
88 (let* ((ref bytevector-u8-ref)
89 (ref+ (lambda (bv offset)
90 (let ((o (+ 1 offset)))
91 (if (>= o (bytevector-length bv))
92 0
93 (bytevector-u8-ref bv o)))))
94 (ref0 (lambda (bv offset)
95 (bit-field (ref bv offset) 3 8)))
96 (ref1 (lambda (bv offset)
97 (logior (ash (bit-field (ref bv offset) 0 3) 2)
98 (bit-field (ref+ bv offset) 6 8))))
99 (ref2 (lambda (bv offset)
100 (bit-field (ref bv offset) 1 6)))
101 (ref3 (lambda (bv offset)
102 (logior (ash (bit-field (ref bv offset) 0 1) 4)
103 (bit-field (ref+ bv offset) 4 8))))
104 (ref4 (lambda (bv offset)
105 (logior (ash (bit-field (ref bv offset) 0 4) 1)
106 (bit-field (ref+ bv offset) 7 8))))
107 (ref5 (lambda (bv offset)
108 (bit-field (ref bv offset) 2 7)))
109 (ref6 (lambda (bv offset)
110 (logior (ash (bit-field (ref bv offset) 0 2) 3)
111 (bit-field (ref+ bv offset) 5 8))))
112 (ref7 (lambda (bv offset)
113 (bit-field (ref bv offset) 0 5)))
114 (refs (vector ref0 ref1 ref2 ref3 ref4 ref5 ref6 ref7)))
115 (lambda (bv index)
116 "Return the INDEXth quintet of BV."
117 (let ((p (vector-ref refs (modulo index 8))))
118 (p bv (quotient (* index 5) 8))))))
119
120(define bytevector-quintet-ref-right
121 (let* ((ref bytevector-u8-ref)
122 (ref+ (lambda (bv offset)
123 (let ((o (+ 1 offset)))
124 (if (>= o (bytevector-length bv))
125 0
126 (bytevector-u8-ref bv o)))))
127 (ref0 (lambda (bv offset)
128 (bit-field (ref bv offset) 0 5)))
129 (ref1 (lambda (bv offset)
130 (logior (bit-field (ref bv offset) 5 8)
131 (ash (bit-field (ref+ bv offset) 0 2) 3))))
132 (ref2 (lambda (bv offset)
133 (bit-field (ref bv offset) 2 7)))
134 (ref3 (lambda (bv offset)
135 (logior (bit-field (ref bv offset) 7 8)
136 (ash (bit-field (ref+ bv offset) 0 4) 1))))
137 (ref4 (lambda (bv offset)
138 (logior (bit-field (ref bv offset) 4 8)
139 (ash (bit-field (ref+ bv offset) 0 1) 4))))
140 (ref5 (lambda (bv offset)
141 (bit-field (ref bv offset) 1 6)))
142 (ref6 (lambda (bv offset)
143 (logior (bit-field (ref bv offset) 6 8)
144 (ash (bit-field (ref+ bv offset) 0 3) 2))))
145 (ref7 (lambda (bv offset)
146 (bit-field (ref bv offset) 3 8)))
147 (refs (vector ref0 ref1 ref2 ref3 ref4 ref5 ref6 ref7)))
148 (lambda (bv index)
149 "Return the INDEXth quintet of BV, assuming quintets start from the
150least-significant bits, contrary to what RFC 4648 describes."
151 (let ((p (vector-ref refs (modulo index 8))))
152 (p bv (quotient (* index 5) 8))))))
153
154(define (bytevector-quintet-length bv)
155 "Return the number of quintets (including truncated ones) available in BV."
156 (ceiling (/ (* (bytevector-length bv) 8) 5)))
157
158(define (bytevector-quintet-fold proc init bv)
159 "Return the result of applying PROC to each quintet of BV and the result of
160the previous application or INIT."
161 (define len
162 (bytevector-quintet-length bv))
163
164 (let loop ((i 0)
165 (r init))
166 (if (= i len)
167 r
168 (loop (1+ i) (proc (bytevector-quintet-ref bv i) r)))))
169
170(define (bytevector-quintet-fold-right proc init bv)
171 "Return the result of applying PROC to each quintet of BV and the result of
172the previous application or INIT."
173 (define len
174 (bytevector-quintet-length bv))
175
176 (let loop ((i len)
177 (r init))
178 (if (zero? i)
179 r
180 (let ((j (- i 1)))
181 (loop j (proc (bytevector-quintet-ref-right bv j) r))))))
182
183(define (make-bytevector->base32-string quintet-fold base32-chars)
184 (lambda (bv)
185 "Return a base32 encoding of BV using BASE32-CHARS as the alphabet."
186 (let ((chars (quintet-fold (lambda (q r)
187 (cons (vector-ref base32-chars q)
188 r))
189 '()
190 bv)))
191 (list->string (reverse chars)))))
192
193(define %nix-base32-chars
194 ;; See `libutil/hash.cc'.
195 #(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9
196 #\a #\b #\c #\d #\f #\g #\h #\i #\j #\k #\l #\m #\n
197 #\p #\q #\r #\s #\v #\w #\x #\y #\z))
198
199(define %rfc4648-base32-chars
200 #(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m
201 #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z
202 #\2 #\3 #\4 #\5 #\6 #\7))
203
204(define bytevector->base32-string
205 (make-bytevector->base32-string bytevector-quintet-fold
206 %rfc4648-base32-chars))
207
208(define bytevector->nix-base32-string
209 (make-bytevector->base32-string bytevector-quintet-fold-right
210 %nix-base32-chars))
211
212
213(define bytevector-quintet-set!
214 (let* ((setq! (lambda (bv offset start stop value)
215 (let ((v (bytevector-u8-ref bv offset))
216 (w (arithmetic-shift value start))
217 (m (bitwise-xor (1- (expt 2 stop))
218 (1- (expt 2 start)))))
219 (bytevector-u8-set! bv offset
220 (bitwise-merge m w v)))))
221 (set0! (lambda (bv offset value)
222 (setq! bv offset 3 8 value)))
223 (set1! (lambda (bv offset value)
224 (setq! bv offset 0 3 (bit-field value 2 5))
225 (or (= (+ 1 offset) (bytevector-length bv))
226 (setq! bv (+ 1 offset) 6 8 (bit-field value 0 2)))))
227 (set2! (lambda (bv offset value)
228 (setq! bv offset 1 6 value)))
229 (set3! (lambda (bv offset value)
230 (setq! bv offset 0 1 (bit-field value 4 5))
231 (or (= (+ 1 offset) (bytevector-length bv))
232 (setq! bv (+ 1 offset) 4 8 (bit-field value 0 4)))))
233 (set4! (lambda (bv offset value)
234 (setq! bv offset 0 4 (bit-field value 1 5))
235 (or (= (+ 1 offset) (bytevector-length bv))
236 (setq! bv (+ 1 offset) 7 8 (bit-field value 0 1)))))
237 (set5! (lambda (bv offset value)
238 (setq! bv offset 2 7 value)))
239 (set6! (lambda (bv offset value)
240 (setq! bv offset 0 2 (bit-field value 3 5))
241 (or (= (+ 1 offset) (bytevector-length bv))
242 (setq! bv (+ 1 offset) 5 8 (bit-field value 0 3)))))
243 (set7! (lambda (bv offset value)
244 (setq! bv offset 0 5 value)))
245 (sets (vector set0! set1! set2! set3! set4! set5! set6! set7!)))
246 (lambda (bv index value)
247 "Set the INDEXth quintet of BV to VALUE."
248 (let ((p (vector-ref sets (modulo index 8))))
249 (p bv (quotient (* index 5) 8) (logand value #x1f))))))
250
251(define bytevector-quintet-set-right!
252 (let* ((setq! (lambda (bv offset start stop value)
253 (let ((v (bytevector-u8-ref bv offset))
254 (w (arithmetic-shift value start))
255 (m (bitwise-xor (1- (expt 2 stop))
256 (1- (expt 2 start)))))
257 (bytevector-u8-set! bv offset
258 (bitwise-merge m w v)))))
259 (set0! (lambda (bv offset value)
260 (setq! bv offset 0 5 value)))
261 (set1! (lambda (bv offset value)
262 (setq! bv offset 5 8 (bit-field value 0 3))
263 (or (= (+ 1 offset) (bytevector-length bv))
264 (setq! bv (+ 1 offset) 0 2 (bit-field value 3 5)))))
265 (set2! (lambda (bv offset value)
266 (setq! bv offset 2 7 value)))
267 (set3! (lambda (bv offset value)
268 (setq! bv offset 7 8 (bit-field value 0 1))
269 (or (= (+ 1 offset) (bytevector-length bv))
270 (setq! bv (+ 1 offset) 0 4 (bit-field value 1 5)))))
271 (set4! (lambda (bv offset value)
272 (setq! bv offset 4 8 (bit-field value 0 4))
273 (or (= (+ 1 offset) (bytevector-length bv))
274 (setq! bv (+ 1 offset) 0 1 (bit-field value 4 5)))))
275 (set5! (lambda (bv offset value)
276 (setq! bv offset 1 6 value)))
277 (set6! (lambda (bv offset value)
278 (setq! bv offset 6 8 (bit-field value 0 2))
279 (or (= (+ 1 offset) (bytevector-length bv))
280 (setq! bv (+ 1 offset) 0 3 (bit-field value 2 5)))))
281 (set7! (lambda (bv offset value)
282 (setq! bv offset 3 8 value)))
283 (sets (vector set0! set1! set2! set3! set4! set5! set6! set7!)))
284 (lambda (bv index value)
285 "Set the INDEXth quintet of BV to VALUE, assuming quintets start from
286the least-significant bits."
287 (let ((p (vector-ref sets (modulo index 8))))
288 (p bv (quotient (* index 5) 8) (logand value #x1f))))))
289
290(define (base32-string-unfold f s)
291 "Given procedure F which, when applied to a character, returns the
292corresponding quintet, return the bytevector corresponding to string S."
293 (define len (string-length s))
294
295 (let ((bv (make-bytevector (quotient (* len 5) 8))))
296 (string-fold (lambda (chr index)
297 (bytevector-quintet-set! bv index (f chr))
298 (+ 1 index))
299 0
300 s)
301 bv))
302
303(define (base32-string-unfold-right f s)
304 "Given procedure F which, when applied to a character, returns the
305corresponding quintet, return the bytevector corresponding to string S,
306starting from the right of S."
307 (define len (string-length s))
308
309 (let ((bv (make-bytevector (quotient (* len 5) 8))))
310 (string-fold-right (lambda (chr index)
311 (bytevector-quintet-set-right! bv index (f chr))
312 (+ 1 index))
313 0
314 s)
315 bv))
316
317(define (make-base32-string->bytevector base32-string-unfold base32-chars)
318 (let ((char->value (let loop ((i 0)
319 (v vlist-null))
320 (if (= i (vector-length base32-chars))
321 v
322 (loop (+ 1 i)
323 (vhash-consv (vector-ref base32-chars i)
324 i v))))))
325 (lambda (s)
326 "Return the binary representation of base32 string S as a bytevector."
327 (base32-string-unfold (lambda (chr)
328 (or (and=> (vhash-assv chr char->value) cdr)
329 (error "invalid base32 character" chr)))
330 s))))
331
332(define base32-string->bytevector
333 (make-base32-string->bytevector base32-string-unfold %rfc4648-base32-chars))
334
335(define nix-base32-string->bytevector
336 (make-base32-string->bytevector base32-string-unfold-right %nix-base32-chars))
337
338
339
340;;;
341;;; Base 16. 79;;; Base 16.
342;;; 80;;;
343 81
diff --git a/tests/base32.scm b/tests/base32.scm
new file mode 100644
index 00000000000..b8b9ebb0dda
--- /dev/null
+++ b/tests/base32.scm
@@ -0,0 +1,93 @@
1;;; Guix --- Nix package management from Guile. -*- coding: utf-8 -*-
2;;; Copyright (C) 2012 Ludovic Courtès <ludo@gnu.org>
3;;;
4;;; This file is part of Guix.
5;;;
6;;; 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;;; 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 Guix. If not, see <http://www.gnu.org/licenses/>.
18
19(define-module (test-base32)
20 #:use-module (guix base32)
21 #:use-module (guix utils)
22 #:use-module (srfi srfi-1)
23 #:use-module (srfi srfi-64)
24 #:use-module (ice-9 rdelim)
25 #:use-module (ice-9 popen)
26 #:use-module (rnrs bytevectors)
27 #:use-module (rnrs io ports))
28
29;; Test the (guix base32) module.
30
31(define %nix-hash
32 (or (getenv "NIX_HASH")
33 "nix-hash"))
34
35(test-begin "base32")
36
37(test-assert "bytevector->base32-string"
38 (fold (lambda (bv expected result)
39 (and result
40 (string=? (bytevector->base32-string bv)
41 expected)))
42 #t
43
44 ;; Examples from RFC 4648.
45 (map string->utf8 '("" "f" "fo" "foo" "foob" "fooba" "foobar"))
46 '(""
47 "my"
48 "mzxq"
49 "mzxw6"
50 "mzxw6yq"
51 "mzxw6ytb"
52 "mzxw6ytboi")))
53
54(test-assert "base32-string->bytevector"
55 (every (lambda (bv)
56 (equal? (base32-string->bytevector
57 (bytevector->base32-string bv))
58 bv))
59 ;; Examples from RFC 4648.
60 (map string->utf8 '("" "f" "fo" "foo" "foob" "fooba" "foobar"))))
61
62(test-assert "nix-base32-string->bytevector"
63 (every (lambda (bv)
64 (equal? (nix-base32-string->bytevector
65 (bytevector->nix-base32-string bv))
66 bv))
67 ;; Examples from RFC 4648.
68 (map string->utf8 '("" "f" "fo" "foo" "foob" "fooba" "foobar"))))
69
70;; The following tests requires `nix-hash' in $PATH.
71(test-skip (if (false-if-exception (system* %nix-hash "--version"))
72 0
73 1))
74
75(test-assert "sha256 & bytevector->nix-base32-string"
76 (let ((file (search-path %load-path "tests/test.drv")))
77 (equal? (bytevector->nix-base32-string
78 (sha256 (call-with-input-file file get-bytevector-all)))
79 (let* ((c (format #f "~a --type sha256 --base32 --flat \"~a\""
80 %nix-hash file))
81 (p (open-input-pipe c))
82 (l (read-line p)))
83 (close-pipe p)
84 l))))
85
86(test-end)
87
88
89(exit (= (test-runner-fail-count (test-runner-current)) 0))
90
91;;; Local Variables:
92;;; eval: (put 'test-assert 'scheme-indent-function 1)
93;;; End:
diff --git a/tests/builders.scm b/tests/builders.scm
index 8b0fa117a91..d9dc5afa204 100644
--- a/tests/builders.scm
+++ b/tests/builders.scm
@@ -23,6 +23,7 @@
23 #:use-module (guix build-system gnu) 23 #:use-module (guix build-system gnu)
24 #:use-module (guix store) 24 #:use-module (guix store)
25 #:use-module (guix utils) 25 #:use-module (guix utils)
26 #:use-module (guix base32)
26 #:use-module (guix derivations) 27 #:use-module (guix derivations)
27 #:use-module ((guix packages) #:select (package-derivation)) 28 #:use-module ((guix packages) #:select (package-derivation))
28 #:use-module (distro packages bootstrap) 29 #:use-module (distro packages bootstrap)
diff --git a/tests/derivations.scm b/tests/derivations.scm
index 01ede11af09..618a7c4b960 100644
--- a/tests/derivations.scm
+++ b/tests/derivations.scm
@@ -21,6 +21,7 @@
21 #:use-module (guix derivations) 21 #:use-module (guix derivations)
22 #:use-module (guix store) 22 #:use-module (guix store)
23 #:use-module (guix utils) 23 #:use-module (guix utils)
24 #:use-module (guix base32)
24 #:use-module ((guix packages) #:select (package-derivation)) 25 #:use-module ((guix packages) #:select (package-derivation))
25 #:use-module (distro packages bootstrap) 26 #:use-module (distro packages bootstrap)
26 #:use-module (srfi srfi-1) 27 #:use-module (srfi srfi-1)
diff --git a/tests/utils.scm b/tests/utils.scm
index 1ced410d419..0a6e8a08332 100644
--- a/tests/utils.scm
+++ b/tests/utils.scm
@@ -16,59 +16,17 @@
16;;; You should have received a copy of the GNU General Public License 16;;; You should have received a copy of the GNU General Public License
17;;; along with Guix. If not, see <http://www.gnu.org/licenses/>. 17;;; along with Guix. If not, see <http://www.gnu.org/licenses/>.
18 18
19
20(define-module (test-utils) 19(define-module (test-utils)
21 #:use-module (guix utils) 20 #:use-module (guix utils)
22 #:use-module ((guix store) #:select (store-path-package-name)) 21 #:use-module ((guix store) #:select (store-path-package-name))
23 #:use-module (srfi srfi-1) 22 #:use-module (srfi srfi-1)
24 #:use-module (srfi srfi-11) 23 #:use-module (srfi srfi-11)
25 #:use-module (srfi srfi-26)
26 #:use-module (srfi srfi-64) 24 #:use-module (srfi srfi-64)
27 #:use-module (rnrs bytevectors) 25 #:use-module (rnrs bytevectors)
28 #:use-module (rnrs io ports)
29 #:use-module (ice-9 rdelim)
30 #:use-module (ice-9 popen)
31 #:use-module (ice-9 match)) 26 #:use-module (ice-9 match))
32 27
33(define %nix-hash
34 (or (getenv "NIX_HASH")
35 "nix-hash"))
36
37(test-begin "utils") 28(test-begin "utils")
38 29
39(test-assert "bytevector->base32-string"
40 (fold (lambda (bv expected result)
41 (and result
42 (string=? (bytevector->base32-string bv)
43 expected)))
44 #t
45
46 ;; Examples from RFC 4648.
47 (map string->utf8 '("" "f" "fo" "foo" "foob" "fooba" "foobar"))
48 '(""
49 "my"
50 "mzxq"
51 "mzxw6"
52 "mzxw6yq"
53 "mzxw6ytb"
54 "mzxw6ytboi")))
55
56(test-assert "base32-string->bytevector"
57 (every (lambda (bv)
58 (equal? (base32-string->bytevector
59 (bytevector->base32-string bv))
60 bv))
61 ;; Examples from RFC 4648.
62 (map string->utf8 '("" "f" "fo" "foo" "foob" "fooba" "foobar"))))
63
64(test-assert "nix-base32-string->bytevector"
65 (every (lambda (bv)
66 (equal? (nix-base32-string->bytevector
67 (bytevector->nix-base32-string bv))
68 bv))
69 ;; Examples from RFC 4648.
70 (map string->utf8 '("" "f" "fo" "foo" "foob" "fooba" "foobar"))))
71
72(test-assert "bytevector->base16-string->bytevector" 30(test-assert "bytevector->base16-string->bytevector"
73 (every (lambda (bv) 31 (every (lambda (bv)
74 (equal? (base16-string->bytevector 32 (equal? (base16-string->bytevector
@@ -76,22 +34,6 @@
76 bv)) 34 bv))
77 (map string->utf8 '("" "f" "fo" "foo" "foob" "fooba" "foobar")))) 35 (map string->utf8 '("" "f" "fo" "foo" "foob" "fooba" "foobar"))))
78 36
79;; The following tests requires `nix-hash' in $PATH.
80(test-skip (if (false-if-exception (system* %nix-hash "--version"))
81 0
82 1))
83
84(test-assert "sha256 & bytevector->nix-base32-string"
85 (let ((file (search-path %load-path "tests/test.drv")))
86 (equal? (bytevector->nix-base32-string
87 (sha256 (call-with-input-file file get-bytevector-all)))
88 (let* ((c (format #f "~a --type sha256 --base32 --flat \"~a\""
89 %nix-hash file))
90 (p (open-input-pipe c))
91 (l (read-line p)))
92 (close-pipe p)
93 l))))
94
95(test-assert "gnu-triplet->nix-system" 37(test-assert "gnu-triplet->nix-system"
96 (let ((samples '(("i586-gnu0.3" "i686-gnu") 38 (let ((samples '(("i586-gnu0.3" "i686-gnu")
97 ("x86_64-unknown-linux-gnu" "x86_64-linux") 39 ("x86_64-unknown-linux-gnu" "x86_64-linux")