From e6740741d188e01cb1a0b9c7db597a25128889d5 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Wed, 29 Oct 2014 00:09:38 +0100
Subject: tests: Move some of the narinfo test tools to (guix tests).

* guix/tests.scm (derivation-narinfo, call-with-derivation-narinfo): New
  procedures.
  (with-derivation-narinfo): New macro.
* tests/derivations.scm ("derivation-prerequisites-to-build and
  substitutes"): Use them.
---
 guix/tests.scm | 59 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 58 insertions(+), 1 deletion(-)

(limited to 'guix')

diff --git a/guix/tests.scm b/guix/tests.scm
index 4f7b0c8171..022679902a 100644
--- a/guix/tests.scm
+++ b/guix/tests.scm
@@ -23,9 +23,11 @@ (define-module (guix tests)
   #:use-module (gnu packages bootstrap)
   #:use-module (srfi srfi-34)
   #:use-module (rnrs bytevectors)
+  #:use-module (web uri)
   #:export (open-connection-for-tests
             random-text
-            random-bytevector))
+            random-bytevector
+            with-derivation-narinfo))
 
 ;;; Commentary:
 ;;;
@@ -67,4 +69,59 @@ (define (random-bytevector n)
             (loop (1+ i)))
           bv))))
 
+
+;;;
+;;; Narinfo files, as used by the substituter.
+;;;
+
+(define* (derivation-narinfo drv #:optional (nar "example.nar"))
+  "Return the contents of the narinfo corresponding to DRV; NAR should be the
+file name of the archive containing the substitute for DRV."
+  (format #f "StorePath: ~a
+URL: ~a
+Compression: none
+NarSize: 1234
+References: 
+System: ~a
+Deriver: ~a~%"
+          (derivation->output-path drv)       ; StorePath
+          nar                                 ; URL
+          (derivation-system drv)             ; System
+          (basename
+           (derivation-file-name drv))))      ; Deriver
+
+(define (call-with-derivation-narinfo drv thunk)
+  "Call THUNK in a context where fake substituter data, as read by 'guix
+substitute-binary', has been installed for DRV."
+  (let* ((output  (derivation->output-path drv))
+         (dir     (uri-path
+                   (string->uri (getenv "GUIX_BINARY_SUBSTITUTE_URL"))))
+         (info    (string-append dir "/nix-cache-info"))
+         (narinfo (string-append dir "/" (store-path-hash-part output)
+                                 ".narinfo")))
+    (dynamic-wind
+      (lambda ()
+        (call-with-output-file info
+          (lambda (p)
+            (format p "StoreDir: ~a\nWantMassQuery: 0\n"
+                    (%store-prefix))))
+        (call-with-output-file narinfo
+          (lambda (p)
+            (display (derivation-narinfo drv) p))))
+      thunk
+      (lambda ()
+        (delete-file narinfo)
+        (delete-file info)))))
+
+(define-syntax-rule (with-derivation-narinfo drv body ...)
+  "Evaluate BODY in a context where DRV looks substitutable from the
+substituter's viewpoint."
+  (call-with-derivation-narinfo drv
+    (lambda ()
+      body ...)))
+
+;; Local Variables:
+;; eval: (put 'call-with-derivation-narinfo 'scheme-indent-function 1)
+;; End:
+
 ;;; tests.scm ends here
-- 
cgit v1.2.3