mirror of
https://codeberg.org/guix/guix.git
synced 2026-01-25 03:55:08 -06:00
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>
This commit is contained in:
Reepca Russelstein
Ludovic Courtès
parent
b39f914b3e
commit
55a10ce4e6
4 changed files with 107 additions and 24 deletions
|
|
@ -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))
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ...)))
|
||||
|
|
|
|||
|
|
@ -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")))
|
||||
|
|
|
|||
|
|
@ -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,10 +387,15 @@
|
|||
#f))))
|
||||
|
||||
(test-assert "'git-download' built-in builder, not found"
|
||||
(with-served-temporary-git-repository directory port
|
||||
'()
|
||||
(let* ((drv (derivation %store "git-download"
|
||||
"builtin:git-download" '()
|
||||
#:env-vars
|
||||
`(("url" . "file:///does-not-exist.git")
|
||||
`(("url" . ,(object->string
|
||||
(string-append "git://localhost:"
|
||||
(number->string port)
|
||||
"/nonexistent")))
|
||||
("commit"
|
||||
. "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"))
|
||||
#:hash-algo 'sha256
|
||||
|
|
@ -391,7 +404,7 @@
|
|||
(guard (c ((store-protocol-error? c)
|
||||
(string-contains (store-protocol-error-message c) "failed")))
|
||||
(build-derivations %store (list drv))
|
||||
#f)))
|
||||
#f))))
|
||||
|
||||
(test-equal "derivation-name"
|
||||
"foo-0.0"
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue