1 files changed, 53 insertions, 0 deletions
diff --git a/aws/cloudformation/utils/base32.scm b/aws/cloudformation/utils/base32.scm
new file mode 100644
index 0000000..4a01825
--- /dev/null
+++ b/aws/cloudformation/utils/base32.scm
@@ -0,0 +1,53 @@
+(define-module (aws cloudformation utils base32)
+  #:use-module (rnrs bytevectors)
+  #:use-module (srfi srfi-60)
+  #:export (base32-encode))
+
+;; Credit to Ludovic Courtes
+(define bytevector-quintet-ref
+  (let* ((ref  bytevector-u8-ref)
+         (ref+ (lambda (bv offset)
+                 (let ((o (+ 1 offset)))
+                   (if (>= o (bytevector-length bv))
+                       0
+                       (bytevector-u8-ref bv o)))))
+         (ref0 (lambda (bv offset)
+                 (bit-field (ref bv offset) 3 8)))
+         (ref1 (lambda (bv offset)
+                 (logior (ash (bit-field (ref bv offset) 0 3) 2)
+                         (bit-field (ref+ bv offset) 6 8))))
+         (ref2 (lambda (bv offset)
+                 (bit-field (ref bv offset) 1 6)))
+         (ref3 (lambda (bv offset)
+                 (logior (ash (bit-field (ref bv offset) 0 1) 4)
+                         (bit-field (ref+ bv offset) 4 8))))
+         (ref4 (lambda (bv offset)
+                 (logior (ash (bit-field (ref bv offset) 0 4) 1)
+                         (bit-field (ref+ bv offset) 7 8))))
+         (ref5 (lambda (bv offset)
+                 (bit-field (ref bv offset) 2 7)))
+         (ref6 (lambda (bv offset)
+                 (logior (ash (bit-field (ref bv offset) 0 2) 3)
+                         (bit-field (ref+ bv offset) 5 8))))
+         (ref7 (lambda (bv offset)
+                 (bit-field (ref bv offset) 0 5)))
+         (refs (vector ref0 ref1 ref2 ref3 ref4 ref5 ref6 ref7)))
+    (lambda (bv index)
+      "Return the INDEXth quintet of BV."
+      (let ((p (vector-ref refs (modulo index 8))))
+        (p bv (quotient (* index 5) 8))))))
+
+(define (base32-encode bv)
+  ;; We are assuming that the bytevector length is divisible by 5,
+  ;; because that is the case for SHA-1 hashes. A general-purpose
+  ;; base32 encoder would need to pad the bytevector when this is not
+  ;; the case.
+  (let* ((alphabet "0123456789ABCDEFGHJKMNPQRSTVWXYZ")
+         (n (/ (* (bytevector-length bv) 8) 5))
+         (s (make-string n)))
+    (let loop ((i 0))
+      (when (< i n)
+        (let ((x (bytevector-quintet-ref bv i)))
+          (string-set! s i (string-ref alphabet x))
+          (loop (+ i 1)))))
+    s))