1 ;; -*- mode: scheme; coding: utf-8 -*-
3 ;; This module was renamed from (weinholt text base64 (1 0 20100612)) to
4 ;; (guix base64) by Nikita Karetnikov <nikita@karetnikov.org> on
7 ;; Some optimizations made by Ludovic Courtès <ludo@gnu.org>, 2015.
9 ;; Copyright © 2009, 2010 Göran Weinholt <goran@weinholt.se>
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.
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.
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/>.
25 ;; RFC 4648 Base-N Encodings
27 (library (guix base64)
35 (only (srfi :13 strings)
37 string-prefix? string-suffix?
38 string-concatenate string-trim-both)
39 (only (guile) ash logior))
42 (define-syntax define-alias
45 (define-syntax new (identifier-syntax old)))))
47 ;; Force the use of Guile's own primitives to avoid the overhead of its 'fx'
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)
56 (define base64-alphabet
57 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
59 (define base64url-alphabet
60 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_")
64 ;; Simple interface. Returns a string containing the canonical
65 ;; base64 representation of the given bytevector.
67 (base64-encode bv 0 (bytevector-length bv) #f #f base64-alphabet #f))
69 (base64-encode bv start (bytevector-length bv) #f #f base64-alphabet #f))
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
91 (when (fx=? chars line-length)
93 (put-char p #\linefeed))
94 (set! chars (fx+ chars 1))
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)))
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)))
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)))
122 ;; Decodes a base64 string. The string must contain only pure
123 ;; unpadded base64 data.
124 (define base64-decode
127 (base64-decode str base64-alphabet #f))
129 (base64-decode str alphabet #f))
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))))
138 ((= i (string-length str))
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)
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))))
170 (error 'base64-decode "invalid input"
171 (list c1 c2 c3 c4)))))))))))
173 (define (get-line-comp f port)
176 (f (get-line port))))
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)
195 (let ((line (get-line-comp string-trim-both port)))
196 (cond ((eof-object? line)
197 (values "" (eof-object)))
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)))
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)))))
222 (define put-delimited-base64
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))
230 (put-delimited-base64 port type bv 76)))))