tests: don't use 'file://...' URIs for testing git downloads.

While 'url-fetch*' in (guix download) special-cases these URIs, 'git-fetch'
does not.  Consequently, the recent changes to (guix scripts perform-download)
that disallow these URIs cause tests that use builtin:git-download to fail.

* guix/tests/git.scm (serve-git-repository, call-with-served-git-repository):
  new procedures.
  (with-served-git-repository, with-served-temporary-git-repository): new
  syntax.
* .dir-locals.el (scheme-mode): add indentation information for
  'with-served-git-repository'.
* tests/builders.scm ("git-fetch, file URI"): use git:// URI with
  'with-served-temporary-git-repository'.
* tests/derivations.scm ("'git-download' build-in builder, invalid hash",
  "'git-download' built-in builder, invalid commit", "'git-download' built-in
  builder, not found"): same.
  ("'git-download' built-in builder"): same, and use a nonce in the repo
  contents so that success isn't cached.

Change-Id: Id3e1233bb74d5987faf89c4341e1d37f09c77c80
Signed-off-by: Ludovic Courtès <ludo@gnu.org>

.dir-locals.el

@@ -202,6 +202,7 @@
    (eval . (put 'call-with-progress-reporter 'scheme-indent-function 1))
    (eval . (put 'with-repository 'scheme-indent-function 2))
    (eval . (put 'with-temporary-git-repository 'scheme-indent-function 2))
+   (eval . (put 'with-served-git-repository 'scheme-indent-function 2))
    (eval . (put 'with-environment-variables 'scheme-indent-function 1))
    (eval . (put 'with-fresh-gnupg-setup 'scheme-indent-function 1))
 

guix/tests/git.scm

@@ -27,6 +27,9 @@
   #:export (git-command
             with-temporary-git-repository
             with-git-repository
+            serve-git-repository
+            with-served-git-repository
+            with-served-temporary-git-repository
             find-commit))
 
 (define git-command
@@ -151,3 +154,67 @@ per DIRECTIVES."
                   #f
                   repository)
     (error "commit not found" message)))
