From 25ad6e1d8ee268bbf57a48481467a1b13a4fbbb2 Mon Sep 17 00:00:00 2001
From: Mathieu Othacehe <othacehe@gnu.org>
Date: Fri, 19 Feb 2021 19:09:18 +0100
Subject: tests: cuirass: Add an operating system argument.

Rewrite so that "run-cuirass-test" takes an operating-system argument. This is
functionally equivalent.

* gnu/tests/cuirass.scm (%derivation-file, git-service, cow-service,
%cuirass-specs): New variables.
(cuirass-services): New procedure.
(run-cuirass-test): Add an "operating-system" argument.
(%cuirass-test): Adapt it.
(%cuirass-remote-test): Ditto.
---
 gnu/tests/cuirass.scm | 242 ++++++++++++++++++++++++++------------------------
 1 file changed, 126 insertions(+), 116 deletions(-)

diff --git a/gnu/tests/cuirass.scm b/gnu/tests/cuirass.scm
index 86a06d3069..760aef8245 100644
--- a/gnu/tests/cuirass.scm
+++ b/gnu/tests/cuirass.scm
@@ -31,20 +31,89 @@
   #:use-module (gnu services databases)
   #:use-module (gnu services networking)
   #:use-module (gnu system nss)
+  #:use-module (guix channels)
   #:use-module (guix gexp)
   #:use-module (guix store)
   #:export (%cuirass-test
             %cuirass-remote-test))
 
