Update license headers.
[jackhill/guix/guix.git] / guix / base32.scm
1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2012 Ludovic Courtès <ludo@gnu.org>
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 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
100 least-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
110 the 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
122 the 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
236 the 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
242 corresponding 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
255 corresponding quintet, return the bytevector corresponding to string S,
256 starting 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