#72997 [PATCH Cuirass] cuirass: Use Gitlab project name to derive spec.

Message #5 received at submit@debbugs.gnu.org (full text, mbox, reply):

From: Romain GARBAGE <romain.garbage@inria.fr>

To: guix-patches@gnu.org

Cc: ludovic.courtes@inria.fr, Romain GARBAGE <romain.garbage@inria.fr>

Subject: [PATCH Cuirass] cuirass: Use Gitlab project name to derive spec.

Date: Tue, 3 Sep 2024 10:44:27 +0200

* src/cuirass/gitlab.scm (gitlab-project): New record type.
(gitlab-event): New field PROJECT.
(gitlab-merge-request->specification): New project argument.
* src/cuirass/http.scm (url-hanlder): Update Gitlab API.
* tests/gitlab.scm: Fix tests.
* tests/http.scm: Fix tests.
---
 src/cuirass/gitlab.scm | 25 ++++++++++----
 src/cuirass/http.scm   |  3 +-
 tests/gitlab.scm       | 74 +++++++++++++++++++++++++++---------------
 tests/http.scm         | 13 ++++++--
 4 files changed, 78 insertions(+), 37 deletions(-)

diff --git a/src/cuirass/gitlab.scm b/src/cuirass/gitlab.scm
index 4da9e82..fcb93bb 100644
--- a/src/cuirass/gitlab.scm
+++ b/src/cuirass/gitlab.scm
@@ -23,9 +23,14 @@
   #:use-module (ice-9 match)
   #:export (gitlab-event
             gitlab-event-type
+            gitlab-event-project
             gitlab-event-value
             json->gitlab-event
 
+            gitlab-project
+            gitlab-project-name
+            json->gitlab-project
+
             gitlab-merge-request
             gitlab-merge-request-action
             gitlab-merge-request-project-name
@@ -48,6 +53,13 @@
   (name     gitlab-source-name "name"
             string->symbol))
 
+(define-json-mapping <gitlab-project>
+  make-gitlab-project
+  gitlab-project?
+  json->gitlab-project
+  (name    gitlab-project-name "name"
+           string->symbol))
+
 ;; This mapping defines a specific JSON dictionary used for tweaking Cuirass
 ;; options. It is not included in the JSON data sent by default by Gitlab and
 ;; must be used through the custom template mechanism (see documentation).
@@ -111,6 +123,8 @@
                                #\-
                                c))
                          v))))
