base64.scm 11 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255
  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. It was later renamed to (gcrypt base64) by
  6. ;; Christopher Allan Webber <cwebber@dustycloud.org> on May 20, 2017.
  7. ;;
  8. ;; Some optimizations made by Ludovic Courtès <ludo@gnu.org>, 2015.
  9. ;; Turned into a Guile module (instead of R6RS).
  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. ;;
  24. ;; This file incorporates work covered by the following copyright and
  25. ;; permission notice:
  26. ;;
  27. ;; Copyright © 2009, 2010 Göran Weinholt <goran@weinholt.se>
  28. ;;
  29. ;; Permission is hereby granted, free of charge, to any person obtaining a
  30. ;; copy of this software and associated documentation files (the "Software"),
  31. ;; to deal in the Software without restriction, including without limitation
  32. ;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
  33. ;; and/or sell copies of the Software, and to permit persons to whom the
  34. ;; Software is furnished to do so, subject to the following conditions:
  35. ;;
  36. ;; The above copyright notice and this permission notice shall be included in
  37. ;; all copies or substantial portions of the Software.
  38. ;;
  39. ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
  40. ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  41. ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
  42. ;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  43. ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  44. ;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  45. ;; DEALINGS IN THE SOFTWARE.
  46. ;; RFC 4648 Base-N Encodings
  47. (define-module (gcrypt base64)
  48. #:export (base64-encode
  49. base64-decode
  50. base64-alphabet
  51. base64url-alphabet
  52. get-delimited-base64
  53. put-delimited-base64)
  54. #:use-module (rnrs)
  55. #:use-module ((srfi srfi-13)
  56. #:select (string-index
  57. string-prefix? string-suffix?
  58. string-concatenate string-trim-both)))
  59. (define-syntax define-alias
  60. (syntax-rules ()
  61. ((_ new old)
  62. (define-syntax new (identifier-syntax old)))))
  63. ;; Force the use of Guile's own primitives to avoid the overhead of its 'fx'
  64. ;; procedures.
  65. (define-alias fxbit-field bitwise-bit-field)
  66. (define-alias fxarithmetic-shift ash)
  67. (define-alias fxarithmetic-shift-left ash)
  68. (define-alias fxand logand)
  69. (define-alias fxior logior)
  70. (define-alias fxxor logxor)
  71. (define base64-alphabet
  72. "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
  73. (define base64url-alphabet
  74. "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_")
  75. (define base64-encode
  76. (case-lambda
  77. ;; Simple interface. Returns a string containing the canonical
  78. ;; base64 representation of the given bytevector.
  79. ((bv)
  80. (base64-encode bv 0 (bytevector-length bv) #f #f base64-alphabet #f))
  81. ((bv start)
  82. (base64-encode bv start (bytevector-length bv) #f #f base64-alphabet #f))
  83. ((bv start end)
  84. (base64-encode bv start end #f #f base64-alphabet #f))
  85. ((bv start end line-length)
  86. (base64-encode bv start end line-length #f base64-alphabet #f))
  87. ((bv start end line-length no-padding)
  88. (base64-encode bv start end line-length no-padding base64-alphabet #f))
  89. ((bv start end line-length no-padding alphabet)
  90. (base64-encode bv start end line-length no-padding alphabet #f))
  91. ;; Base64 encodes the bytes [start,end[ in the given bytevector.
  92. ;; Lines are limited to line-length characters (unless #f),
  93. ;; which must be a multiple of four. To omit the padding
  94. ;; characters (#\=) set no-padding to a true value. If port is
  95. ;; #f, returns a string.
  96. ((bv start end line-length no-padding alphabet port)
  97. (assert (or (not line-length) (zero? (mod line-length 4))))
  98. (let-values (((p extract) (if port
  99. (values port (lambda () (values)))
  100. (open-string-output-port))))
  101. (letrec ((put (if line-length
  102. (let ((chars 0))
  103. (lambda (p c)
  104. (when (fx=? chars line-length)
  105. (set! chars 0)
  106. (put-char p #\linefeed))
  107. (set! chars (fx+ chars 1))
  108. (put-char p c)))
  109. put-char)))
  110. (let lp ((i start))
  111. (cond ((= i end))
  112. ((<= (+ i 3) end)
  113. (let ((x (bytevector-uint-ref bv i (endianness big) 3)))
  114. (put p (string-ref alphabet (fxbit-field x 18 24)))
  115. (put p (string-ref alphabet (fxbit-field x 12 18)))
  116. (put p (string-ref alphabet (fxbit-field x 6 12)))
  117. (put p (string-ref alphabet (fxbit-field x 0 6)))
  118. (lp (+ i 3))))
  119. ((<= (+ i 2) end)
  120. (let ((x (fxarithmetic-shift-left (bytevector-u16-ref bv i (endianness big)) 8)))
  121. (put p (string-ref alphabet (fxbit-field x 18 24)))
  122. (put p (string-ref alphabet (fxbit-field x 12 18)))
  123. (put p (string-ref alphabet (fxbit-field x 6 12)))
  124. (unless no-padding
  125. (put p #\=))))
  126. (else
  127. (let ((x (fxarithmetic-shift-left (bytevector-u8-ref bv i) 16)))
  128. (put p (string-ref alphabet (fxbit-field x 18 24)))
  129. (put p (string-ref alphabet (fxbit-field x 12 18)))
  130. (unless no-padding
  131. (put p #\=)
  132. (put p #\=)))))))
  133. (extract)))))
  134. ;; Decodes a base64 string. The string must contain only pure
  135. ;; unpadded base64 data.
  136. (define base64-decode
  137. (case-lambda
  138. ((str)
  139. (base64-decode str base64-alphabet #f))
  140. ((str alphabet)
  141. (base64-decode str alphabet #f))
  142. ((str alphabet port)
  143. (unless (zero? (mod (string-length str) 4))
  144. (error 'base64-decode
  145. "input string must be a multiple of four characters"))
  146. (let-values (((p extract) (if port
  147. (values port (lambda () (values)))
  148. (open-bytevector-output-port))))
  149. (do ((i 0 (+ i 4)))
  150. ((= i (string-length str))
  151. (extract))
  152. (let ((c1 (string-ref str i))
  153. (c2 (string-ref str (+ i 1)))
  154. (c3 (string-ref str (+ i 2)))
  155. (c4 (string-ref str (+ i 3))))
  156. ;; TODO: be more clever than string-index
  157. (let ((i1 (string-index alphabet c1))
  158. (i2 (string-index alphabet c2))
  159. (i3 (string-index alphabet c3))
  160. (i4 (string-index alphabet c4)))
  161. (cond ((and i1 i2 i3 i4)
  162. (let ((x (fxior (fxarithmetic-shift-left i1 18)
  163. (fxarithmetic-shift-left i2 12)
  164. (fxarithmetic-shift-left i3 6)
  165. i4)))
  166. (put-u8 p (fxbit-field x 16 24))
  167. (put-u8 p (fxbit-field x 8 16))
  168. (put-u8 p (fxbit-field x 0 8))))
  169. ((and i1 i2 i3 (char=? c4 #\=)
  170. (= i (- (string-length str) 4)))
  171. (let ((x (fxior (fxarithmetic-shift-left i1 18)
  172. (fxarithmetic-shift-left i2 12)
  173. (fxarithmetic-shift-left i3 6))))
  174. (put-u8 p (fxbit-field x 16 24))
  175. (put-u8 p (fxbit-field x 8 16))))
  176. ((and i1 i2 (char=? c3 #\=) (char=? c4 #\=)
  177. (= i (- (string-length str) 4)))
  178. (let ((x (fxior (fxarithmetic-shift-left i1 18)
  179. (fxarithmetic-shift-left i2 12))))
  180. (put-u8 p (fxbit-field x 16 24))))
  181. (else
  182. (error 'base64-decode "invalid input"
  183. (list c1 c2 c3 c4)))))))))))
  184. (define (get-line-comp f port)
  185. (if (port-eof? port)
  186. (eof-object)
  187. (f (get-line port))))
  188. ;; Reads the common -----BEGIN/END type----- delimited format from
  189. ;; the given port. Returns two values: a string with the type and a
  190. ;; bytevector containing the base64 decoded data. The second value
  191. ;; is the eof object if there is an eof before the BEGIN delimiter.
  192. (define (get-delimited-base64 port)
  193. (define (get-first-data-line port)
  194. ;; Some MIME data has header fields in the same format as mail
  195. ;; or http. These are ignored.
  196. (let ((line (get-line-comp string-trim-both port)))
  197. (cond ((eof-object? line) line)
  198. ((string-index line #\:)
  199. (let lp () ;read until empty line
  200. (let ((line (get-line-comp string-trim-both port)))
  201. (if (string=? line "")
  202. (get-line-comp string-trim-both port)
  203. (lp)))))
  204. (else line))))
  205. (let ((line (get-line-comp string-trim-both port)))
  206. (cond ((eof-object? line)
  207. (values "" (eof-object)))
  208. ((string=? line "")
  209. (get-delimited-base64 port))
  210. ((and (string-prefix? "-----BEGIN " line)
  211. (string-suffix? "-----" line))
  212. (let* ((type (substring line 11 (- (string-length line) 5)))
  213. (endline (string-append "-----END " type "-----")))
  214. (let-values (((outp extract) (open-bytevector-output-port)))
  215. (let lp ((line (get-first-data-line port)))
  216. (cond ((eof-object? line)
  217. (error 'get-delimited-base64
  218. "unexpected end of file"))
  219. ((string-prefix? "-" line)
  220. (unless (string=? line endline)
  221. (error 'get-delimited-base64
  222. "bad end delimiter" type line))
  223. (values type (extract)))
  224. (else
  225. (unless (and (= (string-length line) 5)
  226. (string-prefix? "=" line)) ;Skip Radix-64 checksum
  227. (base64-decode line base64-alphabet outp))
  228. (lp (get-line-comp string-trim-both port))))))))
  229. (else ;skip garbage (like in openssl x509 -in foo -text output).
  230. (get-delimited-base64 port)))))
  231. (define put-delimited-base64
  232. (case-lambda
  233. ((port type bv line-length)
  234. (display (string-append "-----BEGIN " type "-----\n") port)
  235. (base64-encode bv 0 (bytevector-length bv)
  236. line-length #f base64-alphabet port)
  237. (display (string-append "\n-----END " type "-----\n") port))
  238. ((port type bv)
  239. (put-delimited-base64 port type bv 76))))