Mirror of GNU Guix
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.

303 lines
13 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2012, 2015 Ludovic Courtès <ludo@gnu.org>
  3. ;;;
  4. ;;; This file is part of GNU Guix.
  5. ;;;
  6. ;;; GNU Guix is free software; you can redistribute it and/or modify it
  7. ;;; under the terms of the GNU General Public License as published by
  8. ;;; the Free Software Foundation; either version 3 of the License, or (at
  9. ;;; your option) any later version.
  10. ;;;
  11. ;;; GNU Guix is distributed in the hope that it will be useful, but
  12. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  14. ;;; GNU General Public License for more details.
  15. ;;;
  16. ;;; You should have received a copy of the GNU General Public License
  17. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
  18. (define-module (guix base32)
  19. #:use-module (srfi srfi-1)
  20. #:use-module (srfi srfi-34)
  21. #:use-module (srfi srfi-35)
  22. #:use-module (srfi srfi-60)
  23. #:use-module (rnrs bytevectors)
  24. #:use-module (ice-9 vlist)
  25. #:export (bytevector-quintet-length
  26. bytevector->base32-string
  27. bytevector->nix-base32-string
  28. base32-string->bytevector
  29. nix-base32-string->bytevector
  30. &invalid-base32-character
  31. invalid-base32-character?
  32. invalid-base32-character-value
  33. invalid-base32-character-string))
  34. ;;; Commentary:
  35. ;;;
  36. ;;; A generic, customizable to convert bytevectors to/from a base32
  37. ;;; representation.
  38. ;;;
  39. ;;; Code:
  40. (define bytevector-quintet-ref
  41. (let* ((ref bytevector-u8-ref)
  42. (ref+ (lambda (bv offset)
  43. (let ((o (+ 1 offset)))
  44. (if (>= o (bytevector-length bv))
  45. 0
  46. (bytevector-u8-ref bv o)))))
  47. (ref0 (lambda (bv offset)
  48. (bit-field (ref bv offset) 3 8)))
  49. (ref1 (lambda (bv offset)
  50. (logior (ash (bit-field (ref bv offset) 0 3) 2)
  51. (bit-field (ref+ bv offset) 6 8))))
  52. (ref2 (lambda (bv offset)
  53. (bit-field (ref bv offset) 1 6)))
  54. (ref3 (lambda (bv offset)
  55. (logior (ash (bit-field (ref bv offset) 0 1) 4)
  56. (bit-field (ref+ bv offset) 4 8))))
  57. (ref4 (lambda (bv offset)
  58. (logior (ash (bit-field (ref bv offset) 0 4) 1)
  59. (bit-field (ref+ bv offset) 7 8))))
  60. (ref5 (lambda (bv offset)
  61. (bit-field (ref bv offset) 2 7)))
  62. (ref6 (lambda (bv offset)
  63. (logior (ash (bit-field (ref bv offset) 0 2) 3)
  64. (bit-field (ref+ bv offset) 5 8))))
  65. (ref7 (lambda (bv offset)
  66. (bit-field (ref bv offset) 0 5)))
  67. (refs (vector ref0 ref1 ref2 ref3 ref4 ref5 ref6 ref7)))
  68. (lambda (bv index)
  69. "Return the INDEXth quintet of BV."
  70. (let ((p (vector-ref refs (modulo index 8))))
  71. (p bv (quotient (* index 5) 8))))))
  72. (define bytevector-quintet-ref-right
  73. (let* ((ref bytevector-u8-ref)
  74. (ref+ (lambda (bv offset)
  75. (let ((o (+ 1 offset)))
  76. (if (>= o (bytevector-length bv))
  77. 0
  78. (bytevector-u8-ref bv o)))))
  79. (ref0 (lambda (bv offset)
  80. (bit-field (ref bv offset) 0 5)))
  81. (ref1 (lambda (bv offset)
  82. (logior (bit-field (ref bv offset) 5 8)
  83. (ash (bit-field (ref+ bv offset) 0 2) 3))))
  84. (ref2 (lambda (bv offset)
  85. (bit-field (ref bv offset) 2 7)))
  86. (ref3 (lambda (bv offset)
  87. (logior (bit-field (ref bv offset) 7 8)
  88. (ash (bit-field (ref+ bv offset) 0 4) 1))))
  89. (ref4 (lambda (bv offset)
  90. (logior (bit-field (ref bv offset) 4 8)
  91. (ash (bit-field (ref+ bv offset) 0 1) 4))))
  92. (ref5 (lambda (bv offset)
  93. (bit-field (ref bv offset) 1 6)))
  94. (ref6 (lambda (bv offset)
  95. (logior (bit-field (ref bv offset) 6 8)
  96. (ash (bit-field (ref+ bv offset) 0 3) 2))))
  97. (ref7 (lambda (bv offset)
  98. (bit-field (ref bv offset) 3 8)))
  99. (refs (vector ref0 ref1 ref2 ref3 ref4 ref5 ref6 ref7)))
  100. (lambda (bv index)
  101. "Return the INDEXth quintet of BV, assuming quintets start from the
  102. least-significant bits, contrary to what RFC 4648 describes."
  103. (let ((p (vector-ref refs (modulo index 8))))
  104. (p bv (quotient (* index 5) 8))))))
  105. (define (bytevector-quintet-length bv)
  106. "Return the number of quintets (including truncated ones) available in BV."
  107. (ceiling (/ (* (bytevector-length bv) 8) 5)))
  108. (define (bytevector-quintet-fold proc init bv)
  109. "Return the result of applying PROC to each quintet of BV and the result of
  110. the previous application or INIT."
  111. (define len
  112. (bytevector-quintet-length bv))
  113. (let loop ((i 0)
  114. (r init))
  115. (if (= i len)
  116. r
  117. (loop (1+ i) (proc (bytevector-quintet-ref bv i) r)))))
  118. (define (bytevector-quintet-fold-right proc init bv)
  119. "Return the result of applying PROC to each quintet of BV and the result of
  120. the previous application or INIT."
  121. (define len
  122. (bytevector-quintet-length bv))
  123. (let loop ((i len)
  124. (r init))
  125. (if (zero? i)
  126. r
  127. (let ((j (- i 1)))
  128. (loop j (proc (bytevector-quintet-ref-right bv j) r))))))
  129. (define (make-bytevector->base32-string quintet-fold base32-chars)
  130. (lambda (bv)
  131. "Return a base32 encoding of BV using BASE32-CHARS as the alphabet."
  132. (let ((chars (quintet-fold (lambda (q r)
  133. (cons (vector-ref base32-chars q)
  134. r))
  135. '()
  136. bv)))
  137. (list->string (reverse chars)))))
  138. (define %nix-base32-chars
  139. ;; See `libutil/hash.cc'.
  140. #(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9
  141. #\a #\b #\c #\d #\f #\g #\h #\i #\j #\k #\l #\m #\n
  142. #\p #\q #\r #\s #\v #\w #\x #\y #\z))
  143. (define %rfc4648-base32-chars
  144. #(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m
  145. #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z
  146. #\2 #\3 #\4 #\5 #\6 #\7))
  147. (define bytevector->base32-string
  148. (make-bytevector->base32-string bytevector-quintet-fold
  149. %rfc4648-base32-chars))
  150. (define bytevector->nix-base32-string
  151. (make-bytevector->base32-string bytevector-quintet-fold-right
  152. %nix-base32-chars))
  153. (define bytevector-quintet-set!
  154. (let* ((setq! (lambda (bv offset start stop value)
  155. (let ((v (bytevector-u8-ref bv offset))
  156. (w (arithmetic-shift value start))
  157. (m (bitwise-xor (1- (expt 2 stop))
  158. (1- (expt 2 start)))))
  159. (bytevector-u8-set! bv offset
  160. (bitwise-merge m w v)))))
  161. (set0! (lambda (bv offset value)
  162. (setq! bv offset 3 8 value)))
  163. (set1! (lambda (bv offset value)
  164. (setq! bv offset 0 3 (bit-field value 2 5))
  165. (or (= (+ 1 offset) (bytevector-length bv))
  166. (setq! bv (+ 1 offset) 6 8 (bit-field value 0 2)))))
  167. (set2! (lambda (bv offset value)
  168. (setq! bv offset 1 6 value)))
  169. (set3! (lambda (bv offset value)
  170. (setq! bv offset 0 1 (bit-field value 4 5))
  171. (or (= (+ 1 offset) (bytevector-length bv))
  172. (setq! bv (+ 1 offset) 4 8 (bit-field value 0 4)))))
  173. (set4! (lambda (bv offset value)
  174. (setq! bv offset 0 4 (bit-field value 1 5))
  175. (or (= (+ 1 offset) (bytevector-length bv))
  176. (setq! bv (+ 1 offset) 7 8 (bit-field value 0 1)))))
  177. (set5! (lambda (bv offset value)
  178. (setq! bv offset 2 7 value)))
  179. (set6! (lambda (bv offset value)
  180. (setq! bv offset 0 2 (bit-field value 3 5))
  181. (or (= (+ 1 offset) (bytevector-length bv))
  182. (setq! bv (+ 1 offset) 5 8 (bit-field value 0 3)))))
  183. (set7! (lambda (bv offset value)
  184. (setq! bv offset 0 5 value)))
  185. (sets (vector set0! set1! set2! set3! set4! set5! set6! set7!)))
  186. (lambda (bv index value)
  187. "Set the INDEXth quintet of BV to VALUE."
  188. (let ((p (vector-ref sets (modulo index 8))))
  189. (p bv (quotient (* index 5) 8) (logand value #x1f))))))
  190. (define bytevector-quintet-set-right!
  191. (let* ((setq! (lambda (bv offset start stop value)
  192. (let ((v (bytevector-u8-ref bv offset))
  193. (w (arithmetic-shift value start))
  194. (m (bitwise-xor (1- (expt 2 stop))
  195. (1- (expt 2 start)))))
  196. (bytevector-u8-set! bv offset
  197. (bitwise-merge m w v)))))
  198. (set0! (lambda (bv offset value)
  199. (setq! bv offset 0 5 value)))
  200. (set1! (lambda (bv offset value)
  201. (setq! bv offset 5 8 (bit-field value 0 3))
  202. (or (= (+ 1 offset) (bytevector-length bv))
  203. (setq! bv (+ 1 offset) 0 2 (bit-field value 3 5)))))
  204. (set2! (lambda (bv offset value)
  205. (setq! bv offset 2 7 value)))
  206. (set3! (lambda (bv offset value)
  207. (setq! bv offset 7 8 (bit-field value 0 1))
  208. (or (= (+ 1 offset) (bytevector-length bv))
  209. (setq! bv (+ 1 offset) 0 4 (bit-field value 1 5)))))
  210. (set4! (lambda (bv offset value)
  211. (setq! bv offset 4 8 (bit-field value 0 4))
  212. (or (= (+ 1 offset) (bytevector-length bv))
  213. (setq! bv (+ 1 offset) 0 1 (bit-field value 4 5)))))
  214. (set5! (lambda (bv offset value)
  215. (setq! bv offset 1 6 value)))
  216. (set6! (lambda (bv offset value)
  217. (setq! bv offset 6 8 (bit-field value 0 2))
  218. (or (= (+ 1 offset) (bytevector-length bv))
  219. (setq! bv (+ 1 offset) 0 3 (bit-field value 2 5)))))
  220. (set7! (lambda (bv offset value)
  221. (setq! bv offset 3 8 value)))
  222. (sets (vector set0! set1! set2! set3! set4! set5! set6! set7!)))
  223. (lambda (bv index value)
  224. "Set the INDEXth quintet of BV to VALUE, assuming quintets start from
  225. the least-significant bits."
  226. (let ((p (vector-ref sets (modulo index 8))))
  227. (p bv (quotient (* index 5) 8) (logand value #x1f))))))
  228. (define (base32-string-unfold f s)
  229. "Given procedure F which, when applied to a character, returns the
  230. corresponding quintet, return the bytevector corresponding to string S."
  231. (define len (string-length s))
  232. (let ((bv (make-bytevector (quotient (* len 5) 8))))
  233. (string-fold (lambda (chr index)
  234. (bytevector-quintet-set! bv index (f chr))
  235. (+ 1 index))
  236. 0
  237. s)
  238. bv))
  239. (define (base32-string-unfold-right f s)
  240. "Given procedure F which, when applied to a character, returns the
  241. corresponding quintet, return the bytevector corresponding to string S,
  242. starting from the right of S."
  243. (define len (string-length s))
  244. (let ((bv (make-bytevector (quotient (* len 5) 8))))
  245. (string-fold-right (lambda (chr index)
  246. (bytevector-quintet-set-right! bv index (f chr))
  247. (+ 1 index))
  248. 0
  249. s)
  250. bv))
  251. ;; Invalid base32 character error condition when decoding base32.
  252. (define-condition-type &invalid-base32-character &error
  253. invalid-base32-character?
  254. (character invalid-base32-character-value)
  255. (string invalid-base32-character-string))
  256. (define (make-base32-string->bytevector base32-string-unfold base32-chars)
  257. (let ((char->value (let loop ((i 0)
  258. (v vlist-null))
  259. (if (= i (vector-length base32-chars))
  260. v
  261. (loop (+ 1 i)
  262. (vhash-consv (vector-ref base32-chars i)
  263. i v))))))
  264. (lambda (s)
  265. "Return the binary representation of base32 string S as a bytevector."
  266. (base32-string-unfold (lambda (chr)
  267. (or (and=> (vhash-assv chr char->value) cdr)
  268. (raise (condition
  269. (&invalid-base32-character
  270. (character chr)
  271. (string s))))))
  272. s))))
  273. (define base32-string->bytevector
  274. (make-base32-string->bytevector base32-string-unfold %rfc4648-base32-chars))
  275. (define nix-base32-string->bytevector
  276. (make-base32-string->bytevector base32-string-unfold-right %nix-base32-chars))
  277. ;;; base32.scm ends here