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) | |
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))) | |
b2ad9d9b LC |
60 | |
61 | ||
4862a98b LC |
62 | (define-syntax define-alias |
63 | (syntax-rules () | |
64 | ((_ new old) | |
65 | (define-syntax new (identifier-syntax old))))) | |
b2ad9d9b | 66 | |
4862a98b LC |
67 | ;; Force the use of Guile's own primitives to avoid the overhead of its 'fx' |
68 | ;; procedures. | |
e9c6c584 | 69 | |
4862a98b LC |
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) | |
e9c6c584 | 76 | |
4862a98b LC |
77 | (define base64-alphabet |
78 | "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/") | |
e9c6c584 | 79 | |
4862a98b LC |
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))))) | |
e9c6c584 NK |
142 | |
143 | ;; Decodes a base64 string. The string must contain only pure | |
144 | ;; unpadded base64 data. | |
4862a98b LC |
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))))))))))) | |
e9c6c584 | 194 | |
4862a98b LC |
195 | (define (get-line-comp f port) |
196 | (if (port-eof? port) | |
197 | (eof-object) | |
198 | (f (get-line port)))) | |
e9c6c584 NK |
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. | |
4862a98b LC |
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. | |
e9c6c584 | 209 | (let ((line (get-line-comp string-trim-both port))) |
4862a98b LC |
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) | |
e9c6c584 | 234 | (error 'get-delimited-base64 |
4862a98b LC |
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))))) | |
e9c6c584 | 244 | |
4862a98b LC |
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)))) |