From f9c7080aa3acafc6fb15fa1b304670acfe114704 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Fri, 1 Jun 2012 23:29:55 +0200
Subject: [PATCH] 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 +++++++++++++++++++++++++++++++++++++++++++------
 tests/utils.scm | 21 +++++++++++++++-
 2 files changed, 77 insertions(+), 9 deletions(-)

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 @@
       (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 @@ the previous application or INIT."
         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 @@ the previous application or INIT."
     #\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.
diff --git a/tests/utils.scm b/tests/utils.scm
index 57705e6f48..eade84b5d4 100644
--- a/tests/utils.scm
+++ b/tests/utils.scm
@@ -22,7 +22,10 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-64)
-  #:use-module (rnrs bytevectors))
+  #:use-module (rnrs bytevectors)
+  #:use-module (rnrs io ports)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 popen))
 
 (test-begin "utils")
 
@@ -43,6 +46,22 @@
           "mzxw6ytb"
           "mzxw6ytboi")))
 
+;; The following tests requires `nix-hash' in $PATH.
+(test-skip (if (false-if-exception (system* "nix-hash" "--version"))
+               0
+               1))
+
+(test-assert "sha256 & bytevector->nix-base32-string"
+  (let ((file (search-path %load-path "tests/test.drv")))
+    (equal? (bytevector->nix-base32-string
+             (sha256 (call-with-input-file file get-bytevector-all)))
+            (let* ((c (format #f "nix-hash --type sha256 --base32 --flat \"~a\""
+                              file))
+                   (p (open-input-pipe c))
+                   (l (read-line p)))
+              (close-pipe p)
+              l))))
+
 (test-end)