[jackhill/guix/guix.git] / guix / base32.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2015 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix base32)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (srfi srfi-60)
  #:use-module (rnrs bytevectors)
  #:use-module (ice-9 vlist)
  #:export (bytevector-quintet-length
            bytevector->base32-string
            bytevector->nix-base32-string
            base32-string->bytevector
            nix-base32-string->bytevector
            &invalid-base32-character
            invalid-base32-character?
            invalid-base32-character-value
            invalid-base32-character-string))

;;; Commentary:
;;;
;;; A generic, customizable to convert bytevectors to/from a base32
;;; representation.
;;;
;;; Code:

(define bytevector-quintet-ref
  (let* ((ref  bytevector-u8-ref)
         (ref+ (lambda (bv offset)
                 (let ((o (+ 1 offset)))
                   (if (>= o (bytevector-length bv))
                       0
                       (bytevector-u8-ref bv o)))))
         (ref0 (lambda (bv offset)
                 (bit-field (ref bv offset) 3 8)))
         (ref1 (lambda (bv offset)
                 (logior (ash (bit-field (ref bv offset) 0 3) 2)
                         (bit-field (ref+ bv offset) 6 8))))
         (ref2 (lambda (bv offset)
                 (bit-field (ref bv offset) 1 6)))
         (ref3 (lambda (bv offset)
                 (logior (ash (bit-field (ref bv offset) 0 1) 4)
                         (bit-field (ref+ bv offset) 4 8))))
         (ref4 (lambda (bv offset)
                 (logior (ash (bit-field (ref bv offset) 0 4) 1)
                         (bit-field (ref+ bv offset) 7 8))))
         (ref5 (lambda (bv offset)
                 (bit-field (ref bv offset) 2 7)))
         (ref6 (lambda (bv offset)
                 (logior (ash (bit-field (ref bv offset) 0 2) 3)
                         (bit-field (ref+ bv offset) 5 8))))
         (ref7 (lambda (bv offset)
                 (bit-field (ref bv offset) 0 5)))
         (refs (vector ref0 ref1 ref2 ref3 ref4 ref5 ref6 ref7)))
    (lambda (bv index)
      "Return the INDEXth quintet of BV."
      (let ((p (vector-ref refs (modulo index 8))))
        (p bv (quotient (* index 5) 8))))))

(define bytevector-quintet-ref-right
  (let* ((ref  bytevector-u8-ref)
         (ref+ (lambda (bv offset)
                 (let ((o (+ 1 offset)))
                   (if (>= o (bytevector-length bv))
                       0
                       (bytevector-u8-ref bv o)))))
         (ref0 (lambda (bv offset)
                 (bit-field (ref bv offset) 0 5)))
         (ref1 (lambda (bv offset)
                 (logior (bit-field (ref bv offset) 5 8)
                         (ash (bit-field (ref+ bv offset) 0 2) 3))))
         (ref2 (lambda (bv offset)
                 (bit-field (ref bv offset) 2 7)))
         (ref3 (lambda (bv offset)
                 (logior (bit-field (ref bv offset) 7 8)
                         (ash (bit-field (ref+ bv offset) 0 4) 1))))
         (ref4 (lambda (bv offset)
                 (logior (bit-field (ref bv offset) 4 8)
                         (ash (bit-field (ref+ bv offset) 0 1) 4))))
         (ref5 (lambda (bv offset)
                 (bit-field (ref bv offset) 1 6)))
         (ref6 (lambda (bv offset)
                 (logior (bit-field (ref bv offset) 6 8)
                         (ash (bit-field (ref+ bv offset) 0 3) 2))))
         (ref7 (lambda (bv offset)
                 (bit-field (ref bv offset) 3 8)))
         (refs (vector ref0 ref1 ref2 ref3 ref4 ref5 ref6 ref7)))
    (lambda (bv index)
      "Return the INDEXth quintet of BV, assuming quintets start from the
least-significant bits, contrary to what RFC 4648 describes."
      (let ((p (vector-ref refs (modulo index 8))))
        (p bv (quotient (* index 5) 8))))))

