8sync/contrib/base64.scm

   1 ;; -*- mode: scheme; coding: utf-8 -*-
   2 ;; Copyright © 2009, 2010, 2012, 2013 Göran Weinholt <goran@weinholt.se>
   3
   4 ;; Permission is hereby granted, free of charge, to any person obtaining a
   5 ;; copy of this software and associated documentation files (the "Software"),
   6 ;; to deal in the Software without restriction, including without limitation
   7 ;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
   8 ;; and/or sell copies of the Software, and to permit persons to whom the
   9 ;; Software is furnished to do so, subject to the following conditions:
  10
  11 ;; The above copyright notice and this permission notice shall be included in
  12 ;; all copies or substantial portions of the Software.
  13
  14 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
  15 ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  16 ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
  17 ;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  18 ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  19 ;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  20 ;; DEALINGS IN THE SOFTWARE.
  21 #!r6rs
  22
  23 ;; RFC 4648 Base-N Encodings
  24
  25 (library (8sync contrib base64)
  26   (export base64-encode
  27           base64-decode
  28           base64-alphabet
  29           base64url-alphabet
  30           get-delimited-base64
  31           put-delimited-base64)
  32   (import (rnrs)
  33           (only (srfi :13 strings)
  34                 string-index
  35                 string-prefix? string-suffix?
  36                 string-concatenate string-trim-both))
  37
  38   (define base64-alphabet
  39     "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
  40
  41   (define base64url-alphabet
  42     "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_")
  43
  44   (define base64-encode
  45     (case-lambda
  46       ;; Simple interface. Returns a string containing the canonical
  47       ;; base64 representation of the given bytevector.
  48       ((bv)
  49        (base64-encode bv 0 (bytevector-length bv) #f #f base64-alphabet #f))
  50       ((bv start)
  51        (base64-encode bv start (bytevector-length bv) #f #f base64-alphabet #f))
  52       ((bv start end)
  53        (base64-encode bv start end #f #f base64-alphabet #f))
  54       ((bv start end line-length)
  55        (base64-encode bv start end line-length #f base64-alphabet #f))
  56       ((bv start end line-length no-padding)
  57        (base64-encode bv start end line-length no-padding base64-alphabet #f))
  58       ((bv start end line-length no-padding alphabet)
  59        (base64-encode bv start end line-length no-padding alphabet #f))
  60       ;; Base64 encodes the bytes [start,end[ in the given bytevector.
  61       ;; Lines are limited to line-length characters (unless #f),
  62       ;; which must be a multiple of four. To omit the padding
  63       ;; characters (#\=) set no-padding to a true value. If port is
  64       ;; #f, returns a string.
  65       ((bv start end line-length no-padding alphabet port)
  66        (assert (or (not line-length) (zero? (mod line-length 4))))
  67        (let-values (((p extract) (if port
  68                                      (values port (lambda () (values)))
  69                                      (open-string-output-port))))
  70          (letrec ((put (if line-length
  71                            (let ((chars 0))
  72                              (lambda (p c)
  73                                (when (fx=? chars line-length)
  74                                  (set! chars 0)
  75                                  (put-char p #\linefeed))
  76                                (set! chars (fx+ chars 1))
  77                                (put-char p c)))
  78                            put-char)))
  79            (let lp ((i start))
  80              (cond ((= i end))
  81                    ((<= (+ i 3) end)
  82                     (let ((x (bytevector-uint-ref bv i (endianness big) 3)))
  83                       (put p (string-ref alphabet (fxbit-field x 18 24)))
  84                       (put p (string-ref alphabet (fxbit-field x 12 18)))
  85                       (put p (string-ref alphabet (fxbit-field x 6 12)))
  86                       (put p (string-ref alphabet (fxbit-field x 0 6)))
  87                       (lp (+ i 3))))
  88                    ((<= (+ i 2) end)
  89                     (let ((x (fxarithmetic-shift-left (bytevector-u16-ref bv i (endianness big)) 8)))
  90                       (put p (string-ref alphabet (fxbit-field x 18 24)))
  91                       (put p (string-ref alphabet (fxbit-field x 12 18)))
  92                       (put p (string-ref alphabet (fxbit-field x 6 12)))
  93                       (unless no-padding
  94                         (put p #\=))))
  95                    (else
  96                     (let ((x (fxarithmetic-shift-left (bytevector-u8-ref bv i) 16)))
  97                       (put p (string-ref alphabet (fxbit-field x 18 24)))
  98                       (put p (string-ref alphabet (fxbit-field x 12 18)))
  99                       (unless no-padding
 100                         (put p #\=)
 101                         (put p #\=)))))))
 102          (extract)))))
 103
 104   ;; Create a lookup table for the alphabet and remember the latest table.
 105   (define get-decode-table
 106     (let ((ascii-table #f)
 107           (extra-table '())     ;in the unlikely case of unicode chars
 108           (table-alphabet #f))
 109       (lambda (alphabet)
 110         (unless (eq? alphabet table-alphabet)
 111           ;; Rebuild the table.
 112           (do ((ascii (make-vector 128 #f))
 113                (extra '())
 114                (i 0 (+ i 1)))
 115               ((= i (string-length alphabet))
 116                (set! ascii-table ascii)
 117                (set! extra-table extra))
 118             (let ((c (char->integer (string-ref alphabet i))))
 119               (if (fx<=? c 127)
 120                   (vector-set! ascii c i)
 121                   (set! extra (cons (cons c i) extra)))))
 122           (set! table-alphabet alphabet))
 123         (values ascii-table extra-table))))
 124
 125   ;; Decodes a correctly padded base64 string, optionally ignoring
 126   ;; non-alphabet characters.
 127   (define base64-decode
 128     (case-lambda
 129       ((str)
 130        (base64-decode str base64-alphabet #f))
 131       ((str alphabet)
 132        (base64-decode str alphabet #f))
 133       ((str alphabet port)
 134        (base64-decode str alphabet port #t))
 135       ((str alphabet port strict?)
 136        (define (pad? c) (eqv? c (char->integer #\=)))
 137        (let-values (((p extract) (if port
 138                                      (values port (lambda () (values)))
 139                                      (open-bytevector-output-port)))
 140                     ((ascii extra) (get-decode-table alphabet)))
 141          (define-syntax lookup
 142            (syntax-rules ()
 143              ((_ c) (or (and (fx<=? c 127) (vector-ref ascii c))
 144                         (cond ((assv c extra) => cdr)
 145                               (else #f))))))
 146          (let* ((len (if strict?
 147                          (string-length str)
 148                          (let lp ((i (fx- (string-length str) 1)))
 149                            ;; Skip trailing invalid chars.
 150                            (cond ((fxzero? i) 0)
 151                                  ((let ((c (char->integer (string-ref str i))))
 152                                     (or (lookup c) (pad? c)))
 153                                   (fx+ i 1))
 154                                  (else (lp (fx- i 1))))))))
 155            (let lp ((i 0))
 156              (cond
 157                ((fx=? i len)
 158                 (extract))
 159                ((fx<=? i (fx- len 4))
 160                 (let lp* ((c1 (char->integer (string-ref str i)))
 161                           (c2 (char->integer (string-ref str (fx+ i 1))))
 162                           (c3 (char->integer (string-ref str (fx+ i 2))))
 163                           (c4 (char->integer (string-ref str (fx+ i 3))))
 164                           (i i))
 165                   (let ((i1 (lookup c1)) (i2 (lookup c2))
 166                         (i3 (lookup c3)) (i4 (lookup c4)))
 167                     (cond
 168                       ((and i1 i2 i3 i4)
 169                        ;; All characters present and accounted for.
 170                        ;; The most common case.
 171                        (let ((x (fxior (fxarithmetic-shift-left i1 18)
 172                                        (fxarithmetic-shift-left i2 12)
 173                                        (fxarithmetic-shift-left i3 6)
 174                                        i4)))
 175                          (put-u8 p (fxbit-field x 16 24))
 176                          (put-u8 p (fxbit-field x 8 16))
 177                          (put-u8 p (fxbit-field x 0 8))
 178                          (lp (fx+ i 4))))
 179                       ((and i1 i2 i3 (pad? c4) (= i (- len 4)))
 180                        ;; One padding character at the end of the input.
 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                          (lp (fx+ i 4))))
 187                       ((and i1 i2 (pad? c3) (pad? c4) (= i (- len 4)))
 188                        ;; Two padding characters.
 189                        (let ((x (fxior (fxarithmetic-shift-left i1 18)
 190                                        (fxarithmetic-shift-left i2 12))))
 191                          (put-u8 p (fxbit-field x 16 24))
 192                          (lp (fx+ i 4))))
 193                       ((not strict?)
 194                        ;; Non-alphabet characters.
 195                        (let lp ((i i) (c* '()) (n 4))
 196                          (cond ((fxzero? n)
 197                                 ;; Found four valid characters.
 198                                 (lp* (cadddr c*) (caddr c*) (cadr c*) (car c*)
 199                                      (fx- i 4)))
 200                                ((fx=? i len)
 201                                 (error 'base64-decode
 202                                        "Invalid input in non-strict mode."
 203                                        i c*))
 204                                (else
 205                                 ;; Gather alphabetic (or valid
 206                                 ;; padding) characters.
 207                                 (let ((c (char->integer (string-ref str i))))
 208                                   (cond ((or (lookup c)
 209                                              (and (pad? c)
 210                                                   (fx<=? n 2)
 211                                                   (fx=? i (fx- len n))))
 212                                          (lp (fx+ i 1) (cons c c*) (fx- n 1)))
 213                                         (else
 214                                          (lp (fx+ i 1) c* n))))))))
 215                       (else
 216                        (error 'base64-decode
 217                               "Invalid input in strict mode."
 218                               c1 c2 c3 c4))))))
 219                (else
 220                 (error 'base64-decode
 221                        "The input is too short, it may be missing padding."
 222                        i)))))))))
 223
 224   (define (get-line-comp f port)
 225     (if (port-eof? port)
 226         (eof-object)
 227         (f (get-line port))))
 228
 229   ;; Reads the common -----BEGIN/END type----- delimited format from
 230   ;; the given port. Returns two values: a string with the type and a
 231   ;; bytevector containing the base64 decoded data. The second value
 232   ;; is the eof object if there is an eof before the BEGIN delimiter.
 233   (define get-delimited-base64
 234     (case-lambda
 235       ((port)
 236        (get-delimited-base64 port #t))
 237       ((port strict)
 238        (define (get-first-data-line port)
 239          ;; Some MIME data has header fields in the same format as mail
 240          ;; or http. These are ignored.
 241          (let ((line (get-line-comp string-trim-both port)))
 242            (cond ((eof-object? line) line)
 243                  ((string-index line #\:)
 244                   (let lp ()               ;read until empty line
 245                     (let ((line (get-line-comp string-trim-both port)))
 246                       (if (string=? line "")
 247                           (get-line-comp string-trim-both port)
 248                           (lp)))))
 249                  (else line))))
 250        (let ((line (get-line-comp string-trim-both port)))
 251          (cond ((eof-object? line)
 252                 (values "" (eof-object)))
 253                ((string=? line "")
 254                 (get-delimited-base64 port))
 255                ((and (string-prefix? "-----BEGIN " line)
 256                      (string-suffix? "-----" line))
 257                 (let* ((type (substring line 11 (- (string-length line) 5)))
 258                        (endline (string-append "-----END " type "-----")))
 259                   (let-values (((outp extract) (open-bytevector-output-port)))
 260                     (let lp ((line (get-first-data-line port)))
 261                       (cond ((eof-object? line)
 262                              (error 'get-delimited-base64
 263                                     "unexpected end of file"))
 264                             ((string-prefix? "-" line)
 265                              (unless (string=? line endline)
 266                                (error 'get-delimited-base64
 267                                       "bad end delimiter" type line))
 268                              (values type (extract)))
 269                             (else
 270                              (unless (and (= (string-length line) 5)
 271                                           (string-prefix? "=" line)) ;Skip Radix-64 checksum
 272                                (base64-decode line base64-alphabet outp))
 273                              (lp (get-line-comp string-trim-both port))))))))
 274                (else ;skip garbage (like in openssl x509 -in foo -text output).
 275                 (get-delimited-base64 port)))))))
 276
 277   (define put-delimited-base64
 278     (case-lambda
 279       ((port type bv line-length)
 280        (display (string-append "-----BEGIN " type "-----\n") port)
 281        (base64-encode bv 0 (bytevector-length bv)
 282                       line-length #f base64-alphabet port)
 283        (display (string-append "\n-----END " type "-----\n") port))
 284       ((port type bv)
 285        (put-delimited-base64 port type bv 76)))))