You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 
 
 

212 lines
9.9 KiB

  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. ;;
  7. ;; Copyright © 2009, 2010 Göran Weinholt <goran@weinholt.se>
  8. ;;
  9. ;; This program is free software: you can redistribute it and/or modify
  10. ;; it under the terms of the GNU General Public License as published by
  11. ;; the Free Software Foundation, either version 3 of the License, or
  12. ;; (at your option) any later version.
  13. ;;
  14. ;; This program is distributed in the hope that it will be useful,
  15. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  17. ;; GNU General Public License for more details.
  18. ;;
  19. ;; You should have received a copy of the GNU General Public License
  20. ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
  21. #!r6rs
  22. ;; RFC 4648 Base-N Encodings
  23. (library (guix base64)
  24. (export base64-encode
  25. base64-decode
  26. base64-alphabet
  27. base64url-alphabet
  28. get-delimited-base64
  29. put-delimited-base64)
  30. (import (rnrs)
  31. (only (srfi :13 strings)
  32. string-index
  33. string-prefix? string-suffix?
  34. string-concatenate string-trim-both))
  35. (define base64-alphabet
  36. "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
  37. (define base64url-alphabet
  38. "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_")
  39. (define base64-encode
  40. (case-lambda
  41. ;; Simple interface. Returns a string containing the canonical
  42. ;; base64 representation of the given bytevector.
  43. ((bv)
  44. (base64-encode bv 0 (bytevector-length bv) #f #f base64-alphabet #f))
  45. ((bv start)
  46. (base64-encode bv start (bytevector-length bv) #f #f base64-alphabet #f))
  47. ((bv start end)
  48. (base64-encode bv start end #f #f base64-alphabet #f))
  49. ((bv start end line-length)
  50. (base64-encode bv start end line-length #f base64-alphabet #f))
  51. ((bv start end line-length no-padding)
  52. (base64-encode bv start end line-length no-padding base64-alphabet #f))
  53. ((bv start end line-length no-padding alphabet)
  54. (base64-encode bv start end line-length no-padding alphabet #f))
  55. ;; Base64 encodes the bytes [start,end[ in the given bytevector.
  56. ;; Lines are limited to line-length characters (unless #f),
  57. ;; which must be a multiple of four. To omit the padding
  58. ;; characters (#\=) set no-padding to a true value. If port is
  59. ;; #f, returns a string.
  60. ((bv start end line-length no-padding alphabet port)
  61. (assert (or (not line-length) (zero? (mod line-length 4))))
  62. (let-values (((p extract) (if port
  63. (values port (lambda () (values)))
  64. (open-string-output-port))))
  65. (letrec ((put (if line-length
  66. (let ((chars 0))
  67. (lambda (p c)
  68. (when (fx=? chars line-length)
  69. (set! chars 0)
  70. (put-char p #\linefeed))
  71. (set! chars (fx+ chars 1))
  72. (put-char p c)))
  73. put-char)))
  74. (let lp ((i start))
  75. (cond ((= i end))
  76. ((<= (+ i 3) end)
  77. (let ((x (bytevector-uint-ref bv i (endianness big) 3)))
  78. (put p (string-ref alphabet (fxbit-field x 18 24)))
  79. (put p (string-ref alphabet (fxbit-field x 12 18)))
  80. (put p (string-ref alphabet (fxbit-field x 6 12)))
  81. (put p (string-ref alphabet (fxbit-field x 0 6)))
  82. (lp (+ i 3))))
  83. ((<= (+ i 2) end)
  84. (let ((x (fxarithmetic-shift-left (bytevector-u16-ref bv i (endianness big)) 8)))
  85. (put p (string-ref alphabet (fxbit-field x 18 24)))
  86. (put p (string-ref alphabet (fxbit-field x 12 18)))
  87. (put p (string-ref alphabet (fxbit-field x 6 12)))
  88. (unless no-padding
  89. (put p #\=))))
  90. (else
  91. (let ((x (fxarithmetic-shift-left (bytevector-u8-ref bv i) 16)))
  92. (put p (string-ref alphabet (fxbit-field x 18 24)))
  93. (put p (string-ref alphabet (fxbit-field x 12 18)))
  94. (unless no-padding
  95. (put p #\=)
  96. (put p #\=)))))))
  97. (extract)))))
  98. ;; Decodes a base64 string. The string must contain only pure
  99. ;; unpadded base64 data.
  100. (define base64-decode
  101. (case-lambda
  102. ((str)
  103. (base64-decode str base64-alphabet #f))
  104. ((str alphabet)
  105. (base64-decode str alphabet #f))
  106. ((str alphabet port)
  107. (unless (zero? (mod (string-length str) 4))
  108. (error 'base64-decode
  109. "input string must be a multiple of four characters"))
  110. (let-values (((p extract) (if port
  111. (values port (lambda () (values)))
  112. (open-bytevector-output-port))))
  113. (do ((i 0 (+ i 4)))
  114. ((= i (string-length str))
  115. (extract))
  116. (let ((c1 (string-ref str i))
  117. (c2 (string-ref str (+ i 1)))
  118. (c3 (string-ref str (+ i 2)))
  119. (c4 (string-ref str (+ i 3))))
  120. ;; TODO: be more clever than string-index
  121. (let ((i1 (string-index alphabet c1))
  122. (i2 (string-index alphabet c2))
  123. (i3 (string-index alphabet c3))
  124. (i4 (string-index alphabet c4)))
  125. (cond ((and i1 i2 i3 i4)
  126. (let ((x (fxior (fxarithmetic-shift-left i1 18)
  127. (fxarithmetic-shift-left i2 12)
  128. (fxarithmetic-shift-left i3 6)
  129. i4)))
  130. (put-u8 p (fxbit-field x 16 24))
  131. (put-u8 p (fxbit-field x 8 16))
  132. (put-u8 p (fxbit-field x 0 8))))
  133. ((and i1 i2 i3 (char=? c4 #\=)
  134. (= i (- (string-length str) 4)))
  135. (let ((x (fxior (fxarithmetic-shift-left i1 18)
  136. (fxarithmetic-shift-left i2 12)
  137. (fxarithmetic-shift-left i3 6))))
  138. (put-u8 p (fxbit-field x 16 24))
  139. (put-u8 p (fxbit-field x 8 16))))
  140. ((and i1 i2 (char=? c3 #\=) (char=? c4 #\=)
  141. (= i (- (string-length str) 4)))
  142. (let ((x (fxior (fxarithmetic-shift-left i1 18)
  143. (fxarithmetic-shift-left i2 12))))
  144. (put-u8 p (fxbit-field x 16 24))))
  145. (else
  146. (error 'base64-decode "invalid input"
  147. (list c1 c2 c3 c4)))))))))))
  148. (define (get-line-comp f port)
  149. (if (port-eof? port)
  150. (eof-object)
  151. (f (get-line port))))
  152. ;; Reads the common -----BEGIN/END type----- delimited format from
  153. ;; the given port. Returns two values: a string with the type and a
  154. ;; bytevector containing the base64 decoded data. The second value
  155. ;; is the eof object if there is an eof before the BEGIN delimiter.
  156. (define (get-delimited-base64 port)
  157. (define (get-first-data-line port)
  158. ;; Some MIME data has header fields in the same format as mail
  159. ;; or http. These are ignored.
  160. (let ((line (get-line-comp string-trim-both port)))
  161. (cond ((eof-object? line) line)
  162. ((string-index line #\:)
  163. (let lp () ;read until empty line
  164. (let ((line (get-line-comp string-trim-both port)))
  165. (if (string=? line "")
  166. (get-line-comp string-trim-both port)
  167. (lp)))))
  168. (else line))))
  169. (let ((line (get-line-comp string-trim-both port)))
  170. (cond ((eof-object? line)
  171. (values "" (eof-object)))
  172. ((string=? line "")
  173. (get-delimited-base64 port))
  174. ((and (string-prefix? "-----BEGIN " line)
  175. (string-suffix? "-----" line))
  176. (let* ((type (substring line 11 (- (string-length line) 5)))
  177. (endline (string-append "-----END " type "-----")))
  178. (let-values (((outp extract) (open-bytevector-output-port)))
  179. (let lp ((line (get-first-data-line port)))
  180. (cond ((eof-object? line)
  181. (error 'get-delimited-base64
  182. "unexpected end of file"))
  183. ((string-prefix? "-" line)
  184. (unless (string=? line endline)
  185. (error 'get-delimited-base64
  186. "bad end delimiter" type line))
  187. (values type (extract)))
  188. (else
  189. (unless (and (= (string-length line) 5)
  190. (string-prefix? "=" line)) ;Skip Radix-64 checksum
  191. (base64-decode line base64-alphabet outp))
  192. (lp (get-line-comp string-trim-both port))))))))
  193. (else ;skip garbage (like in openssl x509 -in foo -text output).
  194. (get-delimited-base64 port)))))
  195. (define put-delimited-base64
  196. (case-lambda
  197. ((port type bv line-length)
  198. (display (string-append "-----BEGIN " type "-----\n") port)
  199. (base64-encode bv 0 (bytevector-length bv)
  200. line-length #f base64-alphabet port)
  201. (display (string-append "\n-----END " type "-----\n") port))
  202. ((port type bv)
  203. (put-delimited-base64 port type bv 76)))))