(define (bytevector-quintet-length bv)
  "Return the number of quintets (including truncated ones) available in BV."
  (ceiling (/ (* (bytevector-length bv) 8) 5)))

(define (bytevector-quintet-fold proc init bv)
  "Return the result of applying PROC to each quintet of BV and the result of
the previous application or INIT."
  (define len
    (bytevector-quintet-length bv))

  (let loop ((i 0)
             (r init))
    (if (= i len)
        r
        (loop (1+ i) (proc (bytevector-quintet-ref bv i) r)))))

(define (bytevector-quintet-fold-right proc init bv)
  "Return the result of applying PROC to each quintet of BV and the result of
the previous application or INIT."
  (define len
    (bytevector-quintet-length bv))

  (let loop ((i len)
             (r init))
    (if (zero? i)
        r
        (let ((j (- i 1)))
          (loop j (proc (bytevector-quintet-ref-right bv j) r))))))

(define (make-bytevector->base32-string quintet-fold base32-chars)
  (lambda (bv)
    "Return a base32 encoding of BV using BASE32-CHARS as the alphabet."
    (let ((chars (quintet-fold (lambda (q r)
                                 (cons (vector-ref base32-chars q)
                                       r))
                               '()
                               bv)))
      (list->string (reverse chars)))))

(define %nix-base32-chars
  ;; See `libutil/hash.cc'.
  #(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9
    #\a #\b #\c #\d #\f #\g #\h #\i #\j #\k #\l #\m #\n
    #\p #\q #\r #\s #\v #\w #\x #\y #\z))

(define %rfc4648-base32-chars
  #(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m
    #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z
    #\2 #\3 #\4 #\5 #\6 #\7))

(define bytevector->base32-string
  (make-bytevector->base32-string bytevector-quintet-fold
                                  %rfc4648-base32-chars))

(define bytevector->nix-base32-string
  (make-bytevector->base32-string bytevector-quintet-fold-right
                                  %nix-base32-chars))


(define bytevector-quintet-set!
  (let* ((setq! (lambda (bv offset start stop value)
                  (let ((v (bytevector-u8-ref bv offset))
                        (w (arithmetic-shift value start))
                        (m (bitwise-xor (1- (expt 2 stop))
                                        (1- (expt 2 start)))))
                    (bytevector-u8-set! bv offset
                                        (bitwise-merge m w v)))))
         (set0! (lambda (bv offset value)
                  (setq! bv offset 3 8 value)))
         (set1! (lambda (bv offset value)
                  (setq! bv offset 0 3 (bit-field value 2 5))
                  (or (= (+ 1 offset) (bytevector-length bv))
                      (setq! bv (+ 1 offset) 6 8 (bit-field value 0 2)))))
         (set2! (lambda (bv offset value)
                  (setq! bv offset 1 6 value)))
         (set3! (lambda (bv offset value)
                  (setq! bv offset 0 1 (bit-field value 4 5))
                  (or (= (+ 1 offset) (bytevector-length bv))
                      (setq! bv (+ 1 offset) 4 8 (bit-field value 0 4)))))
         (set4! (lambda (bv offset value)
                  (setq! bv offset 0 4 (bit-field value 1 5))
                  (or (= (+ 1 offset) (bytevector-length bv))
                      (setq! bv (+ 1 offset) 7 8  (bit-field value 0 1)))))
         (set5! (lambda (bv offset value)
                  (setq! bv offset 2 7 value)))
         (set6! (lambda (bv offset value)
                  (setq! bv offset 0 2 (bit-field value 3 5))
                  (or (= (+ 1 offset) (bytevector-length bv))
                      (setq! bv (+ 1 offset) 5 8 (bit-field value 0 3)))))
         (set7! (lambda (bv offset value)
                  (setq! bv offset 0 5 value)))
         (sets  (vector set0! set1! set2! set3! set4! set5! set6! set7!)))
    (lambda (bv index value)
      "Set the INDEXth quintet of BV to VALUE."
      (let ((p (vector-ref sets (modulo index 8))))
        (p bv (quotient (* index 5) 8) (logand value #x1f))))))

(define bytevector-quintet-set-right!
  (let* ((setq! (lambda (bv offset start stop value)
                  (let ((v (bytevector-u8-ref bv offset))
                        (w (arithmetic-shift value start))
                        (m (bitwise-xor (1- (expt 2 stop))
                                        (1- (expt 2 start)))))
                    (bytevector-u8-set! bv offset
                                        (bitwise-merge m w v)))))
         (set0! (lambda (bv offset value)
                  (setq! bv offset 0 5 value)))
         (set1! (lambda (bv offset value)
                  (setq! bv offset 5 8 (bit-field value 0 3))
                  (or (= (+ 1 offset) (bytevector-length bv))
                      (setq! bv (+ 1 offset) 0 2 (bit-field value 3 5)))))
         (set2! (lambda (bv offset value)
                  (setq! bv offset 2 7 value)))
         (set3! (lambda (bv offset value)
                  (setq! bv offset 7 8 (bit-field value 0 1))
                  (or (= (+ 1 offset) (bytevector-length bv))
                      (setq! bv (+ 1 offset) 0 4 (bit-field value 1 5)))))
         (set4! (lambda (bv offset value)
                  (setq! bv offset 4 8 (bit-field value 0 4))
                  (or (= (+ 1 offset) (bytevector-length bv))
                      (setq! bv (+ 1 offset) 0 1 (bit-field value 4 5)))))
         (set5! (lambda (bv offset value)
                  (setq! bv offset 1 6 value)))
         (set6! (lambda (bv offset value)
                  (setq! bv offset 6 8 (bit-field value 0 2))
                  (or (= (+ 1 offset) (bytevector-length bv))
                      (setq! bv (+ 1 offset) 0 3 (bit-field value 2 5)))))
         (set7! (lambda (bv offset value)
                  (setq! bv offset 3 8 value)))
         (sets  (vector set0! set1! set2! set3! set4! set5! set6! set7!)))
    (lambda (bv index value)
      "Set the INDEXth quintet of BV to VALUE, assuming quintets start from
the least-significant bits."
      (let ((p (vector-ref sets (modulo index 8))))
        (p bv (quotient (* index 5) 8) (logand value #x1f))))))

(define (base32-string-unfold f s)
  "Given procedure F which, when applied to a character, returns the
corresponding quintet, return the bytevector corresponding to string S."
  (define len (string-length s))

  (let ((bv (make-bytevector (quotient (* len 5) 8))))
    (string-fold (lambda (chr index)
                   (bytevector-quintet-set! bv index (f chr))
                   (+ 1 index))
                 0
                 s)
    bv))

(define (base32-string-unfold-right f s)
  "Given procedure F which, when applied to a character, returns the
corresponding quintet, return the bytevector corresponding to string S,
starting from the right of S."
  (define len (string-length s))

  (let ((bv (make-bytevector (quotient (* len 5) 8))))
    (string-fold-right (lambda (chr index)
                         (bytevector-quintet-set-right! bv index (f chr))
                         (+ 1 index))
                       0
                       s)
    bv))

;; Invalid base32 character error condition when decoding base32.
(define-condition-type &invalid-base32-character &error
  invalid-base32-character?
  (character invalid-base32-character-value)
  (string    invalid-base32-character-string))

(define (make-base32-string->bytevector base32-string-unfold base32-chars)
  (let ((char->value (let loop ((i 0)
                                (v vlist-null))
                       (if (= i (vector-length base32-chars))
                           v
                           (loop (+ 1 i)
                                 (vhash-consv (vector-ref base32-chars i)
                                              i v))))))
    (lambda (s)
      "Return the binary representation of base32 string S as a bytevector."
      (base32-string-unfold (lambda (chr)
                              (or (and=> (vhash-assv chr char->value) cdr)
                                  (raise (condition
                                          (&invalid-base32-character
                                           (character chr)
                                           (string s))))))
                            s))))

(define base32-string->bytevector
  (make-base32-string->bytevector base32-string-unfold %rfc4648-base32-chars))

(define nix-base32-string->bytevector
  (make-base32-string->bytevector base32-string-unfold-right %nix-base32-chars))

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