+
+(define* (serve-git-repository directory #:optional port)
+  "Run \"git daemon\" to serve the bare git repository at DIRECTORY as the
+root resource on PORT on the loopback interface.  If PORT isn't provided or is
+#f, select an arbitrary unused port instead.
+
+Return two values: the PID of the newly-spawned process and the port it is
+listening on."
+  (let ((port (or port
+                  ;; XXX: race between when it's closed and 'git daemon' binds
+                  ;; the same port.
+                  (call-with-port (socket AF_INET SOCK_STREAM 0)
+                    (lambda (sock)
+                      (bind sock AF_INET INADDR_LOOPBACK 0)
+                      (sockaddr:port (getsockname sock)))))))
+    (values
+     (spawn (git-command)
+            (list (basename (git-command))
+                  "daemon"
+                  (string-append "--base-path=" directory)
+                  "--listen=127.0.0.1"
+                  "--listen=::1"
+                  (string-append "--port=" (number->string port))
+                  "--export-all" ;; don't require git-daemon-export-ok file
+                  "--strict-paths"
+                  "--"
+                  ;; with --strict-paths this limits requests to exactly this
+                  ;; directory.  The client can't fetch an empty string,
+                  ;; though (has to be at least "/"), so add a trailing slash.
+                  (if (string-suffix? "/" directory)
+                      directory
+                      (string-append directory "/"))))
+     port)))
+
+(define* (call-with-served-git-repository directory proc #:key port)
+  "Serve DIRECTORY as the root resource \"/\" on the loopback interface during
+the dynamic extent of a single invocation of PROC.  PROC is called with a
+single integer argument indicating which port of the loopback interface \"git
+daemon\" is listening on.  If PORT is specified, that port will be used,
+otherwise a random unused port will be chosen."
+  (call-with-values (lambda ()
+                      (serve-git-repository directory port))
+    (lambda (pid port)
+      (dynamic-wind
+        (const #t)
+        (lambda ()
+          (proc port))
+        (lambda ()
+          (kill pid SIGTERM)
+          (waitpid pid))))))
+
+(define-syntax-rule (with-served-git-repository directory port exp ...)
+  "Evaluate EXP in a context where the identifier PORT is bound to a port
+number on which \"git daemon\" is serving DIRECTORY as the root resource
+\"/\"."
+  (call-with-served-git-repository directory
+                                   (lambda (port)
+                                     exp ...)))
+
+(define-syntax-rule (with-served-temporary-git-repository directory port
+                                                          directives exp ...)
+  (with-temporary-git-repository directory directives
+    (with-served-git-repository (string-append directory "/.git") port
+      exp ...)))

tests/builders.scm

@@ -88,10 +88,10 @@
     (and (file-exists? out)
          (valid-path? %store out))))
 
-(test-equal "git-fetch, file URI"
+(test-equal "git-fetch, local URI"
   '("." ".." "a.txt" "b.scm")
   (let ((nonce (random-text)))
-    (with-temporary-git-repository directory
+    (with-served-temporary-git-repository directory port
         `((add "a.txt" ,nonce)
           (add "b.scm" "#t")
           (commit "Commit.")
@@ -103,7 +103,9 @@
                                              #:recursive? #t))
                              (drv (git-fetch
                                    (git-reference
-                                    (url (string-append "file://" directory))
+                                    (url (string-append "git://localhost:"
+                                                        (number->string port)
+                                                        "/"))
                                     (commit "v1.0.0"))
                                    'sha256 hash
                                    "git-fetch-test")))

tests/derivations.scm

@@ -306,12 +306,14 @@
                          get-string-all)
                        text))))))
 
+(define %nonce (random-text))
+
 (test-equal "'git-download' built-in builder"
-  `(("/a.txt" . "AAA")
+  `(("/a.txt" . ,%nonce)
     ("/b.scm" . "#t"))
   (let ((nonce (random-text)))
-    (with-temporary-git-repository directory
+    (with-served-temporary-git-repository directory port
-        `((add "a.txt" "AAA")
+        `((add "a.txt" ,%nonce)
           (add "b.scm" "#t")
           (commit ,nonce))
       (let* ((commit (with-repository directory repository
@@ -322,7 +324,9 @@
                               #:env-vars
                               `(("url"
                                  . ,(object->string
-                                     (string-append "file://" directory)))
+                                     (string-append "git://localhost:"
+                                                    (number->string port)
+                                                    "/")))
                                 ("commit" . ,commit))
                               #:hash-algo 'sha256
                               #:hash (file-hash* directory
@@ -335,7 +339,7 @@
         (directory-contents (derivation->output-path drv) get-string-all)))))
 
 (test-assert "'git-download' built-in builder, invalid hash"
-  (with-temporary-git-repository directory
+  (with-served-temporary-git-repository directory port
       `((add "a.txt" "AAA")
         (add "b.scm" "#t")
         (commit "Commit!"))
@@ -347,7 +351,9 @@
                             #:env-vars
                             `(("url"
                                . ,(object->string
-                                   (string-append "file://" directory)))
+                                   (string-append "git://localhost:"
+                                                  (number->string port)
+                                                  "/")))
                               ("commit" . ,commit))
                             #:hash-algo 'sha256
                             #:hash (gcrypt:sha256 #vu8())
@@ -358,7 +364,7 @@
         #f))))
 
 (test-assert "'git-download' built-in builder, invalid commit"
-  (with-temporary-git-repository directory
+  (with-served-temporary-git-repository directory port
       `((add "a.txt" "AAA")
         (add "b.scm" "#t")
         (commit "Commit!"))
@@ -367,7 +373,9 @@
                             #:env-vars
                             `(("url"
                                . ,(object->string
-                                   (string-append "file://" directory)))
+                                   (string-append "git://localhost:"
+                                                  (number->string port)
+                                                  "/")))
                               ("commit"
                                . "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"))
                             #:hash-algo 'sha256
@@ -379,19 +387,24 @@
         #f))))
 
 (test-assert "'git-download' built-in builder, not found"
-  (let* ((drv (derivation %store "git-download"
+  (with-served-temporary-git-repository directory port
-                          "builtin:git-download" '()
+    '()
-                          #:env-vars
+    (let* ((drv (derivation %store "git-download"
-                          `(("url" . "file:///does-not-exist.git")
+                            "builtin:git-download" '()
-                            ("commit"
+                            #:env-vars
-                             . "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"))
+                            `(("url" . ,(object->string
-                          #:hash-algo 'sha256
+                                         (string-append "git://localhost:"
-                          #:hash (gcrypt:sha256 #vu8())
+                                                        (number->string port)
-                          #:recursive? #t)))
+                                                        "/nonexistent")))
-    (guard (c ((store-protocol-error? c)
+                              ("commit"
-               (string-contains (store-protocol-error-message c) "failed")))
+                               . "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"))
-      (build-derivations %store (list drv))
+                            #:hash-algo 'sha256
-      #f)))
+                            #:hash (gcrypt:sha256 #vu8())
+                            #:recursive? #t)))
+      (guard (c ((store-protocol-error? c)
+                 (string-contains (store-protocol-error-message c) "failed")))
+        (build-derivations %store (list drv))
+        #f))))
 
 (test-equal "derivation-name"
   "foo-0.0"