1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2012, 2015, 2017, 2021 Ludovic Courtès <ludo@gnu.org>
4 ;;; This file is part of GNU Guix.
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.
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.
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/>.
19 (define-module (guix base32)
20 #:use-module (srfi srfi-1)
21 #:use-module (srfi srfi-34)
22 #:use-module (srfi srfi-35)
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
30 nix-base32-string->bytevector
32 %rfc4648-base32-charset
33 &invalid-base32-character
34 invalid-base32-character?
35 invalid-base32-character-value
36 invalid-base32-character-string))
40 ;;; A generic, customizable to convert bytevectors to/from a base32
45 (define-syntax bit-field
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.)
53 (let* ((s (syntax->datum #'start))
54 (e (syntax->datum #'end))
55 (mask (- (expt 2 (- e s)) 1)))
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)))))))
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))
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)))
95 "Return the INDEXth quintet of BV."
96 (let ((p (vector-ref refs (modulo index 8))))
97 (p bv (quotient (* index 5) 8))))))
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))
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)))
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))))))
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)))
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."
141 (bytevector-quintet-length bv))
147 (loop (1+ i) (proc (bytevector-quintet-ref bv i) r)))))
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."
153 (bytevector-quintet-length bv))
160 (loop j (proc (bytevector-quintet-ref-right bv j) r))))))
162 (define (make-bytevector->base32-string quintet-fold base32-chars)
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)
170 (list->string (reverse chars)))))
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))
178 (define %nix-base32-charset
179 (list->char-set (vector->list %nix-base32-chars)))
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))
186 (define %rfc4648-base32-charset
187 (list->char-set (vector->list %rfc4648-base32-chars)))
189 (define bytevector->base32-string
190 (make-bytevector->base32-string bytevector-quintet-fold
191 %rfc4648-base32-chars))
193 (define bytevector->nix-base32-string
194 (make-bytevector->base32-string bytevector-quintet-fold-right
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))))))
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))))))
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))
280 (let ((bv (make-bytevector (quotient (* len 5) 8))))
281 (string-fold (lambda (chr index)
282 (bytevector-quintet-set! bv index (f chr))
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))
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))
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))
308 (define (make-base32-string->bytevector base32-string-unfold base32-chars)
309 (let ((char->value (let loop ((i 0)
311 (if (= i (vector-length base32-chars))
314 (vhash-consv (vector-ref base32-chars i)
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)
321 (&invalid-base32-character
326 (define base32-string->bytevector
327 (make-base32-string->bytevector base32-string-unfold %rfc4648-base32-chars))
329 (define nix-base32-string->bytevector
330 (make-base32-string->bytevector base32-string-unfold-right %nix-base32-chars))
332 ;;; base32.scm ends here