From c63d94035f7cff02d885f9deaaf4011d52a1151d Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Sat, 6 Jun 2015 19:05:25 +0200
Subject: store: Add 'verify-store' RPC.

* guix/store.scm (operation-id): Add 'verify-store'.
  (verify-store): New procedure.
  (set-build-options): Adjust comment.
* tests/store.scm ("verify-store", "verify-store + check-contents"): New
  tests.
---
 .dir-locals.el  |  2 +-
 guix/store.scm  | 21 ++++++++++++++++++---
 tests/store.scm | 54 ++++++++++++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 73 insertions(+), 4 deletions(-)

diff --git a/.dir-locals.el b/.dir-locals.el
index 7ac7e13ff1..cbcb120edf 100644
--- a/.dir-locals.el
+++ b/.dir-locals.el
@@ -46,7 +46,7 @@
    (eval . (put 'emacs-substitute-sexps 'scheme-indent-function 1))
    (eval . (put 'emacs-substitute-variables 'scheme-indent-function 1))
    (eval . (put 'with-derivation-narinfo 'scheme-indent-function 1))
-   (eval . (put 'with-derivation-substitute 'scheme-indent-function 1))
+   (eval . (put 'with-derivation-substitute 'scheme-indent-function 2))
 
    (eval . (put 'syntax-parameterize 'scheme-indent-function 1))
    (eval . (put 'with-monad 'scheme-indent-function 1))
diff --git a/guix/store.scm b/guix/store.scm
index 8905a5a558..933708defc 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -91,6 +91,7 @@
             requisites
             referrers
             optimize-store
+            verify-store
             topologically-sorted
             valid-derivers
             query-derivation-outputs
@@ -174,7 +175,8 @@
   (query-valid-paths 31)
   (query-substitutable-paths 32)
   (query-valid-derivers 33)
-  (optimize-store 34))
+  (optimize-store 34)
+  (verify-store 35))
 
 (define-enumerate-type hash-algo
   ;; hash.hh
@@ -497,8 +499,8 @@ encoding conversion errors."
 
                             ;; Client-provided substitute URLs.  For
                             ;; unprivileged clients, these are considered
-                            ;; "untrusted"; for root, they override the
-                            ;; daemon's settings.
+                            ;; "untrusted"; for "trusted" users, they override
+                            ;; the daemon's settings.
                             (substitute-urls %default-substitute-urls))
   ;; Must be called after `open-connection'.
 
@@ -769,6 +771,19 @@ Return #t on success."
   ;; Note: the daemon in Guix <= 0.8.2 does not implement this RPC.
   boolean)
 
+(define verify-store
+  (let ((verify (operation (verify-store (boolean check-contents?)
+                                         (boolean repair?))
+                           "Verify the store."
+                           boolean)))
+    (lambda* (store #:key check-contents? repair?)
+      "Verify the integrity of the store and return false if errors remain,
+and true otherwise.  When REPAIR? is true, repair any missing or altered store
+items by substituting them (this typically requires root privileges because it
+is not an atomic operation.)  When CHECK-CONTENTS? is true, check the contents
+of store items; this can take a lot of time."
+      (not (verify store check-contents? repair?)))))
+
 (define (run-gc server action to-delete min-freed)
   "Perform the garbage-collector operation ACTION, one of the
 `gc-action' values.  When ACTION is `delete-specific', the TO-DELETE is
diff --git a/tests/store.scm b/tests/store.scm
index eeceed45c1..faa924fce9 100644
--- a/tests/store.scm
+++ b/tests/store.scm
@@ -600,6 +600,60 @@
            (null? (valid-derivers %store file))
            (null? (referrers %store file))))))
 
+(test-assert "verify-store"
+  (let* ((text  (random-text))
+         (file1 (add-text-to-store %store "foo" text))
+         (file2 (add-text-to-store %store "bar" (random-text)
+                                   (list file1))))
+    (and (pk 'verify1 (verify-store %store))    ;hopefully OK ;
+         (begin
+           (delete-file file1)
+           (not (pk 'verify2 (verify-store %store)))) ;bad! ;
+         (begin
+           ;; Using 'add-text-to-store' here wouldn't work: It would succeed ;
+           ;; without actually creating the file. ;
+           (call-with-output-file file1
+             (lambda (port)
+               (display text port)))
+           (pk 'verify3 (verify-store %store)))))) ;OK again
+
+(test-assert "verify-store + check-contents"
+  ;; XXX: This test is I/O intensive.
+  (with-store s
+    (let* ((text (random-text))
+           (drv  (build-expression->derivation
+                  s "corrupt"
+                  `(let ((out (assoc-ref %outputs "out")))
+                     (call-with-output-file out
+                       (lambda (port)
+                         (display ,text port)))
+                     #t)
+                  #:guile-for-build
+                  (package-derivation s %bootstrap-guile (%current-system))))
+           (file (derivation->output-path drv)))
+      (with-derivation-substitute drv text
+        (and (build-derivations s (list drv))
+             (verify-store s #:check-contents? #t) ;should be OK
+             (begin
+               (chmod file #o644)
+               (call-with-output-file file
+                 (lambda (port)
+                   (display "corrupt!" port)))
+               #t)
+
+             ;; Make sure the corruption is detected.  We don't test repairing
+             ;; because only "trusted" users are allowed to do it, but we
+             ;; don't expose that notion of trusted users that nix-daemon
+             ;; supports because it seems dubious and redundant with what the
+             ;; OS provides (in Nix "trusted" users have additional
+             ;; privileges, such as overriding the set of substitute URLs, but
+             ;; we instead want to allow anyone to modify them, provided
+             ;; substitutes are signed by a root-approved key.)
+             (not (verify-store s #:check-contents? #t))
+
+             ;; Delete the corrupt item to leave the store in a clean state.
+             (delete-paths s (list file)))))))
+
 (test-equal "store-lower"
   "Lowered."
   (let* ((add  (store-lower text-file))
-- 
cgit v1.2.3