Merge branch 'master' into core-updates

5 files changed, 272 insertions, 5 deletions

diff --git a/tests/guix-register.sh b/tests/guix-register.sh
index ca28fb0d95..ee633af4f9 100644
--- a/tests/guix-register.sh
+++ b/tests/guix-register.sh
@@ -1,5 +1,5 @@
 # GNU Guix --- Functional package management for GNU
-# Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
+# Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
 #
 # This file is part of GNU Guix.
 #
@@ -29,6 +29,33 @@ rm -rf "$new_store"
 exit_hook=":"
 trap "chmod -R +w $new_store ; rm -rf $new_store $closure ; \$exit_hook" EXIT
 
+#
+# Registering items in the current store---i.e., without '--prefix'.
+#
+
+new_file="$NIX_STORE_DIR/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-guix-register-$$"
+echo "Fake store file to test registration." > "$new_file"
+
+# Register the file with zero references and no deriver.
+guix-register <<EOF
+$new_file
+
+0
+EOF
+
+# Make sure it's valid, and delete it.
+guile -c "
+   (use-modules (guix store))
+   (define s (open-connection))
+   (exit (and (valid-path? s \"$new_file\")
+              (null? (references s \"$new_file\"))
+              (pair? (delete-paths s (list \"$new_file\")))))"
+
+
+#
+# Registering items in a new store, with '--prefix'.
+#
+
 mkdir -p "$new_store/$storedir"
 new_store_dir="`cd "$new_store/$storedir" ; pwd`"
 new_store="`cd "$new_store" ; pwd`"
diff --git a/tests/hash.scm b/tests/hash.scm
index 27751023d3..9bcd69440b 100644
--- a/tests/hash.scm
+++ b/tests/hash.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -37,6 +37,14 @@
   (base16-string->bytevector
    "b94d27b9934d3e08a52e52d7da7dabfac484efe37a5380ee9088f7ace2efcde9"))
 
+(define (supports-unbuffered-cbip?)
+  "Return #t if unbuffered custom binary input ports (CBIPs) are supported.
+In Guile <= 2.0.9, CBIPs were always fully buffered, so the
+'open-sha256-input-port' does not work there."
+  (false-if-exception
+   (setvbuf (make-custom-binary-input-port "foo" pk #f #f #f) _IONBF)))
+
+
 (test-begin "hash")
 
 (test-equal "sha256, empty"
@@ -68,6 +76,55 @@
     (equal? (sha256 contents)
             (call-with-input-file file port-sha256))))
 
+(test-skip (if (supports-unbuffered-cbip?) 0 4))
+
+(test-equal "open-sha256-input-port, empty"
+  `("" ,%empty-sha256)
+  (let-values (((port get)
+                (open-sha256-input-port (open-string-input-port ""))))
+    (let ((str (get-string-all port)))
+      (list str (get)))))
+
+(test-equal "open-sha256-input-port, hello"
+  `("hello world" ,%hello-sha256)
+  (let-values (((port get)
+                (open-sha256-input-port
+                 (open-bytevector-input-port
+                  (string->utf8 "hello world")))))
+    (let ((str (get-string-all port)))
+      (list str (get)))))
+
+(test-equal "open-sha256-input-port, hello, one two"
+  (list (string->utf8 "hel") (string->utf8 "lo")
+        (base16-string->bytevector                ; echo -n hello | sha256sum
+         "2cf24dba5fb0a30e26e83b2ac5b9e29e1b161e5c1fa7425e73043362938b9824")
+        " world")
+  (let-values (((port get)
+                (open-sha256-input-port
+                 (open-bytevector-input-port (string->utf8 "hello world")))))
+    (let* ((one   (get-bytevector-n port 3))
+           (two   (get-bytevector-n port 2))
+           (hash  (get))
+           (three (get-string-all port)))
+      (list one two hash three))))
+
+(test-equal "open-sha256-input-port, hello, read from wrapped port"
+  (list (string->utf8 "hello")
+        (base16-string->bytevector                ; echo -n hello | sha256sum
+         "2cf24dba5fb0a30e26e83b2ac5b9e29e1b161e5c1fa7425e73043362938b9824")
+        " world")
+  (let*-values (((wrapped)
+                 (open-bytevector-input-port (string->utf8 "hello world")))
+                ((port get)
+                 (open-sha256-input-port wrapped)))
+    (let* ((hello (get-bytevector-n port 5))
+           (hash  (get))
+
+           ;; Now read from WRAPPED to make sure its current position is
+           ;; correct.
+           (world (get-string-all wrapped)))
+      (list hello hash world))))
+
 (test-end)
 
 
diff --git a/tests/nar.scm b/tests/nar.scm
index 6493d76876..9f21f990c8 100644
--- a/tests/nar.scm
+++ b/tests/nar.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -18,11 +18,17 @@
 
 (define-module (test-nar)
   #:use-module (guix nar)
+  #:use-module (guix store)
+  #:use-module ((guix hash) #:select (open-sha256-input-port))
   #:use-module (rnrs bytevectors)
   #:use-module (rnrs io ports)
+  #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
   #:use-module (srfi srfi-64)
   #:use-module (ice-9 ftw)
+  #:use-module (ice-9 regex)
   #:use-module (ice-9 match))
 
 ;; Test the (guix nar) module.
@@ -156,6 +162,24 @@
   (string-append (dirname (search-path %load-path "pre-inst-env"))
                  "/test-nar-" (number->string (getpid))))
 
+;; XXX: Factorize.
+(define %seed
+  (seed->random-state (logxor (getpid) (car (gettimeofday)))))
+
+(define (random-text)
+  (number->string (random (expt 2 256) %seed) 16))
+
+(define-syntax-rule (let/ec k exp...)
+  ;; This one appeared in Guile 2.0.9, so provide a copy here.
+  (let ((tag (make-prompt-tag)))
+    (call-with-prompt tag
+      (lambda ()
+        (let ((k (lambda args
+                   (apply abort-to-prompt tag args))))
+          exp...))
+      (lambda (_ . args)
+        (apply values args)))))
+
 
 (test-begin "nar")
 
@@ -201,6 +225,83 @@
       (lambda ()
         (rmdir input)))))
 
+;; 'restore-file-set' depends on 'open-sha256-input-port', which in turn
+;; relies on a Guile 2.0.10+ feature.
+(test-skip (if (false-if-exception
+                (open-sha256-input-port (%make-void-port "r")))
+               0
+               3))
+
+(test-assert "restore-file-set (signed, valid)"
+  (with-store store
+    (let* ((texts (unfold (cut >= <> 10)
+                          (lambda _ (random-text))
+                          1+
+                          0))
+           (files (map (cut add-text-to-store store "text" <>) texts))
+           (dump  (call-with-bytevector-output-port
+                   (cut export-paths store files <>))))
+      (delete-paths store files)
+      (and (every (negate file-exists?) files)
+           (let* ((source   (open-bytevector-input-port dump))
+                  (imported (restore-file-set source)))
+             (and (equal? imported files)
+                  (every (lambda (file)
+                           (and (file-exists? file)
+                                (valid-path? store file)))
+                         files)
+                  (equal? texts
+                          (map (lambda (file)
+                                 (call-with-input-file file
+                                   get-string-all))
+                               files))))))))
+
+(test-assert "restore-file-set (missing signature)"
+  (let/ec return
+    (with-store store
+      (let* ((file  (add-text-to-store store "foo" "Hello, world!"))
+             (dump  (call-with-bytevector-output-port
+                     (cute export-paths store (list file) <>
+                           #:sign? #f))))
+        (delete-paths store (list file))
+        (and (not (file-exists? file))
+             (let ((source (open-bytevector-input-port dump)))
+               (guard (c ((nar-signature-error? c)
+                          (let ((message (condition-message c))
+                                (port    (nar-error-port c)))
+                            (return
+                             (and (string-match "lacks.*signature" message)
+                                  (string=? file (nar-error-file c))
+                                  (eq? source port))))))
+                 (restore-file-set source))
+               #f))))))
+
+(test-assert "restore-file-set (corrupt)"
+  (let/ec return
+    (with-store store
+      (let* ((file  (add-text-to-store store "foo"
+                                       (random-text)))
+             (dump  (call-with-bytevector-output-port
+                     (cute export-paths store (list file) <>))))
+        (delete-paths store (list file))
+
+        ;; Flip a byte in the file contents.
+        (let* ((index 120)
+               (byte  (bytevector-u8-ref dump index)))
+          (bytevector-u8-set! dump index (logxor #xff byte)))
+
+        (and (not (file-exists? file))
+             (let ((source (open-bytevector-input-port dump)))
+               (guard (c ((nar-invalid-hash-error? c)
+                          (let ((message (condition-message c))
+                                (port    (nar-error-port c)))
+                            (return
+                             (and (string-contains message "hash")
+                                  (string=? file (nar-error-file c))
+                                  (eq? source port))))))
+                 (restore-file-set source))
+               #f))))))
+
 (test-end "nar")
 
 
diff --git a/tests/store.scm b/tests/store.scm
index 4bd739e7f6..a61d449fb4 100644
--- a/tests/store.scm
+++ b/tests/store.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -162,6 +162,38 @@
          (equal? (valid-derivers %store o)
                  (list (derivation-file-name d))))))
 
+(test-assert "topologically-sorted, one item"
+  (let* ((a (add-text-to-store %store "a" "a"))
+         (b (add-text-to-store %store "b" "b" (list a)))
+         (c (add-text-to-store %store "c" "c" (list b)))
+         (d (add-text-to-store %store "d" "d" (list c)))
+         (s (topologically-sorted %store (list d))))
+    (equal? s (list a b c d))))
+
+(test-assert "topologically-sorted, several items"
+  (let* ((a  (add-text-to-store %store "a" "a"))
+         (b  (add-text-to-store %store "b" "b" (list a)))
+         (c  (add-text-to-store %store "c" "c" (list b)))
+         (d  (add-text-to-store %store "d" "d" (list c)))
+         (s1 (topologically-sorted %store (list d a c b)))
+         (s2 (topologically-sorted %store (list b d c a b d))))
+    (equal? s1 s2 (list a b c d))))
+
+(test-assert "topologically-sorted, more difficult"
+  (let* ((a  (add-text-to-store %store "a" "a"))
+         (b  (add-text-to-store %store "b" "b" (list a)))
+         (c  (add-text-to-store %store "c" "c" (list b)))
+         (d  (add-text-to-store %store "d" "d" (list c)))
+         (w  (add-text-to-store %store "w" "w"))
+         (x  (add-text-to-store %store "x" "x" (list w)))
+         (y  (add-text-to-store %store "y" "y" (list x d)))
+         (s1 (topologically-sorted %store (list y)))
+         (s2 (topologically-sorted %store (list c y)))
+         (s3 (topologically-sorted %store (cons y (references %store y)))))
+    (and (equal? s1 (list w x a b c d y))
+         (equal? s2 (list a b c w x d y))
+         (lset= string=? s1 s3))))
+
 (test-assert "log-file, derivation"
   (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '()))
          (s (add-to-store %store "bash" #t "sha256"
@@ -389,6 +421,26 @@ Deriver: ~a~%"
              (pk 'corrupt-imported imported)
              #f)))))
 
+(test-assert "register-path"
+  (let ((file (string-append (%store-prefix) "/" (make-string 32 #\f)
+                             "-fake")))
+    (when (valid-path? %store file)
+      (delete-paths %store (list file)))
+    (false-if-exception (delete-file file))
+
+    (let ((ref (add-text-to-store %store "ref-of-fake" (random-text)))
+          (drv (string-append file ".drv")))
+      (call-with-output-file file
+        (cut display "This is a fake store item.\n" <>))
+      (register-path file
+                     #:references (list ref)
+                     #:deriver drv)
+
+      (and (valid-path? %store file)
+           (equal? (references %store file) (list ref))
+           (null? (valid-derivers %store file))
+           (null? (referrers %store file))))))
+
 (test-end "store")
 
 
diff --git a/tests/utils.scm b/tests/utils.scm
index 017d9170fa..b5706aa792 100644
--- a/tests/utils.scm
+++ b/tests/utils.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -139,6 +139,36 @@
                    (append pids1 pids2)))
            (equal? (get-bytevector-all decompressed) data)))))
 
+(test-equal "fcntl-flock"
+  0                                               ; the child's exit status
+  (let ((file (open-input-file (search-path %load-path "guix.scm"))))
+    (fcntl-flock file 'read-lock)
+    (match (primitive-fork)
+      (0
+       (dynamic-wind
+         (const #t)
+         (lambda ()
+           ;; Taking a read lock should be OK.
+           (fcntl-flock file 'read-lock)
+           (fcntl-flock file 'unlock)
+
+           (catch 'flock-error
+             (lambda ()
+               ;; Taking an exclusive lock should raise an exception.
+               (fcntl-flock file 'write-lock))
+             (lambda args
+               (primitive-exit 0)))
+           (primitive-exit 1))
+         (lambda ()
+           (primitive-exit 2))))
+      (pid
+       (match (waitpid pid)
+         ((_  . status)
+          (let ((result (status:exit-val status)))
+            (fcntl-flock file 'unlock)
+            (close-port file)
+            result)))))))
+
 ;; This is actually in (guix store).
 (test-equal "store-path-package-name"
   "bash-4.2-p24"