guix/base32.scm

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