Commit | Line | Data |
---|---|---|
233e7676 | 1 | ;;; GNU Guix --- Functional package management for GNU |
cb06f7c6 | 2 | ;;; Copyright © 2012, 2015, 2017, 2021 Ludovic Courtès <ludo@gnu.org> |
ddc29a78 | 3 | ;;; |
233e7676 | 4 | ;;; This file is part of GNU Guix. |
ddc29a78 | 5 | ;;; |
233e7676 | 6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it |
ddc29a78 LC |
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 | ;;; | |
233e7676 | 11 | ;;; GNU Guix is distributed in the hope that it will be useful, but |
ddc29a78 LC |
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 | |
233e7676 | 17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. |
ddc29a78 LC |
18 | |
19 | (define-module (guix base32) | |
20 | #:use-module (srfi srfi-1) | |
1a706ff5 LC |
21 | #:use-module (srfi srfi-34) |
22 | #:use-module (srfi srfi-35) | |
ddc29a78 LC |
23 | #:use-module (srfi srfi-60) |
24 | #:use-module (rnrs bytevectors) | |
25 | #:use-module (ice-9 vlist) | |
26 | #:export (bytevector-quintet-length | |
27 | bytevector->base32-string | |
28 | bytevector->nix-base32-string | |
29 | base32-string->bytevector | |
1a706ff5 | 30 | nix-base32-string->bytevector |
0a94dc63 LC |
31 | %nix-base32-charset |
32 | %rfc4648-base32-charset | |
1a706ff5 LC |
33 | &invalid-base32-character |
34 | invalid-base32-character? | |
35 | invalid-base32-character-value | |
36 | invalid-base32-character-string)) | |
ddc29a78 LC |
37 | |
38 | ;;; Commentary: | |
39 | ;;; | |
40 | ;;; A generic, customizable to convert bytevectors to/from a base32 | |
41 | ;;; representation. | |
42 | ;;; | |
43 | ;;; Code: | |
44 | ||
cb06f7c6 LC |
45 | (define-syntax bit-field |
46 | (lambda (s) | |
47 | ;; This inline version of 'bit-field' assumes that START and END are | |
48 | ;; literals and pre-computes the mask. In an ideal world, using 'define' | |
49 | ;; or 'define-inlinable' would be enough, but as of 3.0.7, peval doesn't | |
50 | ;; expand calls to 'expt' (and 'bit-field' is a subr.) | |
51 | (syntax-case s () | |
52 | ((_ n start end) | |
53 | (let* ((s (syntax->datum #'start)) | |
54 | (e (syntax->datum #'end)) | |
55 | (mask (- (expt 2 (- e s)) 1))) | |
baa0aa13 LC |
56 | ;; The baseline compiler in Guile <= 3.0.7 miscompiles (ash x N) as |
57 | ;; (ash x (- N)) when N is a literal: <https://bugs.gnu.org/50696>. | |
58 | ;; Here we take advantage of another bug in the baseline compiler, | |
59 | ;; fixed in Guile commit 330c6ea83f492672578b62d0683acbb532d1a5d9: we | |
60 | ;; introduce 'minus-start' such that it has a different source | |
61 | ;; location, which in turn means that the baseline compiler pattern | |
62 | ;; for (ash x N) doesn't match, thus avoiding the bug (!). | |
63 | (with-syntax ((minus-start (datum->syntax #'start (- s)))) | |
64 | #`(logand (ash n minus-start) #,mask))))))) | |
cb06f7c6 | 65 | |
ddc29a78 LC |
66 | (define bytevector-quintet-ref |
67 | (let* ((ref bytevector-u8-ref) | |
68 | (ref+ (lambda (bv offset) | |
69 | (let ((o (+ 1 offset))) | |
70 | (if (>= o (bytevector-length bv)) | |
71 | 0 | |
72 | (bytevector-u8-ref bv o))))) | |
73 | (ref0 (lambda (bv offset) | |
74 | (bit-field (ref bv offset) 3 8))) | |
75 | (ref1 (lambda (bv offset) | |
76 | (logior (ash (bit-field (ref bv offset) 0 3) 2) | |
77 | (bit-field (ref+ bv offset) 6 8)))) | |
78 | (ref2 (lambda (bv offset) | |
79 | (bit-field (ref bv offset) 1 6))) | |
80 | (ref3 (lambda (bv offset) | |
81 | (logior (ash (bit-field (ref bv offset) 0 1) 4) | |
82 | (bit-field (ref+ bv offset) 4 8)))) | |
83 | (ref4 (lambda (bv offset) | |
84 | (logior (ash (bit-field (ref bv offset) 0 4) 1) | |
85 | (bit-field (ref+ bv offset) 7 8)))) | |
86 | (ref5 (lambda (bv offset) | |
87 | (bit-field (ref bv offset) 2 7))) | |
88 | (ref6 (lambda (bv offset) | |
89 | (logior (ash (bit-field (ref bv offset) 0 2) 3) | |
90 | (bit-field (ref+ bv offset) 5 8)))) | |
91 | (ref7 (lambda (bv offset) | |
92 | (bit-field (ref bv offset) 0 5))) | |
93 | (refs (vector ref0 ref1 ref2 ref3 ref4 ref5 ref6 ref7))) | |
94 | (lambda (bv index) | |
95 | "Return the INDEXth quintet of BV." | |
96 | (let ((p (vector-ref refs (modulo index 8)))) | |
97 | (p bv (quotient (* index 5) 8)))))) | |
98 | ||
99 | (define bytevector-quintet-ref-right | |
100 | (let* ((ref bytevector-u8-ref) | |
101 | (ref+ (lambda (bv offset) | |
102 | (let ((o (+ 1 offset))) | |
103 | (if (>= o (bytevector-length bv)) | |
104 | 0 | |
105 | (bytevector-u8-ref bv o))))) | |
106 | (ref0 (lambda (bv offset) | |
107 | (bit-field (ref bv offset) 0 5))) | |
108 | (ref1 (lambda (bv offset) | |
109 | (logior (bit-field (ref bv offset) 5 8) | |
110 | (ash (bit-field (ref+ bv offset) 0 2) 3)))) | |
111 | (ref2 (lambda (bv offset) | |
112 | (bit-field (ref bv offset) 2 7))) | |
113 | (ref3 (lambda (bv offset) | |
114 | (logior (bit-field (ref bv offset) 7 8) | |
115 | (ash (bit-field (ref+ bv offset) 0 4) 1)))) | |
116 | (ref4 (lambda (bv offset) | |
117 | (logior (bit-field (ref bv offset) 4 8) | |
118 | (ash (bit-field (ref+ bv offset) 0 1) 4)))) | |
119 | (ref5 (lambda (bv offset) | |
120 | (bit-field (ref bv offset) 1 6))) | |
121 | (ref6 (lambda (bv offset) | |
122 | (logior (bit-field (ref bv offset) 6 8) | |
123 | (ash (bit-field (ref+ bv offset) 0 3) 2)))) | |
124 | (ref7 (lambda (bv offset) | |
125 | (bit-field (ref bv offset) 3 8))) | |
126 | (refs (vector ref0 ref1 ref2 ref3 ref4 ref5 ref6 ref7))) | |
127 | (lambda (bv index) | |
128 | "Return the INDEXth quintet of BV, assuming quintets start from the | |
129 | least-significant bits, contrary to what RFC 4648 describes." | |
130 | (let ((p (vector-ref refs (modulo index 8)))) | |
131 | (p bv (quotient (* index 5) 8)))))) | |
132 | ||
133 | (define (bytevector-quintet-length bv) | |
134 | "Return the number of quintets (including truncated ones) available in BV." | |
135 | (ceiling (/ (* (bytevector-length bv) 8) 5))) | |
136 | ||
137 | (define (bytevector-quintet-fold proc init bv) | |
138 | "Return the result of applying PROC to each quintet of BV and the result of | |
139 | the previous application or INIT." | |
140 | (define len | |
141 | (bytevector-quintet-length bv)) | |
142 | ||
143 | (let loop ((i 0) | |
144 | (r init)) | |
145 | (if (= i len) | |
146 | r | |
147 | (loop (1+ i) (proc (bytevector-quintet-ref bv i) r))))) | |
148 | ||
149 | (define (bytevector-quintet-fold-right proc init bv) | |
150 | "Return the result of applying PROC to each quintet of BV and the result of | |
151 | the previous application or INIT." | |
152 | (define len | |
153 | (bytevector-quintet-length bv)) | |
154 | ||
155 | (let loop ((i len) | |
156 | (r init)) | |
157 | (if (zero? i) | |
158 | r | |
159 | (let ((j (- i 1))) | |
160 | (loop j (proc (bytevector-quintet-ref-right bv j) r)))))) | |
161 | ||
162 | (define (make-bytevector->base32-string quintet-fold base32-chars) | |
163 | (lambda (bv) | |
164 | "Return a base32 encoding of BV using BASE32-CHARS as the alphabet." | |
165 | (let ((chars (quintet-fold (lambda (q r) | |
166 | (cons (vector-ref base32-chars q) | |
167 | r)) | |
168 | '() | |
169 | bv))) | |
170 | (list->string (reverse chars))))) | |
171 | ||
172 | (define %nix-base32-chars | |
173 | ;; See `libutil/hash.cc'. | |
174 | #(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 | |
175 | #\a #\b #\c #\d #\f #\g #\h #\i #\j #\k #\l #\m #\n | |
176 | #\p #\q #\r #\s #\v #\w #\x #\y #\z)) | |
177 | ||
0a94dc63 LC |
178 | (define %nix-base32-charset |
179 | (list->char-set (vector->list %nix-base32-chars))) | |
180 | ||
ddc29a78 LC |
181 | (define %rfc4648-base32-chars |
182 | #(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m | |
183 | #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z | |
184 | #\2 #\3 #\4 #\5 #\6 #\7)) | |
185 | ||
0a94dc63 LC |
186 | (define %rfc4648-base32-charset |
187 | (list->char-set (vector->list %rfc4648-base32-chars))) | |
188 | ||
ddc29a78 LC |
189 | (define bytevector->base32-string |
190 | (make-bytevector->base32-string bytevector-quintet-fold | |
191 | %rfc4648-base32-chars)) | |
192 | ||
193 | (define bytevector->nix-base32-string | |
194 | (make-bytevector->base32-string bytevector-quintet-fold-right | |
195 | %nix-base32-chars)) | |
196 | ||
197 | ||
198 | (define bytevector-quintet-set! | |
199 | (let* ((setq! (lambda (bv offset start stop value) | |
200 | (let ((v (bytevector-u8-ref bv offset)) | |
201 | (w (arithmetic-shift value start)) | |
202 | (m (bitwise-xor (1- (expt 2 stop)) | |
203 | (1- (expt 2 start))))) | |
204 | (bytevector-u8-set! bv offset | |
205 | (bitwise-merge m w v))))) | |
206 | (set0! (lambda (bv offset value) | |
207 | (setq! bv offset 3 8 value))) | |
208 | (set1! (lambda (bv offset value) | |
209 | (setq! bv offset 0 3 (bit-field value 2 5)) | |
210 | (or (= (+ 1 offset) (bytevector-length bv)) | |
211 | (setq! bv (+ 1 offset) 6 8 (bit-field value 0 2))))) | |
212 | (set2! (lambda (bv offset value) | |
213 | (setq! bv offset 1 6 value))) | |
214 | (set3! (lambda (bv offset value) | |
215 | (setq! bv offset 0 1 (bit-field value 4 5)) | |
216 | (or (= (+ 1 offset) (bytevector-length bv)) | |
217 | (setq! bv (+ 1 offset) 4 8 (bit-field value 0 4))))) | |
218 | (set4! (lambda (bv offset value) | |
219 | (setq! bv offset 0 4 (bit-field value 1 5)) | |
220 | (or (= (+ 1 offset) (bytevector-length bv)) | |
221 | (setq! bv (+ 1 offset) 7 8 (bit-field value 0 1))))) | |
222 | (set5! (lambda (bv offset value) | |
223 | (setq! bv offset 2 7 value))) | |
224 | (set6! (lambda (bv offset value) | |
225 | (setq! bv offset 0 2 (bit-field value 3 5)) | |
226 | (or (= (+ 1 offset) (bytevector-length bv)) | |
227 | (setq! bv (+ 1 offset) 5 8 (bit-field value 0 3))))) | |
228 | (set7! (lambda (bv offset value) | |
229 | (setq! bv offset 0 5 value))) | |
230 | (sets (vector set0! set1! set2! set3! set4! set5! set6! set7!))) | |
231 | (lambda (bv index value) | |
232 | "Set the INDEXth quintet of BV to VALUE." | |
233 | (let ((p (vector-ref sets (modulo index 8)))) | |
234 | (p bv (quotient (* index 5) 8) (logand value #x1f)))))) | |
235 | ||
236 | (define bytevector-quintet-set-right! | |
237 | (let* ((setq! (lambda (bv offset start stop value) | |
238 | (let ((v (bytevector-u8-ref bv offset)) | |
239 | (w (arithmetic-shift value start)) | |
240 | (m (bitwise-xor (1- (expt 2 stop)) | |
241 | (1- (expt 2 start))))) | |
242 | (bytevector-u8-set! bv offset | |
243 | (bitwise-merge m w v))))) | |
244 | (set0! (lambda (bv offset value) | |
245 | (setq! bv offset 0 5 value))) | |
246 | (set1! (lambda (bv offset value) | |
247 | (setq! bv offset 5 8 (bit-field value 0 3)) | |
248 | (or (= (+ 1 offset) (bytevector-length bv)) | |
249 | (setq! bv (+ 1 offset) 0 2 (bit-field value 3 5))))) | |
250 | (set2! (lambda (bv offset value) | |
251 | (setq! bv offset 2 7 value))) | |
252 | (set3! (lambda (bv offset value) | |
253 | (setq! bv offset 7 8 (bit-field value 0 1)) | |
254 | (or (= (+ 1 offset) (bytevector-length bv)) | |
255 | (setq! bv (+ 1 offset) 0 4 (bit-field value 1 5))))) | |
256 | (set4! (lambda (bv offset value) | |
257 | (setq! bv offset 4 8 (bit-field value 0 4)) | |
258 | (or (= (+ 1 offset) (bytevector-length bv)) | |
259 | (setq! bv (+ 1 offset) 0 1 (bit-field value 4 5))))) | |
260 | (set5! (lambda (bv offset value) | |
261 | (setq! bv offset 1 6 value))) | |
262 | (set6! (lambda (bv offset value) | |
263 | (setq! bv offset 6 8 (bit-field value 0 2)) | |
264 | (or (= (+ 1 offset) (bytevector-length bv)) | |
265 | (setq! bv (+ 1 offset) 0 3 (bit-field value 2 5))))) | |
266 | (set7! (lambda (bv offset value) | |
267 | (setq! bv offset 3 8 value))) | |
268 | (sets (vector set0! set1! set2! set3! set4! set5! set6! set7!))) | |
269 | (lambda (bv index value) | |
270 | "Set the INDEXth quintet of BV to VALUE, assuming quintets start from | |
271 | the least-significant bits." | |
272 | (let ((p (vector-ref sets (modulo index 8)))) | |
273 | (p bv (quotient (* index 5) 8) (logand value #x1f)))))) | |
274 | ||
275 | (define (base32-string-unfold f s) | |
276 | "Given procedure F which, when applied to a character, returns the | |
277 | corresponding quintet, return the bytevector corresponding to string S." | |
278 | (define len (string-length s)) | |
279 | ||
280 | (let ((bv (make-bytevector (quotient (* len 5) 8)))) | |
281 | (string-fold (lambda (chr index) | |
282 | (bytevector-quintet-set! bv index (f chr)) | |
283 | (+ 1 index)) | |
284 | 0 | |
285 | s) | |
286 | bv)) | |
287 | ||
288 | (define (base32-string-unfold-right f s) | |
289 | "Given procedure F which, when applied to a character, returns the | |
290 | corresponding quintet, return the bytevector corresponding to string S, | |
291 | starting from the right of S." | |
292 | (define len (string-length s)) | |
293 | ||
294 | (let ((bv (make-bytevector (quotient (* len 5) 8)))) | |
295 | (string-fold-right (lambda (chr index) | |
296 | (bytevector-quintet-set-right! bv index (f chr)) | |
297 | (+ 1 index)) | |
298 | 0 | |
299 | s) | |
300 | bv)) | |
301 | ||
1a706ff5 LC |
302 | ;; Invalid base32 character error condition when decoding base32. |
303 | (define-condition-type &invalid-base32-character &error | |
304 | invalid-base32-character? | |
305 | (character invalid-base32-character-value) | |
306 | (string invalid-base32-character-string)) | |
307 | ||
ddc29a78 LC |
308 | (define (make-base32-string->bytevector base32-string-unfold base32-chars) |
309 | (let ((char->value (let loop ((i 0) | |
310 | (v vlist-null)) | |
311 | (if (= i (vector-length base32-chars)) | |
312 | v | |
313 | (loop (+ 1 i) | |
314 | (vhash-consv (vector-ref base32-chars i) | |
315 | i v)))))) | |
316 | (lambda (s) | |
317 | "Return the binary representation of base32 string S as a bytevector." | |
318 | (base32-string-unfold (lambda (chr) | |
319 | (or (and=> (vhash-assv chr char->value) cdr) | |
1a706ff5 LC |
320 | (raise (condition |
321 | (&invalid-base32-character | |
322 | (character chr) | |
323 | (string s)))))) | |
ddc29a78 LC |
324 | s)))) |
325 | ||
326 | (define base32-string->bytevector | |
327 | (make-base32-string->bytevector base32-string-unfold %rfc4648-base32-chars)) | |
328 | ||
329 | (define nix-base32-string->bytevector | |
330 | (make-base32-string->bytevector base32-string-unfold-right %nix-base32-chars)) | |
331 | ||
332 | ;;; base32.scm ends here |