Commit | Line | Data |
---|---|---|
e9c6c584 NK |
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 | ;; | |
b2ad9d9b | 7 | ;; Some optimizations made by Ludovic Courtès <ludo@gnu.org>, 2015. |
4862a98b | 8 | ;; Turned into a Guile module (instead of R6RS). |
b2ad9d9b | 9 | ;; |
e9c6c584 NK |
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/>. | |
b47f7510 CAW |
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 | ||
e9c6c584 NK |
46 | ;; RFC 4648 Base-N Encodings |
47 | ||
4862a98b LC |
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) | |
5f9cd63e LC |
55 | #:use-module (srfi srfi-11) |
56 | #:use-module (srfi srfi-60) | |
57 | #:use-module (rnrs bytevectors) | |
58 | #:use-module (rnrs io ports)) | |
b2ad9d9b LC |
59 | |
60 | ||
4862a98b LC |
61 | (define-syntax define-alias |
62 | (syntax-rules () | |
63 | ((_ new old) | |
64 | (define-syntax new (identifier-syntax old))))) | |
b2ad9d9b | 65 | |
4862a98b LC |
66 | ;; Force the use of Guile's own primitives to avoid the overhead of its 'fx' |
67 | ;; procedures. | |
e9c6c584 | 68 | |
5f9cd63e | 69 | (define-alias fxbit-field bit-field) |
4862a98b LC |
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) | |
5f9cd63e LC |
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))) | |
e9c6c584 | 82 | |
4862a98b LC |
83 | (define base64-alphabet |
84 | "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/") | |
e9c6c584 | 85 | |
4862a98b LC |
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))))) | |
e9c6c584 NK |
148 | |
149 | ;; Decodes a base64 string. The string must contain only pure | |
150 | ;; unpadded base64 data. | |
4862a98b LC |
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))))))))))) | |
e9c6c584 | 200 | |
4862a98b LC |
201 | (define (get-line-comp f port) |
202 | (if (port-eof? port) | |
203 | (eof-object) | |
204 | (f (get-line port)))) | |
e9c6c584 NK |
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. | |
4862a98b LC |
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. | |
e9c6c584 | 215 | (let ((line (get-line-comp string-trim-both port))) |
4862a98b LC |
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) | |
e9c6c584 | 240 | (error 'get-delimited-base64 |
4862a98b LC |
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))))) | |
e9c6c584 | 250 | |
4862a98b LC |
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)))) |