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 (srfi srfi-11)
  56   #:use-module (srfi srfi-60)
  57   #:use-module (rnrs bytevectors)
  58   #:use-module (rnrs io ports))
  59
  60
  61 (define-syntax define-alias
  62   (syntax-rules ()
  63     ((_ new old)
  64      (define-syntax new (identifier-syntax old)))))
  65
  66 ;; Force the use of Guile's own primitives to avoid the overhead of its 'fx'
  67 ;; procedures.
  68
  69 (define-alias fxbit-field bit-field)
  70 (define-alias fxarithmetic-shift ash)
  71 (define-alias fxarithmetic-shift-left ash)
  72 (define-alias fxand logand)
  73 (define-alias fxior logior)
  74 (define-alias fxxor logxor)
  75 (define-alias fx=? =)
  76 (define-alias fx+ +)
  77 (define-alias mod modulo)
  78
  79 (define-syntax-rule (assert exp)
  80   (unless exp
  81     (throw 'assertion-failure 'exp)))
  82
  83 (define base64-alphabet
  84   "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
  85
  86 (define base64url-alphabet
  87   "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_")
  88
  89 (define base64-encode
  90   (case-lambda
  91     ;; Simple interface. Returns a string containing the canonical
  92     ;; base64 representation of the given bytevector.
  93     ((bv)
  94      (base64-encode bv 0 (bytevector-length bv) #f #f base64-alphabet #f))
  95     ((bv start)
  96      (base64-encode bv start (bytevector-length bv) #f #f base64-alphabet #f))
  97     ((bv start end)
  98      (base64-encode bv start end #f #f base64-alphabet #f))
  99     ((bv start end line-length)
 100      (base64-encode bv start end line-length #f base64-alphabet #f))
 101     ((bv start end line-length no-padding)
 102      (base64-encode bv start end line-length no-padding base64-alphabet #f))
 103     ((bv start end line-length no-padding alphabet)
 104      (base64-encode bv start end line-length no-padding alphabet #f))
 105     ;; Base64 encodes the bytes [start,end[ in the given bytevector.
 106     ;; Lines are limited to line-length characters (unless #f),
 107     ;; which must be a multiple of four. To omit the padding
 108     ;; characters (#\=) set no-padding to a true value. If port is
 109     ;; #f, returns a string.
 110     ((bv start end line-length no-padding alphabet port)
 111      (assert (or (not line-length) (zero? (mod line-length 4))))
 112      (let-values (((p extract) (if port
 113                                    (values port (lambda () (values)))
 114                                    (open-string-output-port))))
 115        (letrec ((put (if line-length
 116                          (let ((chars 0))
 117                            (lambda (p c)
 118                              (when (fx=? chars line-length)
 119                                (set! chars 0)
 120                                (put-char p #\linefeed))
 121                              (set! chars (fx+ chars 1))
 122                              (put-char p c)))
 123                          put-char)))
 124          (let lp ((i start))
 125            (cond ((= i end))
 126                  ((<= (+ i 3) end)
 127                   (let ((x (bytevector-uint-ref bv i (endianness big) 3)))
 128                     (put p (string-ref alphabet (fxbit-field x 18 24)))
 129                     (put p (string-ref alphabet (fxbit-field x 12 18)))
 130                     (put p (string-ref alphabet (fxbit-field x 6 12)))
 131                     (put p (string-ref alphabet (fxbit-field x 0 6)))
 132                     (lp (+ i 3))))
 133                  ((<= (+ i 2) end)
 134                   (let ((x (fxarithmetic-shift-left (bytevector-u16-ref bv i (endianness big)) 8)))
 135                     (put p (string-ref alphabet (fxbit-field x 18 24)))
 136                     (put p (string-ref alphabet (fxbit-field x 12 18)))
 137                     (put p (string-ref alphabet (fxbit-field x 6 12)))
 138                     (unless no-padding
 139                       (put p #\=))))
 140                  (else
 141                   (let ((x (fxarithmetic-shift-left (bytevector-u8-ref bv i) 16)))
 142                     (put p (string-ref alphabet (fxbit-field x 18 24)))
 143                     (put p (string-ref alphabet (fxbit-field x 12 18)))
 144                     (unless no-padding
 145                       (put p #\=)
 146                       (put p #\=)))))))
 147        (extract)))))
 148
 149   ;; Decodes a base64 string. The string must contain only pure
 150   ;; unpadded base64 data.
 151
 152 (define base64-decode
 153   (case-lambda
 154     ((str)
 155      (base64-decode str base64-alphabet #f))
 156     ((str alphabet)
 157      (base64-decode str alphabet #f))
 158     ((str alphabet port)
 159      (unless (zero? (mod (string-length str) 4))
 160        (error 'base64-decode
 161               "input string must be a multiple of four characters"))
 162      (let-values (((p extract) (if port
 163                                    (values port (lambda () (values)))
 164                                    (open-bytevector-output-port))))
 165        (do ((i 0 (+ i 4)))
 166            ((= i (string-length str))
 167             (extract))
 168          (let ((c1 (string-ref str i))
 169                (c2 (string-ref str (+ i 1)))
 170                (c3 (string-ref str (+ i 2)))
 171                (c4 (string-ref str (+ i 3))))
 172            ;; TODO: be more clever than string-index
 173            (let ((i1 (string-index alphabet c1))
 174                  (i2 (string-index alphabet c2))
 175                  (i3 (string-index alphabet c3))
 176                  (i4 (string-index alphabet c4)))
 177              (cond ((and i1 i2 i3 i4)
 178                     (let ((x (fxior (fxarithmetic-shift-left i1 18)
 179                                     (fxarithmetic-shift-left i2 12)
 180                                     (fxarithmetic-shift-left i3 6)
 181                                     i4)))
 182                       (put-u8 p (fxbit-field x 16 24))
 183                       (put-u8 p (fxbit-field x 8 16))
 184                       (put-u8 p (fxbit-field x 0 8))))
 185                    ((and i1 i2 i3 (char=? c4 #\=)
 186                          (= i (- (string-length str) 4)))
 187                     (let ((x (fxior (fxarithmetic-shift-left i1 18)
 188                                     (fxarithmetic-shift-left i2 12)
 189                                     (fxarithmetic-shift-left i3 6))))
 190                       (put-u8 p (fxbit-field x 16 24))
 191                       (put-u8 p (fxbit-field x 8 16))))
 192                    ((and i1 i2 (char=? c3 #\=) (char=? c4 #\=)
 193                          (= i (- (string-length str) 4)))
 194                     (let ((x (fxior (fxarithmetic-shift-left i1 18)
 195                                     (fxarithmetic-shift-left i2 12))))
 196                       (put-u8 p (fxbit-field x 16 24))))
 197                    (else
 198                     (error 'base64-decode "invalid input"
 199                            (list c1 c2 c3 c4)))))))))))
 200
 201 (define (get-line-comp f port)
 202   (if (port-eof? port)
 203       (eof-object)
 204       (f (get-line port))))
 205
 206   ;; Reads the common -----BEGIN/END type----- delimited format from
 207   ;; the given port. Returns two values: a string with the type and a
 208   ;; bytevector containing the base64 decoded data. The second value
 209   ;; is the eof object if there is an eof before the BEGIN delimiter.
 210
 211 (define (get-delimited-base64 port)
 212   (define (get-first-data-line port)
 213     ;; Some MIME data has header fields in the same format as mail
 214     ;; or http. These are ignored.
 215     (let ((line (get-line-comp string-trim-both port)))
 216       (cond ((eof-object? line) line)
 217             ((string-index line #\:)
 218              (let lp ()                           ;read until empty line
 219                (let ((line (get-line-comp string-trim-both port)))
 220                  (if (string=? line "")
 221                      (get-line-comp string-trim-both port)
 222                      (lp)))))
 223             (else line))))
 224   (let ((line (get-line-comp string-trim-both port)))
 225     (cond ((eof-object? line)
 226            (values "" (eof-object)))
 227           ((string=? line "")
 228            (get-delimited-base64 port))
 229           ((and (string-prefix? "-----BEGIN " line)
 230                 (string-suffix? "-----" line))
 231            (let* ((type (substring line 11 (- (string-length line) 5)))
 232                   (endline (string-append "-----END " type "-----")))
 233              (let-values (((outp extract) (open-bytevector-output-port)))
 234                (let lp ((line (get-first-data-line port)))
 235                  (cond ((eof-object? line)
 236                         (error 'get-delimited-base64
 237                                "unexpected end of file"))
 238                        ((string-prefix? "-" line)
 239                         (unless (string=? line endline)
 240                           (error 'get-delimited-base64
 241                                  "bad end delimiter" type line))
 242                         (values type (extract)))
 243                        (else
 244                         (unless (and (= (string-length line) 5)
 245                                      (string-prefix? "=" line)) ;Skip Radix-64 checksum
 246                           (base64-decode line base64-alphabet outp))
 247                         (lp (get-line-comp string-trim-both port))))))))
 248           (else     ;skip garbage (like in openssl x509 -in foo -text output).
 249            (get-delimited-base64 port)))))
 250
 251 (define put-delimited-base64
 252   (case-lambda
 253     ((port type bv line-length)
 254      (display (string-append "-----BEGIN " type "-----\n") port)
 255      (base64-encode bv 0 (bytevector-length bv)
 256                     line-length #f base64-alphabet port)
 257      (display (string-append "\n-----END " type "-----\n") port))
 258     ((port type bv)
 259      (put-delimited-base64 port type bv 76))))