+  (project  gitlab-event-project "project"
+            json->gitlab-project)
   (value gitlab-event-value "object_attributes"
          (lambda (v)
            ;; FIXME: properly handle cases using field TYPE defined above.
@@ -120,10 +134,9 @@
              (json->gitlab-merge-request v))
             (#t #f)))))
 
-(define (gitlab-merge-request->specification merge-request)
+(define (gitlab-merge-request->specification merge-request project)
   "Returns a SPECIFICATION built out of a GITLAB-MERGE-REQUEST."
-  (let* ((source-name (gitlab-source-name
-                       (gitlab-merge-request-source merge-request)))
+  (let* ((project-name (gitlab-project-name project))
          (source-branch (gitlab-merge-request-source-branch merge-request))
          (source-url (gitlab-source-repo-url
                       (gitlab-merge-request-source merge-request)))
@@ -135,13 +148,13 @@
                           'gitlab-merge-requests))
          (spec-name (string->symbol
                      (format #f "~a-~a-~a-~a" name-prefix
-                                              source-name
+                                              project-name
                                               source-branch
                                               id)))
          (build (if (and cuirass-options
                          (jobset-options-build cuirass-options))
                     (jobset-options-build cuirass-options)
-                    `(channels ,source-name)))
+                    `(channels ,project-name)))
          (period (if (and cuirass-options
                           (jobset-options-period cuirass-options))
                      (jobset-options-period cuirass-options)
@@ -159,7 +172,7 @@
      (build build)
      (channels
       (cons* (channel
-              (name source-name)
+              (name project-name)
               (url source-url)
               (branch source-branch))
              %default-channels))
diff --git a/src/cuirass/http.scm b/src/cuirass/http.scm
index 27cf18f..0ac22df 100644
--- a/src/cuirass/http.scm
+++ b/src/cuirass/http.scm
@@ -723,7 +723,8 @@ return DEFAULT."
            (match (gitlab-event-type event)
              ('merge-request
               (let* ((merge-request (gitlab-event-value event))
-                     (spec (gitlab-merge-request->specification merge-request)))
+                     (project (gitlab-event-project event))
+                     (spec (gitlab-merge-request->specification merge-request project)))
                 (match (gitlab-merge-request-action merge-request)
                   ;; New merge request.
                   ((or "open" "reopen")
diff --git a/tests/gitlab.scm b/tests/gitlab.scm
index b670138..ca6cad5 100644
--- a/tests/gitlab.scm
+++ b/tests/gitlab.scm
@@ -36,6 +36,9 @@
 (define default-mr-json
   "{
     \"event_type\": \"merge_request\",
+    \"project\": {
+        \"name\": \"project-name\"
+    },
     \"object_attributes\": {
         \"action\": \"open\",
         \"merge_status\": \"can_be_merged\",
@@ -51,6 +54,9 @@
 (define custom-mr-json
   "{
     \"event_type\": \"merge_request\",
+    \"project\": {
+        \"name\": \"project-name\"
+    },
     \"object_attributes\": {
         \"action\": \"open\",
         \"merge_status\": \"can_be_merged\",
@@ -79,6 +85,9 @@
 (define custom-mr-json-multiple-packages
  "{
     \"event_type\": \"merge_request\",
+    \"project\": {
+        \"name\": \"project-name\"
+    },
     \"object_attributes\": {
         \"action\": \"open\",
         \"merge_status\": \"can_be_merged\",
@@ -103,6 +112,9 @@
 (define custom-mr-json-name-prefix
   "{
     \"event_type\": \"merge_request\",
+    \"project\": {
+        \"name\": \"project-name\"
+    },
     \"object_attributes\": {
         \"action\": \"open\",
         \"merge_status\": \"can_be_merged\",
@@ -121,6 +133,9 @@
 (define custom-mr-json-build-all
   "{
     \"event_type\": \"merge_request\",
+    \"project\": {
+        \"name\": \"project-name\"
+    },
     \"object_attributes\": {
         \"action\": \"open\",
         \"merge_status\": \"can_be_merged\",
@@ -168,15 +183,16 @@
 
 (test-assert "default-json"
   (specifications-equal?
-   (gitlab-merge-request->specification
-    (gitlab-event-value
-     (json->gitlab-event default-mr-json)))
+   (let ((event (json->gitlab-event default-mr-json)))
+     (gitlab-merge-request->specification
+      (gitlab-event-value event)
+      (gitlab-event-project event)))
    (specification
-    (name 'gitlab-merge-requests-test-project-test-branch-1)
-    (build '(channels . (test-project)))
+    (name 'gitlab-merge-requests-project-name-test-branch-1)
+    (build '(channels . (project-name)))
     (channels
      (cons* (channel
-             (name 'test-project)
+             (name 'project-name)
              (url "https://gitlab.instance.test/source-repo/fork-name.git")
              (branch "test-branch"))
             %default-channels))
@@ -186,15 +202,16 @@
 
 (test-assert "custom-json"
   (specifications-equal?
-   (gitlab-merge-request->specification
-    (gitlab-event-value
-     (json->gitlab-event custom-mr-json)))
+   (let ((event (json->gitlab-event custom-mr-json)))
+     (gitlab-merge-request->specification
+      (gitlab-event-value event)
+      (gitlab-event-project event)))
    (specification
-    (name 'gitlab-merge-requests-test-project-test-branch-2)
+    (name 'gitlab-merge-requests-project-name-test-branch-2)
     (build '(manifests . ("manifest")))
     (channels
      (cons* (channel
-             (name 'test-project)
+             (name 'project-name)
              (url "https://gitlab.instance.test/source-repo/fork-name.git")
              (branch "test-branch"))
             %default-channels))
@@ -205,15 +222,16 @@
 
 (test-assert "custom-json-multiple-packages"
   (specifications-equal?
-   (gitlab-merge-request->specification
-    (gitlab-event-value
-     (json->gitlab-event custom-mr-json-multiple-packages)))
+   (let ((event (json->gitlab-event custom-mr-json-multiple-packages)))
+     (gitlab-merge-request->specification
+      (gitlab-event-value event)
+      (gitlab-event-project event)))
    (specification
-    (name 'gitlab-merge-requests-test-project-test-branch-1)
+    (name 'gitlab-merge-requests-project-name-test-branch-1)
     (build '(packages . ("package1" "package2" "package3")))
     (channels
      (cons* (channel
-             (name 'test-project)
+             (name 'project-name)
              (url "https://gitlab.instance.test/source-repo/fork-name.git")
              (branch "test-branch"))
             %default-channels))
@@ -223,15 +241,16 @@
 
 (test-assert "custom-json-name-prefix"
   (specifications-equal?
-   (gitlab-merge-request->specification
-    (gitlab-event-value
-     (json->gitlab-event custom-mr-json-name-prefix)))
+   (let ((event (json->gitlab-event custom-mr-json-name-prefix)))
+     (gitlab-merge-request->specification
+      (gitlab-event-value event)
+      (gitlab-event-project event)))
    (specification
-    (name 'prefix-test-project-test-branch-1)
-    (build '(channels . (test-project)))
+    (name 'prefix-project-name-test-branch-1)
+    (build '(channels . (project-name)))
     (channels
      (cons* (channel
-             (name 'test-project)
+             (name 'project-name)
              (url "https://gitlab.instance.test/source-repo/fork-name.git")
              (branch "test-branch"))
             %default-channels))
@@ -241,15 +260,16 @@
 
 (test-assert "custom-json-build-all"
   (specifications-equal?
-   (gitlab-merge-request->specification
-    (gitlab-event-value
-     (json->gitlab-event custom-mr-json-build-all)))
+   (let ((event (json->gitlab-event custom-mr-json-build-all)))
+     (gitlab-merge-request->specification
+      (gitlab-event-value event)
+      (gitlab-event-project event)))
    (specification
-    (name 'gitlab-merge-requests-test-project-test-branch-2)
+    (name 'gitlab-merge-requests-project-name-test-branch-2)
     (build 'all)
     (channels
      (cons* (channel
-             (name 'test-project)
+             (name 'project-name)
              (url "https://gitlab.instance.test/source-repo/fork-name.git")
              (branch "test-branch"))
             %default-channels))
diff --git a/tests/http.scm b/tests/http.scm
index bdd2b7d..3fdbaad 100644
--- a/tests/http.scm
+++ b/tests/http.scm
@@ -93,6 +93,9 @@
 (define mr-json-open
   "{
     \"event_type\": \"merge_request\",
+    \"project\": {
+        \"name\": \"test-name\"
+    },
     \"object_attributes\": {
         \"action\": \"open\",
         \"merge_status\": \"can_be_merged\",
@@ -108,6 +111,9 @@
 (define mr-json-close
   "{
     \"event_type\": \"merge_request\",
+    \"project\": {
+        \"name\": \"test-name\"
+    },
     \"object_attributes\": {
         \"action\": \"close\",
         \"merge_status\": \"can_be_merged\",
@@ -121,9 +127,10 @@
   }")
 
 (define mr-spec
-  (gitlab-merge-request->specification
-   (gitlab-event-value
-    (json->gitlab-event mr-json-open))))
+  (let ((event (json->gitlab-event mr-json-open)))
+    (gitlab-merge-request->specification
+     (gitlab-event-value event)
+     (gitlab-event-project event))))
 
 (define-syntax-rule (with-cuirass-register exp ...)
   (with-guix-daemon

base-commit: 59010a5ba32a5f0802d28900908ee9c75f473a66
-- 
2.45.2

Message #10 received at 72997-done@debbugs.gnu.org (full text, mbox, reply):

From: Ludovic Courtès <ludovic.courtes@inria.fr>

To: Romain GARBAGE <romain.garbage@inria.fr>

Cc: 72997-done@debbugs.gnu.org

Subject: Re: bug#72997: [PATCH Cuirass] cuirass: Use Gitlab project name to derive spec.

Date: Thu, 05 Sep 2024 11:58:11 +0200

Hey there,

Romain GARBAGE <romain.garbage@inria.fr> skribis:

> * src/cuirass/gitlab.scm (gitlab-project): New record type.
> (gitlab-event): New field PROJECT.
> (gitlab-merge-request->specification): New project argument.
> * src/cuirass/http.scm (url-hanlder): Update Gitlab API.
> * tests/gitlab.scm: Fix tests.
> * tests/http.scm: Fix tests.

I augmented the commit log a bit and pushed as
d196010d33dd85c91ae6a9a931fef8f7c2408f6b.

Thanks!

Ludo’.

Send a report that this bug log contains spam.