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 ;; Turned into a Guile module (instead of R6RS).
   9 ;;
  10 ;; This program is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14 ;;
  15 ;; This program is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19 ;;
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  22 ;;
  23 ;; This file incorporates work covered by the following copyright and
  24 ;; permission notice:
  25 ;;
  26 ;;   Copyright © 2009, 2010 Göran Weinholt <goran@weinholt.se>
  27 ;;
  28 ;;   Permission is hereby granted, free of charge, to any person obtaining a
  29 ;;   copy of this software and associated documentation files (the "Software"),
  30 ;;   to deal in the Software without restriction, including without limitation
  31 ;;   the rights to use, copy, modify, merge, publish, distribute, sublicense,
  32 ;;   and/or sell copies of the Software, and to permit persons to whom the
  33 ;;   Software is furnished to do so, subject to the following conditions:
  34 ;;
  35 ;;   The above copyright notice and this permission notice shall be included in
  36 ;;   all copies or substantial portions of the Software.
  37 ;;
  38 ;;   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
  39 ;;   IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  40 ;;   FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
  41 ;;   THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  42 ;;   LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  43 ;;   FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  44 ;;   DEALINGS IN THE SOFTWARE.
  45
  46 ;; RFC 4648 Base-N Encodings
  47
  48 (define-module (guix base64)
  49   #:export (base64-encode
  50             base64-decode
  51             base64-alphabet
  52             base64url-alphabet
  53             get-delimited-base64
  54             put-delimited-base64)
  55   #:use-module (rnrs)
  56   #:use-module ((srfi srfi-13)
  57                 #:select (string-index
  58                           string-prefix? string-suffix?
  59                           string-concatenate string-trim-both)))
  60
  61
  62 (define-syntax define-alias
  63   (syntax-rules ()
  64     ((_ new old)
  65      (define-syntax new (identifier-syntax old)))))
  66
  67 ;; Force the use of Guile's own primitives to avoid the overhead of its 'fx'
  68 ;; procedures.
  69
  70 (define-alias fxbit-field bitwise-bit-field)
  71 (define-alias fxarithmetic-shift ash)
  72 (define-alias fxarithmetic-shift-left ash)
  73 (define-alias fxand logand)
  74 (define-alias fxior logior)
  75 (define-alias fxxor logxor)
  76
  77 (define base64-alphabet
  78   "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
  79
  80 (define base64url-alphabet
  81   "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_")
  82
  83 (define base64-encode
  84   (case-lambda
  85     ;; Simple interface. Returns a string containing the canonical
  86     ;; base64 representation of the given bytevector.
  87     ((bv)
  88      (base64-encode bv 0 (bytevector-length bv) #f #f base64-alphabet #f))
  89     ((bv start)
  90      (base64-encode bv start (bytevector-length bv) #f #f base64-alphabet #f))
  91     ((bv start end)
  92      (base64-encode bv start end #f #f base64-alphabet #f))
  93     ((bv start end line-length)
  94      (base64-encode bv start end line-length #f base64-alphabet #f))
  95     ((bv start end line-length no-padding)
  96      (base64-encode bv start end line-length no-padding base64-alphabet #f))
  97     ((bv start end line-length no-padding alphabet)
  98      (base64-encode bv start end line-length no-padding alphabet #f))
  99     ;; Base64 encodes the bytes [start,end[ in the given bytevector.
 100     ;; Lines are limited to line-length characters (unless #f),
 101     ;; which must be a multiple of four. To omit the padding
 102     ;; characters (#\=) set no-padding to a true value. If port is
 103     ;; #f, returns a string.
 104     ((bv start end line-length no-padding alphabet port)
 105      (assert (or (not line-length) (zero? (mod line-length 4))))
 106      (let-values (((p extract) (if port
 107                                    (values port (lambda () (values)))
 108                                    (open-string-output-port))))
 109        (letrec ((put (if line-length
 110                          (let ((chars 0))
 111                            (lambda (p c)
 112                              (when (fx=? chars line-length)
 113                                (set! chars 0)
 114                                (put-char p #\linefeed))
 115                              (set! chars (fx+ chars 1))
 116                              (put-char p c)))
 117                          put-char)))
 118          (let lp ((i start))
 119            (cond ((= i end))
 120                  ((<= (+ i 3) end)
 121                   (let ((x (bytevector-uint-ref bv i (endianness big) 3)))
 122                     (put p (string-ref alphabet (fxbit-field x 18 24)))
 123                     (put p (string-ref alphabet (fxbit-field x 12 18)))
 124                     (put p (string-ref alphabet (fxbit-field x 6 12)))
 125                     (put p (string-ref alphabet (fxbit-field x 0 6)))
 126                     (lp (+ i 3))))
 127                  ((<= (+ i 2) end)
 128                   (let ((x (fxarithmetic-shift-left (bytevector-u16-ref bv i (endianness big)) 8)))
 129                     (put p (string-ref alphabet (fxbit-field x 18 24)))
 130                     (put p (string-ref alphabet (fxbit-field x 12 18)))
 131                     (put p (string-ref alphabet (fxbit-field x 6 12)))
 132                     (unless no-padding
 133                       (put p #\=))))
 134                  (else
 135                   (let ((x (fxarithmetic-shift-left (bytevector-u8-ref bv i) 16)))
 136                     (put p (string-ref alphabet (fxbit-field x 18 24)))
 137                     (put p (string-ref alphabet (fxbit-field x 12 18)))
 138                     (unless no-padding
 139                       (put p #\=)
 140                       (put p #\=)))))))
 141        (extract)))))
 142
 143   ;; Decodes a base64 string. The string must contain only pure
 144   ;; unpadded base64 data.
 145
 146 (define base64-decode
 147   (case-lambda
 148     ((str)
 149      (base64-decode str base64-alphabet #f))
 150     ((str alphabet)
 151      (base64-decode str alphabet #f))
 152     ((str alphabet port)
 153      (unless (zero? (mod (string-length str) 4))
 154        (error 'base64-decode
 155               "input string must be a multiple of four characters"))
 156      (let-values (((p extract) (if port
 157                                    (values port (lambda () (values)))
 158                                    (open-bytevector-output-port))))
 159        (do ((i 0 (+ i 4)))
 160            ((= i (string-length str))
 161             (extract))
 162          (let ((c1 (string-ref str i))
 163                (c2 (string-ref str (+ i 1)))
 164                (c3 (string-ref str (+ i 2)))
 165                (c4 (string-ref str (+ i 3))))
 166            ;; TODO: be more clever than string-index
 167            (let ((i1 (string-index alphabet c1))
 168                  (i2 (string-index alphabet c2))
 169                  (i3 (string-index alphabet c3))
 170                  (i4 (string-index alphabet c4)))
 171              (cond ((and i1 i2 i3 i4)
 172                     (let ((x (fxior (fxarithmetic-shift-left i1 18)
 173                                     (fxarithmetic-shift-left i2 12)
 174                                     (fxarithmetic-shift-left i3 6)
 175                                     i4)))
 176                       (put-u8 p (fxbit-field x 16 24))
 177                       (put-u8 p (fxbit-field x 8 16))
 178                       (put-u8 p (fxbit-field x 0 8))))
 179                    ((and i1 i2 i3 (char=? c4 #\=)
 180                          (= i (- (string-length str) 4)))
 181                     (let ((x (fxior (fxarithmetic-shift-left i1 18)
 182                                     (fxarithmetic-shift-left i2 12)
 183                                     (fxarithmetic-shift-left i3 6))))
 184                       (put-u8 p (fxbit-field x 16 24))
 185                       (put-u8 p (fxbit-field x 8 16))))
 186                    ((and i1 i2 (char=? c3 #\=) (char=? c4 #\=)
 187                          (= i (- (string-length str) 4)))
 188                     (let ((x (fxior (fxarithmetic-shift-left i1 18)
 189                                     (fxarithmetic-shift-left i2 12))))
 190                       (put-u8 p (fxbit-field x 16 24))))
 191                    (else
 192                     (error 'base64-decode "invalid input"
 193                            (list c1 c2 c3 c4)))))))))))
 194
 195 (define (get-line-comp f port)
 196   (if (port-eof? port)
 197       (eof-object)
 198       (f (get-line port))))
 199
 200   ;; Reads the common -----BEGIN/END type----- delimited format from
 201   ;; the given port. Returns two values: a string with the type and a
 202   ;; bytevector containing the base64 decoded data. The second value
 203   ;; is the eof object if there is an eof before the BEGIN delimiter.
 204
 205 (define (get-delimited-base64 port)
 206   (define (get-first-data-line port)
 207     ;; Some MIME data has header fields in the same format as mail
 208     ;; or http. These are ignored.
 209     (let ((line (get-line-comp string-trim-both port)))
 210       (cond ((eof-object? line) line)
 211             ((string-index line #\:)
 212              (let lp ()                           ;read until empty line
 213                (let ((line (get-line-comp string-trim-both port)))
 214                  (if (string=? line "")
 215                      (get-line-comp string-trim-both port)
 216                      (lp)))))
 217             (else line))))
 218   (let ((line (get-line-comp string-trim-both port)))
 219     (cond ((eof-object? line)
 220            (values "" (eof-object)))
 221           ((string=? line "")
 222            (get-delimited-base64 port))
 223           ((and (string-prefix? "-----BEGIN " line)
 224                 (string-suffix? "-----" line))
 225            (let* ((type (substring line 11 (- (string-length line) 5)))
 226                   (endline (string-append "-----END " type "-----")))
 227              (let-values (((outp extract) (open-bytevector-output-port)))
 228                (let lp ((line (get-first-data-line port)))
 229                  (cond ((eof-object? line)
 230                         (error 'get-delimited-base64
 231                                "unexpected end of file"))
 232                        ((string-prefix? "-" line)
 233                         (unless (string=? line endline)
 234                           (error 'get-delimited-base64
 235                                  "bad end delimiter" type line))
 236                         (values type (extract)))
 237                        (else
 238                         (unless (and (= (string-length line) 5)
 239                                      (string-prefix? "=" line)) ;Skip Radix-64 checksum
 240                           (base64-decode line base64-alphabet outp))
 241                         (lp (get-line-comp string-trim-both port))))))))
 242           (else     ;skip garbage (like in openssl x509 -in foo -text output).
 243            (get-delimited-base64 port)))))
 244
 245 (define put-delimited-base64
 246   (case-lambda
 247     ((port type bv line-length)
 248      (display (string-append "-----BEGIN " type "-----\n") port)
 249      (base64-encode bv 0 (bytevector-length bv)
 250                     line-length #f base64-alphabet port)
 251      (display (string-append "\n-----END " type "-----\n") port))
 252     ((port type bv)
 253      (put-delimited-base64 port type bv 76))))