-(define* (run-cuirass-test name #:key remote-build?)
-  (define %cuirass-specs
+(define %derivation-file
+  (scheme-file
+   "derivation.scm"
+   '(begin
+      (use-modules (guix)
+                   (srfi srfi-1)
+                   (ice-9 match))
+
+      (define (derivation->alist store drv)
+        `((#:derivation . ,(derivation-file-name drv))
+          (#:log . ,(log-file store (derivation-file-name drv)))
+          (#:outputs . ,(filter-map (lambda (res)
+                                      (match res
+                                        ((name . path)
+                                         `(,name . ,path))))
+                                    (derivation->output-paths drv)))
+          (#:nix-name . ,(derivation-name drv))
+          (#:system . ,(derivation-system drv))
+          (#:max-silent-time . 3600)
+          (#:timeout . 3600)))
+
+      (define (cuirass-jobs store arguments)
+        (let* ((file (plain-file "test" "this is a test derivation"))
+               (job-name "test-job")
+               (drv  (run-with-store store
+                       (gexp->derivation
+                        job-name
+                        #~(begin
+                            (mkdir #$output)
+                            (symlink #$file
+                                     (string-append #$output "/file")))))))
+          (list (lambda ()
+                  `((#:job-name . ,job-name)
+                    ,@(derivation->alist store drv)))))))))
+
+(define git-service
+  ;; Create a Git repository to host Cuirass' specification.
+  (simple-service
+   'create-git-directory activation-service-type
+   #~(begin
+       (let* ((git (string-append #$git "/bin/git"))
+              (main "/tmp/cuirass-main")
+              (file (string-append main "/build-aux/cuirass/gnu-system.scm")))
+         (mkdir-p (dirname file))
+         (with-directory-excursion main
+           (copy-file #$%derivation-file file)
+           (invoke git "config" "--global" "user.email"
+                   "charlie@example.org")
+           (invoke git "config" "--global" "user.name" "A U Thor")
+           (invoke git "init")
+           (invoke git "add" ".")
+           (invoke git "commit" "-m" "That's a commit."))))))
+
+(define cow-service
+  ;; The Guix-daemon & Cuirass will complain if the store is
+  ;; read-only. Create a store overlay to solve this issue.
+  (simple-service
+   'mount-cow-store activation-service-type
+   #~(begin
+       (use-modules (guix build syscalls)
+                    (guix build utils))
+       (mkdir-p "/rw-store")
+       (mount "none" "/rw-store" "tmpfs")
+
+       (mkdir-p "/rw-store/upper")
+       (mkdir-p "/rw-store/work")
+       (mount "none" "/gnu/store" "overlay" 0
+              "lowerdir=/gnu/store,upperdir=/rw-store/upper,workdir=/rw-store/work"))))
+
+(define %cuirass-specs
     #~(list
        '((#:name . "test")
          (#:load-path-inputs . ())
          (#:package-path-inputs . ())
          (#:proc-input . "main")
-         (#:proc-file . "derivation.scm")
-         (#:proc . main)
+         (#:proc-file . "build-aux/cuirass/gnu-system.scm")
+         (#:proc . cuirass-jobs)
          (#:proc-args . ())
          (#:inputs . (((#:name . "main")
                        (#:url . "file:///tmp/cuirass-main/")
@@ -54,103 +123,29 @@
          (#:build-outputs . ())
          (#:priority . 1))))
 
-  (define %derivation-file
-    (scheme-file
-     "derivation.scm"
-     '(begin
-        (use-modules (guix)
-                     (srfi srfi-1)
-                     (ice-9 match))
-
-        (define (derivation->alist store drv)
-          `((#:derivation . ,(derivation-file-name drv))
-            (#:log . ,(log-file store (derivation-file-name drv)))
-            (#:outputs . ,(filter-map (lambda (res)
-                                        (match res
-                                          ((name . path)
-                                           `(,name . ,path))))
-                                      (derivation->output-paths drv)))
-            (#:nix-name . ,(derivation-name drv))
-            (#:system . ,(derivation-system drv))
-            (#:max-silent-time . 3600)
-            (#:timeout . 3600)))
-
-        (define (main store arguments)
-          (let* ((file (plain-file "test" "this is a test derivation"))
-                 (job-name "test-job")
-                 (drv  (run-with-store store
-                         (gexp->derivation
-                          job-name
-                          #~(begin
-                              (mkdir #$output)
-                              (symlink #$file
-                                       (string-append #$output "/file")))))))
-            (list (lambda ()
-                    `((#:job-name . ,job-name)
-                      ,@(derivation->alist store drv)))))))))
-
-  (define os
-    (marionette-operating-system
-     (simple-operating-system
-      (service cuirass-service-type
-               (cuirass-configuration
-                (specifications %cuirass-specs)
-                (remote-server (and remote-build?
-                                    (cuirass-remote-server-configuration)))
-                (host "0.0.0.0")
-                (use-substitutes? #t)))
-      (service dhcp-client-service-type)
-      ;; Create a Git repository to host Cuirass' specification.
-      (simple-service
-       'create-git-directory activation-service-type
-       #~(begin
-           (let* ((git (string-append #$git "/bin/git"))
-                  (main "/tmp/cuirass-main")
-                  (file (string-append main "/derivation.scm")))
-             (mkdir-p main)
-             (with-directory-excursion main
-               (copy-file #$%derivation-file file)
-               (invoke git "config" "--global" "user.email"
-                       "charlie@example.org")
-               (invoke git "config" "--global" "user.name" "A U Thor")
-               (invoke git "init")
-               (invoke git "add" ".")
-               (invoke git "commit" "-m" "That's a commit.")))))
-      ;; The Guix-daemon & Cuirass will complain if the store is
-      ;; read-only. Create a store overlay to solve this issue.
-      (simple-service
-       'mount-cow-store activation-service-type
-       #~(begin
-           (use-modules (guix build syscalls)
-                        (guix build utils))
-           (mkdir-p "/rw-store")
-           (mount "none" "/rw-store" "tmpfs")
-
-           (mkdir-p "/rw-store/upper")
-           (mkdir-p "/rw-store/work")
-           (mount "none" "/gnu/store" "overlay" 0
-                  "lowerdir=/gnu/store,upperdir=/rw-store/upper,workdir=/rw-store/work")))
-      (service postgresql-service-type
-               (postgresql-configuration
-                (postgresql postgresql-10)))
-      (service postgresql-role-service-type))
-     #:imported-modules '((gnu services herd)
-                          (guix combinators)
-                          (guix build syscalls)
-                          (guix build utils))))
+(define* (cuirass-services #:key remote-build?)
+  (list
+   (service cuirass-service-type
+            (cuirass-configuration
+             (specifications %cuirass-specs)
+             (remote-server (and remote-build?
+                                 (cuirass-remote-server-configuration)))
+             (host "0.0.0.0")
+             (use-substitutes? #t)))
+   (service postgresql-service-type
+            (postgresql-configuration
+             (postgresql postgresql-10)))
+   (service postgresql-role-service-type)))
 
+(define (run-cuirass-test name os)
   (define os*
-    (operating-system
-      (inherit os)
-      (name-service-switch %mdns-host-lookup-nss)
-      (services
-       (append (if remote-build?
-                   (list
-                    (service avahi-service-type)
-                    (service cuirass-remote-worker-service-type
-                             (cuirass-remote-worker-configuration)))
-                   '())
-               (operating-system-user-services os)))))
+    (let ((modules '((gnu services herd)
+                     (guix combinators)
+                     (guix build syscalls)
+                     (guix build utils))))
+      (marionette-operating-system
+       os
+       #:imported-modules modules)))
 
   (define cuirass-web-port 8081)
   (define forward-port 5000)
@@ -219,8 +214,7 @@
                  #:times 5
                  #:delay 5)))
 
-            (test-equal "cuirass-web evaluation"
-              "test"
+            (test-assert "cuirass-web evaluation"
               (begin
                 (retry
                  (lambda ()
@@ -230,8 +224,9 @@
                             (false-if-exception
                              (json-string->scm
                               (utf8->string text)))))
-                       (and result
-                            (assoc-ref result "specification")))))
+                       (eq? (and result
+                                 (assoc-ref result "id"))
+                            1))))
                  #:times 5
                  #:delay 5)))
 
@@ -249,11 +244,7 @@
                              (utf8->string text))))
                        (match (vector->list result)
                          ((build)
-                          (and (string=? (assoc-ref build "job")
-                                         "test-job")
-                               (or (not #$remote-build?)
-                                   ;; Check if the build is started.
-                                   (= (assoc-ref build "buildstatus") -1))))
+                          (string=? (assoc-ref build "job") "test-job"))
                          (else #f)))))
                  #:times 5
                  #:delay 10)))
@@ -264,13 +255,32 @@
   (gexp->derivation name test))
 
 (define %cuirass-test
-  (system-test
-   (name "cuirass")
-   (description "Connect to a Cuirass server.")
-   (value (run-cuirass-test name))))
+  (let ((os (operating-system
+              (inherit %simple-os)
+              (services
+               (append (list cow-service
+                             (service dhcp-client-service-type)
+                             git-service)
+                       (cuirass-services)
+                       (operating-system-user-services %simple-os))))))
+    (system-test
+     (name "cuirass")
+     (description "Connect to a Cuirass server.")
+     (value
+      (run-cuirass-test name os)))))
 
 (define %cuirass-remote-test
-  (system-test
-   (name "cuirass-remote")
-   (description "Connect to a Cuirass server with remote build.")
-   (value (run-cuirass-test name #:remote-build? #t))))
+  (let ((os (operating-system
+              (inherit %simple-os)
+              (name-service-switch %mdns-host-lookup-nss)
+              (services
+               (append (list (service avahi-service-type)
+                             cow-service
+                             (service dhcp-client-service-type)
+                             git-service)
+                       (cuirass-services #:remote-build? #t)
+                       (operating-system-user-services %simple-os))))))
+    (system-test
+     (name "cuirass-remote")
+     (description "Connect to a Cuirass server with remote build.")
+     (value (run-cuirass-test name os)))))
-- 
cgit v1.2.3