guix/base64.scm

   1 ;; -*- mode: scheme; coding: utf-8 -*-
   2 ;;
   3 ;; This module was renamed from (weinholt text base64 (1 0 20100612)) to
   4 ;; (guix base64) by Nikita Karetnikov <nikita@karetnikov.org> on
   5 ;; February 12, 2014.
   6 ;;
   7 ;; Some optimizations made by Ludovic Courtès <ludo@gnu.org>, 2015.
   8 ;;
   9 ;; Copyright © 2009, 2010 Göran Weinholt <goran@weinholt.se>
  10 ;;
  11 ;; This program is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15 ;;
  16 ;; This program is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20 ;;
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  23 #!r6rs
  24
  25 ;; RFC 4648 Base-N Encodings
  26
  27 (library (guix base64)
  28   (export base64-encode
  29           base64-decode
  30           base64-alphabet
  31           base64url-alphabet
  32           get-delimited-base64
  33           put-delimited-base64)
  34   (import (rnrs)
  35           (only (srfi :13 strings)
  36                 string-index
  37                 string-prefix? string-suffix?
  38                 string-concatenate string-trim-both)
  39           (only (guile) ash logior))
  40
  41
  42   (define-syntax define-alias
  43     (syntax-rules ()
  44       ((_ new old)
  45        (define-syntax new (identifier-syntax old)))))
  46
  47   ;; Force the use of Guile's own primitives to avoid the overhead of its 'fx'
  48   ;; procedures.
  49   (define-alias fxbit-field bitwise-bit-field)
  50   (define-alias fxarithmetic-shift ash)
  51   (define-alias fxarithmetic-shift-left ash)
  52   (define-alias fxand logand)
  53   (define-alias fxior logior)
  54   (define-alias fxxor logxor)
  55
  56   (define base64-alphabet
  57     "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
  58
  59   (define base64url-alphabet
  60     "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_")
  61
  62   (define base64-encode
  63     (case-lambda
  64       ;; Simple interface. Returns a string containing the canonical
  65       ;; base64 representation of the given bytevector.
  66       ((bv)
  67        (base64-encode bv 0 (bytevector-length bv) #f #f base64-alphabet #f))
  68       ((bv start)
  69        (base64-encode bv start (bytevector-length bv) #f #f base64-alphabet #f))
  70       ((bv start end)
  71        (base64-encode bv start end #f #f base64-alphabet #f))
  72       ((bv start end line-length)
  73        (base64-encode bv start end line-length #f base64-alphabet #f))
  74       ((bv start end line-length no-padding)
  75        (base64-encode bv start end line-length no-padding base64-alphabet #f))
  76       ((bv start end line-length no-padding alphabet)
  77        (base64-encode bv start end line-length no-padding alphabet #f))
  78       ;; Base64 encodes the bytes [start,end[ in the given bytevector.
  79       ;; Lines are limited to line-length characters (unless #f),
  80       ;; which must be a multiple of four. To omit the padding
  81       ;; characters (#\=) set no-padding to a true value. If port is
  82       ;; #f, returns a string.
  83       ((bv start end line-length no-padding alphabet port)
  84        (assert (or (not line-length) (zero? (mod line-length 4))))
  85        (let-values (((p extract) (if port
  86                                      (values port (lambda () (values)))
  87                                      (open-string-output-port))))
  88          (letrec ((put (if line-length
  89                            (let ((chars 0))
  90                              (lambda (p c)
  91                                (when (fx=? chars line-length)
  92                                  (set! chars 0)
  93                                  (put-char p #\linefeed))
  94                                (set! chars (fx+ chars 1))
  95                                (put-char p c)))
  96                            put-char)))
  97            (let lp ((i start))
  98              (cond ((= i end))
  99                    ((<= (+ i 3) end)
 100                     (let ((x (bytevector-uint-ref bv i (endianness big) 3)))
 101                       (put p (string-ref alphabet (fxbit-field x 18 24)))
 102                       (put p (string-ref alphabet (fxbit-field x 12 18)))
 103                       (put p (string-ref alphabet (fxbit-field x 6 12)))
 104                       (put p (string-ref alphabet (fxbit-field x 0 6)))
 105                       (lp (+ i 3))))
 106                    ((<= (+ i 2) end)
 107                     (let ((x (fxarithmetic-shift-left (bytevector-u16-ref bv i (endianness big)) 8)))
 108                       (put p (string-ref alphabet (fxbit-field x 18 24)))
 109                       (put p (string-ref alphabet (fxbit-field x 12 18)))
 110                       (put p (string-ref alphabet (fxbit-field x 6 12)))
 111                       (unless no-padding
 112                         (put p #\=))))
 113                    (else
 114                     (let ((x (fxarithmetic-shift-left (bytevector-u8-ref bv i) 16)))
 115                       (put p (string-ref alphabet (fxbit-field x 18 24)))
 116                       (put p (string-ref alphabet (fxbit-field x 12 18)))
 117                       (unless no-padding
 118                         (put p #\=)
 119                         (put p #\=)))))))
 120          (extract)))))
 121
 122   ;; Decodes a base64 string. The string must contain only pure
 123   ;; unpadded base64 data.
 124   (define base64-decode
 125     (case-lambda
 126       ((str)
 127        (base64-decode str base64-alphabet #f))
 128       ((str alphabet)
 129        (base64-decode str alphabet #f))
 130       ((str alphabet port)
 131        (unless (zero? (mod (string-length str) 4))
 132          (error 'base64-decode
 133                 "input string must be a multiple of four characters"))
 134        (let-values (((p extract) (if port
 135                                      (values port (lambda () (values)))
 136                                      (open-bytevector-output-port))))
 137          (do ((i 0 (+ i 4)))
 138              ((= i (string-length str))
 139               (extract))
 140            (let ((c1 (string-ref str i))
 141                  (c2 (string-ref str (+ i 1)))
 142                  (c3 (string-ref str (+ i 2)))
 143                  (c4 (string-ref str (+ i 3))))
 144              ;; TODO: be more clever than string-index
 145              (let ((i1 (string-index alphabet c1))
 146                    (i2 (string-index alphabet c2))
 147                    (i3 (string-index alphabet c3))
 148                    (i4 (string-index alphabet c4)))
 149                (cond ((and i1 i2 i3 i4)
 150                       (let ((x (fxior (fxarithmetic-shift-left i1 18)
 151                                       (fxarithmetic-shift-left i2 12)
 152                                       (fxarithmetic-shift-left i3 6)
 153                                       i4)))
 154                         (put-u8 p (fxbit-field x 16 24))
 155                         (put-u8 p (fxbit-field x 8 16))
 156                         (put-u8 p (fxbit-field x 0 8))))
 157                      ((and i1 i2 i3 (char=? c4 #\=)
 158                            (= i (- (string-length str) 4)))
 159                       (let ((x (fxior (fxarithmetic-shift-left i1 18)
 160                                       (fxarithmetic-shift-left i2 12)
 161                                       (fxarithmetic-shift-left i3 6))))
 162                         (put-u8 p (fxbit-field x 16 24))
 163                         (put-u8 p (fxbit-field x 8 16))))
 164                      ((and i1 i2 (char=? c3 #\=) (char=? c4 #\=)
 165                            (= i (- (string-length str) 4)))
 166                       (let ((x (fxior (fxarithmetic-shift-left i1 18)
 167                                       (fxarithmetic-shift-left i2 12))))
 168                         (put-u8 p (fxbit-field x 16 24))))
 169                      (else
 170                       (error 'base64-decode "invalid input"
 171                              (list c1 c2 c3 c4)))))))))))
 172
 173   (define (get-line-comp f port)
 174     (if (port-eof? port)
 175         (eof-object)
 176         (f (get-line port))))
 177
 178   ;; Reads the common -----BEGIN/END type----- delimited format from
 179   ;; the given port. Returns two values: a string with the type and a
 180   ;; bytevector containing the base64 decoded data. The second value
 181   ;; is the eof object if there is an eof before the BEGIN delimiter.
 182   (define (get-delimited-base64 port)
 183     (define (get-first-data-line port)
 184       ;; Some MIME data has header fields in the same format as mail
 185       ;; or http. These are ignored.
 186       (let ((line (get-line-comp string-trim-both port)))
 187         (cond ((eof-object? line) line)
 188               ((string-index line #\:)
 189                (let lp ()               ;read until empty line
 190                  (let ((line (get-line-comp string-trim-both port)))
 191                    (if (string=? line "")
 192                        (get-line-comp string-trim-both port)
 193                        (lp)))))
 194               (else line))))
 195     (let ((line (get-line-comp string-trim-both port)))
 196       (cond ((eof-object? line)
 197              (values "" (eof-object)))
 198             ((string=? line "")
 199              (get-delimited-base64 port))
 200             ((and (string-prefix? "-----BEGIN " line)
 201                   (string-suffix? "-----" line))
 202              (let* ((type (substring line 11 (- (string-length line) 5)))
 203                     (endline (string-append "-----END " type "-----")))
 204                (let-values (((outp extract) (open-bytevector-output-port)))
 205                  (let lp ((line (get-first-data-line port)))
 206                    (cond ((eof-object? line)
 207                           (error 'get-delimited-base64
 208                                  "unexpected end of file"))
 209                          ((string-prefix? "-" line)
 210                           (unless (string=? line endline)
 211                             (error 'get-delimited-base64
 212                                    "bad end delimiter" type line))
 213                           (values type (extract)))
 214                          (else
 215                           (unless (and (= (string-length line) 5)
 216                                        (string-prefix? "=" line)) ;Skip Radix-64 checksum
 217                             (base64-decode line base64-alphabet outp))
 218                           (lp (get-line-comp string-trim-both port))))))))
 219             (else ;skip garbage (like in openssl x509 -in foo -text output).
 220              (get-delimited-base64 port)))))
 221
 222   (define put-delimited-base64
 223     (case-lambda
 224       ((port type bv line-length)
 225        (display (string-append "-----BEGIN " type "-----\n") port)
 226        (base64-encode bv 0 (bytevector-length bv)
 227                       line-length #f base64-alphabet port)
 228        (display (string-append "\n-----END " type "-----\n") port))
 229       ((port type bv)
 230        (put-delimited-base64 port type bv 76)))))