guix/base32.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2015 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   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.
  10 ;;;
  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.
  15 ;;;
  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/>.
  18
  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
  31             &invalid-base32-character
  32             invalid-base32-character?
  33             invalid-base32-character-value
  34             invalid-base32-character-string))
  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
 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
 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)
 291                                   (raise (condition
 292                                           (&invalid-base32-character
 293                                            (character chr)
 294                                            (string s))))))
 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