1 files changed, 34 insertions, 0 deletions
diff --git a/guix/tests.scm b/guix/tests.scm
index bcf9b990e5..f4948148c4 100644
--- a/guix/tests.scm
+++ b/guix/tests.scm
@@ -27,6 +27,7 @@
   #:use-module (guix build-system gnu)
   #:use-module (gnu packages bootstrap)
   #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-64)
   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 binary-ports)
   #:use-module (web uri)
@@ -35,10 +36,13 @@
             random-text
             random-bytevector
             file=?
+            canonical-file?
             network-reachable?
             shebang-too-long?
             mock
             %test-substitute-urls
+            test-assertm
+            test-equalm
             %substitute-directory
             with-derivation-narinfo
             with-derivation-substitute
@@ -147,6 +151,14 @@ too expensive to build entirely in the test store."
          (else
           (error "what?" (lstat a))))))
 
+(define (canonical-file? file)
+  "Return #t if FILE is in the store, is read-only, and its mtime is 1."
+  (let ((st (lstat file)))
+    (or (not (string-prefix? (%store-prefix) file))
+        (eq? 'symlink (stat:type st))
+        (and (= 1 (stat:mtime st))
+             (zero? (logand #o222 (stat:mode st)))))))
+
 (define (network-reachable?)
   "Return true if we can reach the Internet."
   (false-if-exception (getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV)))
@@ -161,6 +173,28 @@ given by REPLACEMENT."
       (lambda () body ...)
       (lambda () (module-set! m 'proc original)))))
 
+(define-syntax-rule (test-assertm name exp)
+  "Like 'test-assert', but EXP is a monadic value.  A new connection to the
+store is opened."
+  (test-assert name
+    (let ((store (open-connection-for-tests)))
+      (dynamic-wind
+        (const #t)
+        (lambda ()
+          (run-with-store store exp
+                          #:guile-for-build (%guile-for-build)))
+        (lambda ()
+          (close-connection store))))))
+
+(define-syntax-rule (test-equalm name value exp)
+  "Like 'test-equal', but EXP is a monadic value.  A new connection to the
+store is opened."
+  (test-equal name
+    value
+    (with-store store
+      (run-with-store store exp
+                      #:guile-for-build (%guile-for-build)))))
+
 
 ;;;
 ;;; Narinfo files, as used by the substituter.