From f9c7080aa3acafc6fb15fa1b304670acfe114704 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Fri, 1 Jun 2012 23:29:55 +0200
Subject: Fix `bytevector->nix-base32-string'.

* guix/utils.scm (bytevector-quintet-ref-right,
  bytevector-quintet-fold): New procedures.
  (bytevector-quintet-fold-right): Add `quintet-fold' parameter; use it
  instead of `bytevector-quintet-fold'.
  (bytevector->base32-string): Pass BYTEVECTOR-QUINTET-FOLD as the
  first parameter.
  (bytevector->nix-base32-string): Pass BYTEVECTOR-QUINTET-FOLD-RIGHT as
  the first parameter.

* tests/utils.scm ("sha256 & bytevector->nix-base32-string"): New test.
---
 guix/utils.scm | 65 ++++++++++++++++++++++++++++++++++++++++++++++++++--------
 1 file changed, 57 insertions(+), 8 deletions(-)

(limited to 'guix')

diff --git a/guix/utils.scm b/guix/utils.scm
index db37d432e8..ad7fe8583f 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -60,6 +60,40 @@ (define bytevector-quintet-ref
       (let ((p (vector-ref refs (modulo index 8))))
         (p bv (quotient (* index 5) 8))))))
 
+(define bytevector-quintet-ref-right
+  (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) 0 5)))
+         (ref1 (lambda (bv offset)
+                 (logior (bit-field (ref bv offset) 5 8)
+                         (ash (bit-field (ref+ bv offset) 0 2) 3))))
+         (ref2 (lambda (bv offset)
+                 (bit-field (ref bv offset) 2 7)))
+         (ref3 (lambda (bv offset)
+                 (logior (bit-field (ref bv offset) 7 8)
+                         (ash (bit-field (ref+ bv offset) 0 4) 1))))
+         (ref4 (lambda (bv offset)
+                 (logior (bit-field (ref bv offset) 4 8)
+                         (ash (bit-field (ref+ bv offset) 0 1) 4))))
+         (ref5 (lambda (bv offset)
+                 (bit-field (ref bv offset) 1 6)))
+         (ref6 (lambda (bv offset)
+                 (logior (bit-field (ref bv offset) 6 8)
+                         (ash (bit-field (ref+ bv offset) 0 3) 2))))
+         (ref7 (lambda (bv offset)
+                 (bit-field (ref bv offset) 3 8)))
+         (refs (vector ref0 ref1 ref2 ref3 ref4 ref5 ref6 ref7)))
+    (lambda (bv index)
+      "Return the INDEXth quintet of BV, assuming quintets start from the
+least-significant bits, contrary to what RFC 4648 describes."
+      (let ((p (vector-ref refs (modulo index 8))))
+        (p bv (quotient (* index 5) 8))))))
+
 (define (bytevector-quintet-length bv)
   "Return the number of quintets (including truncated ones) available in BV."
   (ceiling (/ (* (bytevector-length bv) 8) 5)))
@@ -76,14 +110,27 @@ (define len
         r
         (loop (1+ i) (proc (bytevector-quintet-ref bv i) r)))))
 
-(define (make-bytevector->base32-string base32-chars)
+(define (bytevector-quintet-fold-right proc init bv)
+  "Return the result of applying PROC to each quintet of BV and the result of
+the previous application or INIT."
+  (define len
+    (bytevector-quintet-length bv))
+
+  (let loop ((i len)
+             (r init))
+    (if (zero? i)
+        r
+        (let ((j (- i 1)))
+          (loop j (proc (bytevector-quintet-ref-right bv j) r))))))
+
+(define (make-bytevector->base32-string quintet-fold base32-chars)
   (lambda (bv)
     "Return a base32 encoding of BV using BASE32-CHARS as the alphabet."
-    (let ((chars (bytevector-quintet-fold (lambda (q r)
-                                            (cons (vector-ref base32-chars q)
-                                                  r))
-                                          '()
-                                          bv)))
+    (let ((chars (quintet-fold (lambda (q r)
+                                 (cons (vector-ref base32-chars q)
+                                       r))
+                               '()
+                               bv)))
       (list->string (reverse chars)))))
 
 (define %nix-base32-chars
@@ -98,10 +145,12 @@ (define %rfc4648-base32-chars
     #\2 #\3 #\4 #\5 #\6 #\7))
 
 (define bytevector->base32-string
-  (make-bytevector->base32-string %rfc4648-base32-chars))
+  (make-bytevector->base32-string bytevector-quintet-fold
+                                  %rfc4648-base32-chars))
 
 (define bytevector->nix-base32-string
-  (make-bytevector->base32-string %nix-base32-chars))
+  (make-bytevector->base32-string bytevector-quintet-fold-right
+                                  %nix-base32-chars))
 
 ;;;
 ;;; Hash.
-- 
cgit v1.2.3