diff options
| -rw-r--r-- | .dir-locals.el | 1 | ||||
| -rw-r--r-- | guix/tests/git.scm | 67 | ||||
| -rw-r--r-- | tests/builders.scm | 8 | ||||
| -rw-r--r-- | 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" |