Commit | Line | Data |
---|---|---|
233e7676 | 1 | ;;; GNU Guix --- Functional package management for GNU |
0a94dc63 | 2 | ;;; Copyright © 2012, 2015, 2017 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 | ||
45 | (define bytevector-quintet-ref | |
46 | (let* ((ref bytevector-u8-ref) | |
47 | (ref+ (lambda (bv offset) | |
48 | (let ((o (+ 1 offset))) | |
49 | (if (>= o (bytevector-length bv)) | |
50 | 0 | |
51 | (bytevector-u8-ref bv o))))) | |
52 | (ref0 (lambda (bv offset) | |
53 | (bit-field (ref bv offset) 3 8))) | |
54 | (ref1 (lambda (bv offset) | |
55 | (logior (ash (bit-field (ref bv offset) 0 3) 2) | |
56 | (bit-field (ref+ bv offset) 6 8)))) | |
57 | (ref2 (lambda (bv offset) | |
58 | (bit-field (ref bv offset) 1 6))) | |
59 | (ref3 (lambda (bv offset) | |
60 | (logior (ash (bit-field (ref bv offset) 0 1) 4) | |
61 | (bit-field (ref+ bv offset) 4 8)))) | |
62 | (ref4 (lambda (bv offset) | |
63 | (logior (ash (bit-field (ref bv offset) 0 4) 1) | |
64 | (bit-field (ref+ bv offset) 7 8)))) | |
65 | (ref5 (lambda (bv offset) | |
66 | (bit-field (ref bv offset) 2 7))) | |
67 | (ref6 (lambda (bv offset) | |
68 | (logior (ash (bit-field (ref bv offset) 0 2) 3) | |
69 | (bit-field (ref+ bv offset) 5 8)))) | |
70 | (ref7 (lambda (bv offset) | |
71 | (bit-field (ref bv offset) 0 5))) | |
72 | (refs (vector ref0 ref1 ref2 ref3 ref4 ref5 ref6 ref7))) | |
73 | (lambda (bv index) | |
74 | "Return the INDEXth quintet of BV." | |
75 | (let ((p (vector-ref refs (modulo index 8)))) | |
76 | (p bv (quotient (* index 5) 8)))))) | |
77 | ||
78 | (define bytevector-quintet-ref-right | |
79 | (let* ((ref bytevector-u8-ref) | |
80 | (ref+ (lambda (bv offset) | |
81 | (let ((o (+ 1 offset))) | |
82 | (if (>= o (bytevector-length bv)) | |
83 | 0 | |
84 | (bytevector-u8-ref bv o))))) | |
85 | (ref0 (lambda (bv offset) | |
86 | (bit-field (ref bv offset) 0 5))) | |
87 | (ref1 (lambda (bv offset) | |
88 | (logior (bit-field (ref bv offset) 5 8) | |
89 | (ash (bit-field (ref+ bv offset) 0 2) 3)))) | |
90 | (ref2 (lambda (bv offset) | |
91 | (bit-field (ref bv offset) 2 7))) | |
92 | (ref3 (lambda (bv offset) | |
93 | (logior (bit-field (ref bv offset) 7 8) | |
94 | (ash (bit-field (ref+ bv offset) 0 4) 1)))) | |
95 | (ref4 (lambda (bv offset) | |
96 | (logior (bit-field (ref bv offset) 4 8) | |
97 | (ash (bit-field (ref+ bv offset) 0 1) 4)))) | |
98 | (ref5 (lambda (bv offset) | |
99 | (bit-field (ref bv offset) 1 6))) | |
100 | (ref6 (lambda (bv offset) | |
101 | (logior (bit-field (ref bv offset) 6 8) | |
102 | (ash (bit-field (ref+ bv offset) 0 3) 2)))) | |
103 | (ref7 (lambda (bv offset) | |
104 | (bit-field (ref bv offset) 3 8))) | |
105 | (refs (vector ref0 ref1 ref2 ref3 ref4 ref5 ref6 ref7))) | |
106 | (lambda (bv index) | |
107 | "Return the INDEXth quintet of BV, assuming quintets start from the | |
108 | least-significant bits, contrary to what RFC 4648 describes." | |
109 | (let ((p (vector-ref refs (modulo index 8)))) | |
110 | (p bv (quotient (* index 5) 8)))))) | |
111 | ||
112 | (define (bytevector-quintet-length bv) | |
113 | "Return the number of quintets (including truncated ones) available in BV." | |
114 | (ceiling (/ (* (bytevector-length bv) 8) 5))) | |
115 | ||
116 | (define (bytevector-quintet-fold proc init bv) | |
117 | "Return the result of applying PROC to each quintet of BV and the result of | |
118 | the previous application or INIT." | |
119 | (define len | |
120 | (bytevector-quintet-length bv)) | |
121 | ||
122 | (let loop ((i 0) | |
123 | (r init)) | |
124 | (if (= i len) | |
125 | r | |
126 | (loop (1+ i) (proc (bytevector-quintet-ref bv i) r))))) | |
127 | ||
128 | (define (bytevector-quintet-fold-right proc init bv) | |
129 | "Return the result of applying PROC to each quintet of BV and the result of | |
130 | the previous application or INIT." | |
131 | (define len | |
132 | (bytevector-quintet-length bv)) | |
133 | ||
134 | (let loop ((i len) | |
135 | (r init)) | |
136 | (if (zero? i) | |
137 | r | |
138 | (let ((j (- i 1))) | |
139 | (loop j (proc (bytevector-quintet-ref-right bv j) r)))))) | |
140 | ||
141 | (define (make-bytevector->base32-string quintet-fold base32-chars) | |
142 | (lambda (bv) | |
143 | "Return a base32 encoding of BV using BASE32-CHARS as the alphabet." | |
144 | (let ((chars (quintet-fold (lambda (q r) | |
145 | (cons (vector-ref base32-chars q) | |
146 | r)) | |
147 | '() | |
148 | bv))) | |
149 | (list->string (reverse chars))))) | |
150 | ||
151 | (define %nix-base32-chars | |
152 | ;; See `libutil/hash.cc'. | |
153 | #(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 | |
154 | #\a #\b #\c #\d #\f #\g #\h #\i #\j #\k #\l #\m #\n | |
155 | #\p #\q #\r #\s #\v #\w #\x #\y #\z)) | |
156 | ||
0a94dc63 LC |
157 | (define %nix-base32-charset |
158 | (list->char-set (vector->list %nix-base32-chars))) | |
159 | ||
ddc29a78 LC |
160 | (define %rfc4648-base32-chars |
161 | #(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m | |
162 | #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z | |
163 | #\2 #\3 #\4 #\5 #\6 #\7)) | |
164 | ||
0a94dc63 LC |
165 | (define %rfc4648-base32-charset |
166 | (list->char-set (vector->list %rfc4648-base32-chars))) | |
167 | ||
ddc29a78 LC |
168 | (define bytevector->base32-string |
169 | (make-bytevector->base32-string bytevector-quintet-fold | |
170 | %rfc4648-base32-chars)) | |
171 | ||
172 | (define bytevector->nix-base32-string | |
173 | (make-bytevector->base32-string bytevector-quintet-fold-right | |
174 | %nix-base32-chars)) | |
175 | ||
176 | ||
177 | (define bytevector-quintet-set! | |
178 | (let* ((setq! (lambda (bv offset start stop value) | |
179 | (let ((v (bytevector-u8-ref bv offset)) | |
180 | (w (arithmetic-shift value start)) | |
181 | (m (bitwise-xor (1- (expt 2 stop)) | |
182 | (1- (expt 2 start))))) | |
183 | (bytevector-u8-set! bv offset | |
184 | (bitwise-merge m w v))))) | |
185 | (set0! (lambda (bv offset value) | |
186 | (setq! bv offset 3 8 value))) | |
187 | (set1! (lambda (bv offset value) | |
188 | (setq! bv offset 0 3 (bit-field value 2 5)) | |
189 | (or (= (+ 1 offset) (bytevector-length bv)) | |
190 | (setq! bv (+ 1 offset) 6 8 (bit-field value 0 2))))) | |
191 | (set2! (lambda (bv offset value) | |
192 | (setq! bv offset 1 6 value))) | |
193 | (set3! (lambda (bv offset value) | |
194 | (setq! bv offset 0 1 (bit-field value 4 5)) | |
195 | (or (= (+ 1 offset) (bytevector-length bv)) | |
196 | (setq! bv (+ 1 offset) 4 8 (bit-field value 0 4))))) | |
197 | (set4! (lambda (bv offset value) | |
198 | (setq! bv offset 0 4 (bit-field value 1 5)) | |
199 | (or (= (+ 1 offset) (bytevector-length bv)) | |
200 | (setq! bv (+ 1 offset) 7 8 (bit-field value 0 1))))) | |
201 | (set5! (lambda (bv offset value) | |
202 | (setq! bv offset 2 7 value))) | |
203 | (set6! (lambda (bv offset value) | |
204 | (setq! bv offset 0 2 (bit-field value 3 5)) | |
205 | (or (= (+ 1 offset) (bytevector-length bv)) | |
206 | (setq! bv (+ 1 offset) 5 8 (bit-field value 0 3))))) | |
207 | (set7! (lambda (bv offset value) | |
208 | (setq! bv offset 0 5 value))) | |
209 | (sets (vector set0! set1! set2! set3! set4! set5! set6! set7!))) | |
210 | (lambda (bv index value) | |
211 | "Set the INDEXth quintet of BV to VALUE." | |
212 | (let ((p (vector-ref sets (modulo index 8)))) | |
213 | (p bv (quotient (* index 5) 8) (logand value #x1f)))))) | |
214 | ||
215 | (define bytevector-quintet-set-right! | |
216 | (let* ((setq! (lambda (bv offset start stop value) | |
217 | (let ((v (bytevector-u8-ref bv offset)) | |
218 | (w (arithmetic-shift value start)) | |
219 | (m (bitwise-xor (1- (expt 2 stop)) | |
220 | (1- (expt 2 start))))) | |
221 | (bytevector-u8-set! bv offset | |
222 | (bitwise-merge m w v))))) | |
223 | (set0! (lambda (bv offset value) | |
224 | (setq! bv offset 0 5 value))) | |
225 | (set1! (lambda (bv offset value) | |
226 | (setq! bv offset 5 8 (bit-field value 0 3)) | |
227 | (or (= (+ 1 offset) (bytevector-length bv)) | |
228 | (setq! bv (+ 1 offset) 0 2 (bit-field value 3 5))))) | |
229 | (set2! (lambda (bv offset value) | |
230 | (setq! bv offset 2 7 value))) | |
231 | (set3! (lambda (bv offset value) | |
232 | (setq! bv offset 7 8 (bit-field value 0 1)) | |
233 | (or (= (+ 1 offset) (bytevector-length bv)) | |
234 | (setq! bv (+ 1 offset) 0 4 (bit-field value 1 5))))) | |
235 | (set4! (lambda (bv offset value) | |
236 | (setq! bv offset 4 8 (bit-field value 0 4)) | |
237 | (or (= (+ 1 offset) (bytevector-length bv)) | |
238 | (setq! bv (+ 1 offset) 0 1 (bit-field value 4 5))))) | |
239 | (set5! (lambda (bv offset value) | |
240 | (setq! bv offset 1 6 value))) | |
241 | (set6! (lambda (bv offset value) | |
242 | (setq! bv offset 6 8 (bit-field value 0 2)) | |
243 | (or (= (+ 1 offset) (bytevector-length bv)) | |
244 | (setq! bv (+ 1 offset) 0 3 (bit-field value 2 5))))) | |
245 | (set7! (lambda (bv offset value) | |
246 | (setq! bv offset 3 8 value))) | |
247 | (sets (vector set0! set1! set2! set3! set4! set5! set6! set7!))) | |
248 | (lambda (bv index value) | |
249 | "Set the INDEXth quintet of BV to VALUE, assuming quintets start from | |
250 | the least-significant bits." | |
251 | (let ((p (vector-ref sets (modulo index 8)))) | |
252 | (p bv (quotient (* index 5) 8) (logand value #x1f)))))) | |
253 | ||
254 | (define (base32-string-unfold f s) | |
255 | "Given procedure F which, when applied to a character, returns the | |
256 | corresponding quintet, return the bytevector corresponding to string S." | |
257 | (define len (string-length s)) | |
258 | ||
259 | (let ((bv (make-bytevector (quotient (* len 5) 8)))) | |
260 | (string-fold (lambda (chr index) | |
261 | (bytevector-quintet-set! bv index (f chr)) | |
262 | (+ 1 index)) | |
263 | 0 | |
264 | s) | |
265 | bv)) | |
266 | ||
267 | (define (base32-string-unfold-right f s) | |
268 | "Given procedure F which, when applied to a character, returns the | |
269 | corresponding quintet, return the bytevector corresponding to string S, | |
270 | starting from the right of S." | |
271 | (define len (string-length s)) | |
272 | ||
273 | (let ((bv (make-bytevector (quotient (* len 5) 8)))) | |
274 | (string-fold-right (lambda (chr index) | |
275 | (bytevector-quintet-set-right! bv index (f chr)) | |
276 | (+ 1 index)) | |
277 | 0 | |
278 | s) | |
279 | bv)) | |
280 | ||
1a706ff5 LC |
281 | ;; Invalid base32 character error condition when decoding base32. |
282 | (define-condition-type &invalid-base32-character &error | |
283 | invalid-base32-character? | |
284 | (character invalid-base32-character-value) | |
285 | (string invalid-base32-character-string)) | |
286 | ||
ddc29a78 LC |
287 | (define (make-base32-string->bytevector base32-string-unfold base32-chars) |
288 | (let ((char->value (let loop ((i 0) | |
289 | (v vlist-null)) | |
290 | (if (= i (vector-length base32-chars)) | |
291 | v | |
292 | (loop (+ 1 i) | |
293 | (vhash-consv (vector-ref base32-chars i) | |
294 | i v)))))) | |
295 | (lambda (s) | |
296 | "Return the binary representation of base32 string S as a bytevector." | |
297 | (base32-string-unfold (lambda (chr) | |
298 | (or (and=> (vhash-assv chr char->value) cdr) | |
1a706ff5 LC |
299 | (raise (condition |
300 | (&invalid-base32-character | |
301 | (character chr) | |
302 | (string s)))))) | |
ddc29a78 LC |
303 | s)))) |
304 | ||
305 | (define base32-string->bytevector | |
306 | (make-base32-string->bytevector base32-string-unfold %rfc4648-base32-chars)) | |
307 | ||
308 | (define nix-base32-string->bytevector | |
309 | (make-base32-string->bytevector base32-string-unfold-right %nix-base32-chars)) | |
310 | ||
311 | ;;; base32.scm ends here |