guix_mirror_bot pushed a commit to branch master
in repository guix.
commit 55a10ce4e618d334ccc5df71bf94483d7c9966ed
Author: Reepca Russelstein <[email protected]>
AuthorDate: Tue Sep 16 22:08:19 2025 -0500
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 <[email protected]>
---
.dir-locals.el | 1 +
guix/tests/git.scm | 67 +++++++++++++++++++++++++++++++++++++++++++++++++++
tests/builders.scm | 8 +++---
tests/derivations.scm | 55 ++++++++++++++++++++++++++----------------
4 files changed, 107 insertions(+), 24 deletions(-)
diff --git a/.dir-locals.el b/.dir-locals.el
index 022a338217..4bd0d97cb3 100644
--- a/.dir-locals.el
+++ b/.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))
diff --git a/guix/tests/git.scm b/guix/tests/git.scm
index d51e49e514..a649c1fa6e 100644
--- a/guix/tests/git.scm
+++ b/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 ...)))
diff --git a/tests/builders.scm b/tests/builders.scm
index 0ed295a93f..44add1d13e 100644
--- a/tests/builders.scm
+++ b/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")))
diff --git a/tests/derivations.scm b/tests/derivations.scm
index 077aee0909..d4cca0f605 100644
--- a/tests/derivations.scm
+++ b/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
- `((add "a.txt" "AAA")
+ (with-served-temporary-git-repository directory port
+ `((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"
- "builtin:git-download" '()
- #:env-vars
- `(("url" . "file:///does-not-exist.git")
- ("commit"
- . "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"))
- #:hash-algo 'sha256
- #: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)))
+ (with-served-temporary-git-repository directory port
+ '()
+ (let* ((drv (derivation %store "git-download"
+ "builtin:git-download" '()
+ #:env-vars
+ `(("url" . ,(object->string
+ (string-append "git://localhost:"
+ (number->string port)
+ "/nonexistent")))
+ ("commit"
+ . "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"))
+ #:hash-algo 'sha256
+ #: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"
