guix/base32.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2015, 2017 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             %nix-base32-charset
  32             %rfc4648-base32-charset
  33             &invalid-base32-character
  34             invalid-base32-character?
  35             invalid-base32-character-value
  36             invalid-base32-character-string))
  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
 157 (define %nix-base32-charset
 158   (list->char-set (vector->list %nix-base32-chars)))
 159
 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
 165 (define %rfc4648-base32-charset
 166   (list->char-set (vector->list %rfc4648-base32-chars)))
 167
 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
 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
 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)
 299                                   (raise (condition
 300                                           (&invalid-base32-character
 301                                            (character chr)
 302                                            (string s))))))
 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