Bugfix: with-directory-excursion fails attempting to restore dir

The `with-directory-excursion' macro changes to the specified directory on
entry, runs the code it was provided in that directory then on completion, it
changes back to the directory the original code that called it was in.

Herein lies the problem, the change in directories (entry and exit) only work
if the directory permissions allow. In our case, the `gn-auth-test-flask' gexp
is to be called with `sudo -u genenetwork ...'. This means that while it will
successfully enter into the directories owned by the "genenetwork" user, it
will fail when attempting to exit back into the
"/tmp/gn-integration-tests.XXXXXX" temporary directories (#o700) owned by the
"laminar" user.

This commit changes the git command, providing it the "-C" path to the
repository, thereby circumventing the need to enter and exit directories that
might cross "permission" boundaries.

The commit also removes the duplicated logging within the
`gn-integration-tests-gexp' gexp. Instead, we show the commits within the
`gn-auth-test-flask' gexp that's run under the "genenetwork" user (sudo -u
genenetwork ...) and therefore has the appropriate permissions to access the
checkout directories.

1 files changed, 75 insertions, 77 deletions

diff --git a/genenetwork-development.scm b/genenetwork-development.scm
index 413afdb..9e5e242 100644
--- a/genenetwork-development.scm
+++ b/genenetwork-development.scm
@@ -1593,30 +1593,38 @@ delete-test-users, etc.) as the genenetwork user via sudo."
                           "SSL_PRIVATE_KEY=\"" gn-auth-secrets
                           "/gn-auth-ssl-private-key.pem\"\n"))
            (gn-libs-checkout (string-append repositories-checkout-directory "/gn-libs"))
-           (gn-auth-checkout (string-append repositories-checkout-directory "/gn-auth")))
+           (gn-auth-checkout (string-append repositories-checkout-directory "/gn-auth"))
+           (gn-guile-checkout (string-append repositories-checkout-directory "/gn-guile"))
+           (gn3-checkout (string-append repositories-checkout-directory "/genenetwork3"))
+           (gn2-checkout (string-append repositories-checkout-directory "/genenetwork2")))
       (program-file
        "gn-auth-test-flask"
        (with-imported-modules '((guix build utils))
          #~(begin
              (use-modules (guix build utils))
 
-             (define (hline)
-               "Print a horizontal line 50 '=' characters long."
-               (display (make-string 50 #\=))
+             (define* (hline #:optional (char #\=))
+               "Print a horizontal line 50 `char' characters long."
+               (display (make-string 50 char))
                (newline)
                (force-output))
 
