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 LC |
7 | ;; Some optimizations made by Ludovic Courtès <ludo@gnu.org>, 2015. |
8 | ;; | |
e9c6c584 NK |
9 | ;; Copyright © 2009, 2010 Göran Weinholt <goran@weinholt.se> |
10 | ;; | |
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. | |
15 | ;; | |
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. | |
20 | ;; | |
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/>. | |
23 | #!r6rs | |
24 | ||
25 | ;; RFC 4648 Base-N Encodings | |
26 | ||
27 | (library (guix base64) | |
28 | (export base64-encode | |
29 | base64-decode | |
30 | base64-alphabet | |
31 | base64url-alphabet | |
32 | get-delimited-base64 | |
33 | put-delimited-base64) | |
34 | (import (rnrs) | |
35 | (only (srfi :13 strings) | |
36 | string-index | |
37 | string-prefix? string-suffix? | |
b2ad9d9b LC |
38 | string-concatenate string-trim-both) |
39 | (only (guile) ash logior)) | |
40 | ||
41 | ||
42 | (define-syntax define-alias | |
43 | (syntax-rules () | |
44 | ((_ new old) | |
45 | (define-syntax new (identifier-syntax old))))) | |
46 | ||
47 | ;; Force the use of Guile's own primitives to avoid the overhead of its 'fx' | |
48 | ;; procedures. | |
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) | |
e9c6c584 NK |
55 | |
56 | (define base64-alphabet | |
57 | "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/") | |
58 | ||
59 | (define base64url-alphabet | |
60 | "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_") | |
61 | ||
62 | (define base64-encode | |
63 | (case-lambda | |
64 | ;; Simple interface. Returns a string containing the canonical | |
65 | ;; base64 representation of the given bytevector. | |
66 | ((bv) | |
67 | (base64-encode bv 0 (bytevector-length bv) #f #f base64-alphabet #f)) | |
68 | ((bv start) | |
69 | (base64-encode bv start (bytevector-length bv) #f #f base64-alphabet #f)) | |
70 | ((bv start end) | |
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 | |
89 | (let ((chars 0)) | |
90 | (lambda (p c) | |
91 | (when (fx=? chars line-length) | |
92 | (set! chars 0) | |
93 | (put-char p #\linefeed)) | |
94 | (set! chars (fx+ chars 1)) | |
95 | (put-char p c))) | |
96 | put-char))) | |
97 | (let lp ((i start)) | |
98 | (cond ((= i end)) | |
99 | ((<= (+ i 3) end) | |
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))) | |
105 | (lp (+ i 3)))) | |
106 | ((<= (+ i 2) end) | |
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))) | |
111 | (unless no-padding | |
112 | (put p #\=)))) | |
113 | (else | |
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))) | |
117 | (unless no-padding | |
118 | (put p #\=) | |
119 | (put p #\=))))))) | |
120 | (extract))))) | |
121 | ||
122 | ;; Decodes a base64 string. The string must contain only pure | |
123 | ;; unpadded base64 data. | |
124 | (define base64-decode | |
125 | (case-lambda | |
126 | ((str) | |
127 | (base64-decode str base64-alphabet #f)) | |
128 | ((str alphabet) | |
129 | (base64-decode str alphabet #f)) | |
130 | ((str alphabet port) | |
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)))) | |
137 | (do ((i 0 (+ i 4))) | |
138 | ((= i (string-length str)) | |
139 | (extract)) | |
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) | |
153 | i4))) | |
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)))) | |
169 | (else | |
170 | (error 'base64-decode "invalid input" | |
171 | (list c1 c2 c3 c4))))))))))) | |
172 | ||
173 | (define (get-line-comp f port) | |
174 | (if (port-eof? port) | |
175 | (eof-object) | |
176 | (f (get-line port)))) | |
177 | ||
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) | |
193 | (lp))))) | |
194 | (else line)))) | |
195 | (let ((line (get-line-comp string-trim-both port))) | |
196 | (cond ((eof-object? line) | |
197 | (values "" (eof-object))) | |
198 | ((string=? line "") | |
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))) | |
214 | (else | |
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))))) | |
221 | ||
222 | (define put-delimited-base64 | |
223 | (case-lambda | |
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)) | |
229 | ((port type bv) | |
b2ad9d9b | 230 | (put-delimited-base64 port type bv 76))))) |