Commit | Line | Data |
---|---|---|
233e7676 LC |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2012 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) | |
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 |