-             (define (show-head-commit)
-               (hline)
-               (invoke #$(file-append git-minimal "/bin/git")
-                       "log" "--max-count" "1")
-               (hline))
-             (with-directory-excursion #$gn-libs-checkout
-               (show-head-commit))
-             (with-directory-excursion #$gn-auth-checkout
-               (show-head-commit))
-
-             (setenv "PYTHONPATH"
+              (define* (show-head-commit #:optional (path #f))
+                (hline)
+                (display (basename (or path (getcwd)))) (newline)
+                (hline #\-)
+                (invoke #$(file-append git-minimal "/bin/git")
+                        "-C" (or path (getcwd))
+                        "--no-pager" "log" "--max-count" "1")
+                (hline))
+
+              (show-head-commit #$gn-libs-checkout)
+              (show-head-commit #$gn-auth-checkout)
+              (show-head-commit #$gn-guile-checkout)
+              (show-head-commit #$gn3-checkout)
+              (show-head-commit #$gn2-checkout)
+
+              (setenv "PYTHONPATH"
                      (string-append #$gn-libs-checkout ":"
                                     #$gn-auth-checkout ":"
                                     #$gn-auth-profile
@@ -1675,75 +1683,65 @@ delete-test-users, etc.) as the genenetwork user via sudo."
                                (setup '())
                                (teardown '()))
   (match-record config <genenetwork-configuration>
-    (gn-integration-tests-repository repositories-checkout-directory)
-    (let ((gn-libs-checkout (string-append repositories-checkout-directory "/gn-libs"))
-          (gn-auth-checkout (string-append repositories-checkout-directory "/gn-auth"))
-          (gn3-checkout (string-append repositories-checkout-directory "/genenetwork3"))
-          (gn2-checkout (string-append repositories-checkout-directory "/genenetwork2"))
-          (gn-guile-checkout (string-append repositories-checkout-directory "/gn-guile")))
-      (with-imported-modules '((guix build utils))
-        (with-packages (list nss-certs git-minimal)
-          #~(begin
-              (use-modules (guix build utils))
+    (gn-integration-tests-repository)
+    (with-imported-modules '((guix build utils))
+      (with-packages (list nss-certs git-minimal)
+        #~(begin
+            (use-modules (guix build utils))
 
-              (define (hline)
-                "Print a horizontal line 50 '=' characters long."
-                (display (make-string 50 #\=))
-                (newline)
-                (force-output))
+             (define* (hline #:optional (char #\=))
+               "Print a horizontal line 50 `char' characters long."
+               (display (make-string 50 char))
+               (newline)
+               (force-output))
 
-              (define (show-head-commit)
+              (define* (show-head-commit #:optional (path #f))
                 (hline)
+                (display (basename (or path (getcwd)))) (newline)
+                (hline #\-)
                 (invoke #$(file-append git-minimal "/bin/git")
+                        "-C" (or path (getcwd))
                         "--no-pager" "log" "--max-count" "1")
                 (hline))
 
-
-              ;; laminar user cannot `cd' into some (or all) of these directories
-              ;; (with-directory-excursion #$gn-libs-checkout (show-head-commit))
-              ;; (with-directory-excursion #$gn-auth-checkout (show-head-commit))
-              ;; (with-directory-excursion #$gn-guile-checkout (show-head-commit))
-              ;; (with-directory-excursion #$gn3-checkout (show-head-commit))
-              ;; (with-directory-excursion #$gn2-checkout (show-head-commit))
-
-              (let* ((orig-dir (getcwd))
-                     (tmp-dir (mkdtemp "/tmp/gn-integration-tests.XXXXXX"))
-                     (tests-profile #$(profile
-                                    (content (package->development-manifest gn-integration-tests))
-                                    (allow-collisions? #t)))
-                     (py-version
-                      #$(version-major+minor (package-version python)))
-                     (site-packages
-                      (string-append tests-profile "/lib/python"
-                                     py-version "/site-packages")))
-                (chdir tmp-dir)
-                (invoke #$(file-append git-minimal "/bin/git")
-                        "clone" "--depth" "1" #$gn-integration-tests-repository)
-                (with-directory-excursion "gn-integration-tests"
-                  (show-head-commit))
-                (chdir "gn-integration-tests")
-
-                (setenv "GN_INTEGRATION_TESTS_PROFILE" tests-profile)
-                (setenv "PATH" (string-append tests-profile "/bin:"
-                                              (getenv "PATH")))
-                (if (getenv "PYTHONPATH")
-                    (setenv
-                     "PYTHONPATH"
-                     (string-append site-packages ":" (getenv "PYTHONPATH")))
-                    (setenv "PYTHONPATH" site-packages))
-                (dynamic-wind
-                  (lambda () ;; Run setup if provided
-                    #$(if (null? setup)
-                          #~(if #f #f)
-                          #~(begin #$@setup)))
-                  (lambda () (apply invoke '#$test-command)) ;; Run actual tests
-                  (lambda () ;; Always run teardowns to clean up.
-                    (begin ;; run if teardowns provided
-                      ;; we don't need `null?' check here because we have other
-                      ;; statements therefore the `lambda' does not end up empty.
-                      #$@teardown)
-                    (chdir orig-dir)
-                    (delete-file-recursively tmp-dir))))))))))
+            (let* ((orig-dir (getcwd))
+                   (tmp-dir (mkdtemp "/tmp/gn-integration-tests.XXXXXX"))
+                   (tests-profile #$(profile
+                                      (content (package->development-manifest gn-integration-tests))
+                                      (allow-collisions? #t)))
+                   (py-version
+                    #$(version-major+minor (package-version python)))
+                   (site-packages
+                    (string-append tests-profile "/lib/python"
+                                   py-version "/site-packages")))
+              (chdir tmp-dir)
+              (invoke #$(file-append git-minimal "/bin/git")
+                      "clone" "--depth" "1" #$gn-integration-tests-repository)
+              (with-directory-excursion "gn-integration-tests"
+                (show-head-commit))
+              (chdir "gn-integration-tests")
+
+              (setenv "GN_INTEGRATION_TESTS_PROFILE" tests-profile)
+              (setenv "PATH" (string-append tests-profile "/bin:"
+                                            (getenv "PATH")))
+              (if (getenv "PYTHONPATH")
+                  (setenv
+                   "PYTHONPATH"
+                   (string-append site-packages ":" (getenv "PYTHONPATH")))
+                  (setenv "PYTHONPATH" site-packages))
+              (dynamic-wind
+                (lambda () ;; Run setup if provided
+                  #$(if (null? setup)
+                        #~(if #f #f)
+                        #~(begin #$@setup)))
+                (lambda () (apply invoke '#$test-command)) ;; Run actual tests
+                (lambda () ;; Always run teardowns to clean up.
+                  (begin ;; run if teardowns provided
+                    ;; we don't need `null?' check here because we have other
+                    ;; statements therefore the `lambda' does not end up empty.
+                    #$@teardown)
+                  (chdir orig-dir)
+                  (delete-file-recursively tmp-dir)))))))))
 
 (define (override-fcgiwrap-extension cgit-service)
   (service