all messages for Guix-related lists mirrored at yhetil.org
 help / color / mirror / code / Atom feed
* [bug#72997] [PATCH Cuirass] cuirass: Use Gitlab project name to derive spec.
@ 2024-09-03  8:44 Romain GARBAGE
  2024-09-05  9:58 ` bug#72997: " Ludovic Courtès
  0 siblings, 1 reply; 2+ messages in thread
From: Romain GARBAGE @ 2024-09-03  8:44 UTC (permalink / raw)
  To: 72997; +Cc: ludovic.courtes, Romain GARBAGE

* 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





^ permalink raw reply related	[flat|nested] 2+ messages in thread

* bug#72997: [PATCH Cuirass] cuirass: Use Gitlab project name to derive spec.
  2024-09-03  8:44 [bug#72997] [PATCH Cuirass] cuirass: Use Gitlab project name to derive spec Romain GARBAGE
@ 2024-09-05  9:58 ` Ludovic Courtès
  0 siblings, 0 replies; 2+ messages in thread
From: Ludovic Courtès @ 2024-09-05  9:58 UTC (permalink / raw)
  To: Romain GARBAGE; +Cc: 72997-done

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’.




^ permalink raw reply	[flat|nested] 2+ messages in thread

end of thread, other threads:[~2024-09-05  9:59 UTC | newest]

Thread overview: 2+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2024-09-03  8:44 [bug#72997] [PATCH Cuirass] cuirass: Use Gitlab project name to derive spec Romain GARBAGE
2024-09-05  9:58 ` bug#72997: " Ludovic Courtès

Code repositories for project(s) associated with this external index

	https://git.savannah.gnu.org/cgit/guix.git

This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.