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

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2015, 2017 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
            %nix-base32-charset
            %rfc4648-base32-charset
            &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 %nix-base32-charset
  (list->char-set (vector->list %nix-base32-chars)))

(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 %rfc4648-base32-charset
  (list->char-set (vector->list %rfc4648-base32-chars)))

(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
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)
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	30	nix-base32-string->bytevector
0a94dc63 LC	31	%nix-base32-charset
0a94dc63 LC	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