[PATCH Cuirass 1/4] specification: Ensure name is a symbol.

[PATCH Cuirass 1/4] specification: Ensure name is a symbol.

[Romain GARBAGE]

* src/cuirass/specification.scm (ensure-symbol): New variable.
(specification)[name]: Ensure name is a symbol.
* tests/database.scm: Fix test.
---
 src/cuirass/specification.scm | 11 ++++++++++-
 tests/database.scm            |  2 +-
 2 files changed, 11 insertions(+), 2 deletions(-)

diff --git a/src/cuirass/specification.scm b/src/cuirass/specification.scm
index d62037e..7b237e6 100644
--- a/src/cuirass/specification.scm
+++ b/src/cuirass/specification.scm
@@ -138,10 +138,19 @@
     packages
     manifests))
 
+(define (ensure-symbol x)
+  (if (string? x)
+      (string->symbol x)
+      x))
+
 (define-record-type* <specification>
   specification make-specification
   specification?
-  (name               specification-name) ;symbol
+  (name               specification-name
+                      ;; There was a confusion in the documentation regarding
+                      ;; the type of this field. For this reason, strings are
+                      ;; accepted but silently converted into symbols.
+                      (sanitize ensure-symbol)) ;symbol
   (build              specification-build ;symbol for %build-types
                       (default 'all))
   (channels           specification-channels ;list of <channel>
diff --git a/tests/database.scm b/tests/database.scm
index c4efb0a..010c139 100644
--- a/tests/database.scm
+++ b/tests/database.scm
@@ -190,7 +190,7 @@ timestamp, checkouttime, evaltime) VALUES ('guix', 0, 0, 0, 0);")
       (let* ((spec (db-get-specification "guix"))
              (channels (specification-channels spec))
              (build-outputs (specification-build-outputs spec)))
-        (and (string=? (specification-name spec) "guix")
+        (and (eq? (specification-name spec) 'guix)
              (equal? (map channel-name channels) '(guix my-channel))
              (equal? (map build-output-job build-outputs) '("job"))))))
 
-- 
2.45.1

[PATCH Cuirass 2/4] gitlab: Add module for Gitlab JSON objects definition.

[Romain GARBAGE]

* Makefile.am: Add src/cuirass/gitlab.scm.
* src/cuirass/gitlab.scm: Add <gitlab-event> and <gitlab-merge-request> record
types.
(gitlab-merge-request->specification): New variable.
---
 Makefile.am            |  1 +
 src/cuirass/gitlab.scm | 95 ++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 96 insertions(+)
 create mode 100644 src/cuirass/gitlab.scm

diff --git a/Makefile.am b/Makefile.am
index c58bf58..4a066d3 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -52,6 +52,7 @@ dist_pkgmodule_DATA =				\
   src/cuirass/store.scm				\
   src/cuirass/base.scm				\
   src/cuirass/database.scm			\
+  src/cuirass/gitlab.scm                        \
   src/cuirass/http.scm				\
   src/cuirass/logging.scm			\
   src/cuirass/mail.scm				\
diff --git a/src/cuirass/gitlab.scm b/src/cuirass/gitlab.scm
new file mode 100644
index 0000000..dab76b5
--- /dev/null
+++ b/src/cuirass/gitlab.scm
@@ -0,0 +1,95 @@
+;;;; gitlab.scm -- Gitlab JSON mappings
+;;; Copyright © 2024 Romain Garbage <guix-devel@rgarbage.fr>
+;;;
+;;; This file is part of Cuirass.
+;;;
+;;; Cuirass is free software: you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation, either version 3 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; Cuirass is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Cuirass.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (cuirass gitlab)
+  #:use-module (cuirass specification)
+  #:use-module (json)
+  #:use-module (guix channels)
+  #:use-module (ice-9 match)
+  #:export (gitlab-event
+            gitlab-event-type
+            gitlab-event-value
+            json->gitlab-event
+
+            gitlab-merge-request
+            gitlab-merge-request-action
+            gitlab-merge-request-project-name
+            json->gitlab-merge-request
+            gitlab-merge-request->specification))
+
+(define-json-mapping <gitlab-source>
+  make-gitlab-source
+  gitlab-source?
+  json->gitlab-source
+  (repo-url gitlab-source-repo-url "git_http_url")
+  (name     gitlab-source-name "name"
+            string->symbol))
+
+(define-json-mapping <gitlab-merge-request>
+  make-gitlab-merge-request
+  gitlab-merge-request?
+  json->gitlab-merge-request
+  (action          gitlab-merge-request-action "action")
+  (source-branch   gitlab-merge-request-source-branch "source_branch")
+  (source          gitlab-merge-request-source "source"
+                   json->gitlab-source))
+
+(define-json-mapping <gitlab-event>
+  make-gitlab-event
+  gitlab-event?
+  json->gitlab-event
+  (type  gitlab-event-type "event_type"
+         (lambda (v)
+           (string->symbol
+             (string-map (lambda (c)
+                           (if (char=? c #\_)
+                               #\-
+                               c))
+                         v))))
+  (value gitlab-event-value "object_attributes"
+         (lambda (v)
+           ;; FIXME: properly handle cases using field TYPE defined above.
+           ;; This would need to use something like Guix's define-record-type*.
+           (cond
+            ((assoc-ref v "merge_status")
+             (json->gitlab-merge-request v))
+            (#t #f)))))
+
+(define (gitlab-merge-request->specification merge-request)
+  "Returns a SPECIFICATION built out of a GITLAB-MERGE-REQUEST."
+  (let* ((source-name (gitlab-source-name
+                       (gitlab-merge-request-source merge-request)))
+         (source-branch (gitlab-merge-request-source-branch merge-request))
+         (source-url (gitlab-source-repo-url
+                      (gitlab-merge-request-source merge-request)))
+         (spec-name (symbol-append 'gitlab-merge-requests-
+                                   source-name
+                                   '-
+                                   (string->symbol source-branch))))
+    (specification
+     (name spec-name)
+     (build `(channels ,source-name))
+     (channels
+      (cons* (channel
+              (name source-name)
+              (url source-url)
+              (branch source-branch))
+             %default-channels))
+     (priority 1)
+     (period 0)
+     (systems (list "x86_64-linux")))))
-- 
2.45.1

[PATCH Cuirass 3/4] http: Add /admin/gitlab/event.

[Romain GARBAGE]

* src/cuirass/http.scm (url-handler): Add "/admin/gitlab/event".
---
 src/cuirass/http.scm | 88 +++++++++++++++++++++++++++++++++++++++-----
 1 file changed, 78 insertions(+), 10 deletions(-)

diff --git a/src/cuirass/http.scm b/src/cuirass/http.scm
index 0a2a30f..d47333c 100644
--- a/src/cuirass/http.scm
+++ b/src/cuirass/http.scm
@@ -5,6 +5,7 @@
 ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
 ;;; Copyright © 2018 Tatiana Sholokhova <tanja201396@gmail.com>
 ;;; Copyright © 2019, 2020 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2024 Romain Garbage <guix-devel@rgarbage.fr>
 ;;;
 ;;; This file is part of Cuirass.
 ;;;
@@ -26,6 +27,7 @@
   #:use-module (cuirass config)
   #:use-module (cuirass database)
   #:use-module ((cuirass base) #:select (evaluation-log-file))
+  #:use-module (cuirass gitlab)
   #:use-module (cuirass metrics)
   #:use-module (cuirass utils)
   #:use-module (cuirass logging)
@@ -705,6 +707,72 @@ bogus reply is received, return DEFAULT."
     (('GET "robots.txt")
      (respond-text %robots-txt))
 
+    ;; Define an API for Gitlab events.
+    (('POST "admin" "gitlab" "event")
+     (let* ((params (utf8->string body))
+            (event (json->gitlab-event params))
+            (content-type (assoc-ref (request-headers request) 'content-type))
+            (json? (equal? (car content-type)
+                           'application/json)))
+       (if json?
+           (match (gitlab-event-type event)
+             ('merge-request
+              (let* ((merge-request (gitlab-event-value event))
+                     (spec (gitlab-merge-request->specification merge-request)))
+                (match (gitlab-merge-request-action merge-request)
+                  ;; New merge request.
+                  ((or "open" "reopen")
+                   (if (not (db-get-specification (specification-name spec)))
+                       (begin
+                         (db-add-or-update-specification spec)
+
+                         (unless (call-bridge `(register-jobset ,(specification-name spec))
+                                              bridge)
+                           (log-warning
+                            "cannot notify bridge of the addition of jobset '~a'"
+                            (specification-name spec)))
+                         (respond
+                          (build-response #:code 200
+                                          #:headers
+                                          `((location . ,(string->uri-reference "/"))))
+                          #:body ""))
+                       (begin
+                         (log-warning "jobset '~a' already exists" (specification-name spec))
+                         (respond-json-with-error 400 "Jobset already exists."))))
+                  ;; Accepted or rejected merge requests receive the same treatment.
+                  ((or "close" "merge")
+                   (let ((spec-name (symbol->string (specification-name spec))))
+                     (if (db-get-specification spec-name)
+                         (begin
+                           (db-remove-specification spec-name)
+                           (log-info "Removed jobset '~a'" spec-name)
+                           (respond
+                            (build-response #:code 200
+                                            #:headers
+                                            `((location . ,(string->uri-reference "/"))))
+                            #:body ""))
+                         (begin
+                           (log-warning "cannot find jobset '~a'" spec-name)
+                           (respond-json-with-error 404 "Jobset not found.")))))
+                  ;; A lot of things can trigger an "update" action. For now they are all
+                  ;; treated the same way: the jobset is reevaluated.
+                  ;; XXX: Copied and adapted from "/jobset/<spec>/hook/evaluate.
+                  ("update"
+                   (let ((spec-name (symbol->string (specification-name spec))))
+                     (if (db-get-specification spec-name)
+                         (if (call-bridge `(trigger-jobset ,(specification-name spec))
+                                          bridge)
+                             (respond-json (scm->json-string `((jobset . ,spec-name))))
+                             (begin
+                               (log-warning "evaluation hook disabled")
+                               (respond-json-with-error 400 "Evaluation hook disabled.")))
+                         (respond-json-with-error 404 "Jobset not found."))))
+                  (action (log-warning
+                         "Handling of action '~a' not implemented"
+                         action)))))
+             (event-type (respond-json-with-error 400 (format #f "Event type \"~a\" not supported." event-type))))
+           (respond-json-with-error 400 "This API only supports JSON."))))
+
     (('POST "admin" "specification" "add")
      (let* ((spec (body->specification body))
             (name (specification-name spec)))
@@ -1026,7 +1094,7 @@ bogus reply is received, return DEFAULT."
            (respond-json-with-error 500 "Parameter not defined!"))))
     (('GET "api" "evaluations")
      (let* ((params (request-parameters request))
-            (spec (assq-ref params 'spec))        ;optional
+            (spec (assq-ref params 'spec)) ;optional
             ;; 'nr parameter is mandatory to limit query size.
             (nr (assq-ref params 'nr)))
        (if nr
@@ -1233,13 +1301,13 @@ bogus reply is received, return DEFAULT."
              (build-search-results-table
               query
               (with-time-logging
-               "job search request"
-               (db-get-builds-by-search
-                `((query . ,query)
-                  (nr . ,%page-size)
-                  (order . finish-time+build-id)
-                  (border-low-id . ,border-low-id)
-                  (border-high-id . ,border-high-id))))
+                  "job search request"
+                (db-get-builds-by-search
+                 `((query . ,query)
+                   (nr . ,%page-size)
+                   (order . finish-time+build-id)
+                   (border-low-id . ,border-low-id)
+                   (border-high-id . ,border-high-id))))
               builds-id-min
               builds-id-max)
              '()
@@ -1367,8 +1435,8 @@ bogus reply is received, return DEFAULT."
        (if file
            (if (file-exists? file)
                (respond-file file #:ttl %static-file-ttl)
-               (fail 500))                     ;something's wrong: it vanished
-           (fail 404))))                       ;no such build product
+               (fail 500))              ;something's wrong: it vanished
+           (fail 404))))                ;no such build product
 
     (('GET "machine" name)
      (respond-html
-- 
2.45.1

[PATCH Cuirass 4/4] http: Add tests for Gitlab API.

[Romain GARBAGE]

* tests/http.scm (http-post-json, mr-json-open, mr-json-close mr-spec): New
variables.
New tests for Gitlab API.
---
 tests/http.scm | 34 ++++++++++++++++++++++++++++++++++
 1 file changed, 34 insertions(+)

diff --git a/tests/http.scm b/tests/http.scm
index a124761..3281bcc 100644
--- a/tests/http.scm
+++ b/tests/http.scm
@@ -21,6 +21,7 @@
 
 (use-modules (cuirass http)
              (cuirass database)
+             (cuirass gitlab)
              (cuirass specification)
              (cuirass utils)
              (tests common)
@@ -41,6 +42,9 @@
   (call-with-values (lambda () (http-get uri))
     (lambda (response body) body)))
 
+(define (http-post-json uri body)
+  (http-post uri #:body body #:headers '((content-type application/json))))
+
 (define (wait-until-ready port)
   ;; Wait until the server is accepting connections.
   (let ((conn (socket PF_INET SOCK_STREAM 0)))
@@ -85,6 +89,17 @@
                      (channel . "packages")
                      (directory . "dir2")))))))
 
+(define mr-json-open
+  "{\"event_type\":\"merge_request\",\"object_attributes\":{\"action\":\"open\",\"merge_status\":\"can_be_merged\",\"source_branch\":\"test-branch\",\"source\":{\"git_http_url\":\"https://gitlab.instance.test/source-repo/fork-name.git\",\"name\":\"test-project\"}}}")
+
+(define mr-json-close
+  "{\"event_type\":\"merge_request\",\"object_attributes\":{\"action\":\"close\",\"merge_status\":\"can_be_merged\",\"source_branch\":\"test-branch\",\"source\":{\"git_http_url\":\"https://gitlab.instance.test/source-repo/fork-name.git\",\"name\":\"test-project\"}}}")
+
+(define mr-spec
+  (gitlab-merge-request->specification
+   (gitlab-event-value
+    (pk 'json (json->gitlab-event mr-json-open)))))
+
 (test-group-with-cleanup "http"
   (test-assert "db-init"
     (begin
@@ -323,6 +338,25 @@
         (http-get-body
          (test-cuirass-uri "/api/jobs/history?spec=guix&names=fake-job&nr=10"))))))
 
+  (test-equal "/admin/gitlab/event creates a spec from a new merge request"
+    (specification-name mr-spec)
+    (begin
+      (http-post-json (test-cuirass-uri "/admin/gitlab/event") mr-json-open)
+      (specification-name (db-get-specification (specification-name mr-spec)))))
+
+  (test-equal "/admin/gitlab/event error when a merge request has already been created"
+    400
+    (response-code (http-post-json (test-cuirass-uri "/admin/gitlab/event") mr-json-open)))
+
+  (test-assert "/admin/gitlab/event removes a spec from a closed merge request"
+    (begin
+      (http-post-json (test-cuirass-uri "/admin/gitlab/event") mr-json-close)
+      (not (db-get-specification (specification-name mr-spec)))))
+
+  (test-equal "/admin/gitlab/event error when a merge request has already been closed"
+    404
+    (response-code (http-post-json (test-cuirass-uri "/admin/gitlab/event") mr-json-close)))
+
   (test-assert "db-close"
     (begin
       (db-close (%db))
-- 
2.45.1

Re: [PATCH Cuirass 1/4] specification: Ensure name is a symbol.

[Ludovic Courtès]

Hi Romain,

I’ve applied the whole series to Cuirass:

  81d2530 * http: Add /admin/gitlab/event.
  10cf59f * gitlab: Add module for Gitlab JSON objects definition.
  1da873b * specification: Ensure name is a symbol.

I took the liberty to merge the commit that adds test with the one that
defines the HTTP endpoint, and I also added a comment at the top of
gitlab.scm giving context.

For those following along: Romain and I work together at Inria.  This
feature will allow us to hook Cuirass into GitLab so that merge requests
on the channels hosted at https://gitlab.inria.fr/guix-hpc trigger
builds on https://guix.bordeaux.inria.fr (technically, it adds a new
“spec” that gets deleted once the merge request is merged).

We still need to figure out how to get the build result back into
GitLab, but that’s a start.

Feedback welcome!

Thanks,
Ludo’.

Re: [PATCH Cuirass 1/4] specification: Ensure name is a symbol.

[Ludovic Courtès]

Hi,

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

> I’ve applied the whole series to Cuirass:
>
>   81d2530 * http: Add /admin/gitlab/event.
>   10cf59f * gitlab: Add module for Gitlab JSON objects definition.
>   1da873b * specification: Ensure name is a symbol.

After doing some more testing, we realized the string/symbol migration
introduced type errors (statically-typed language programmers would be
right to laugh at us here, I admit).  It’s not fixed in ‘main’ yet, but
we’ll be looking into it in the coming days.

Cheers,
Ludo’.

Re: [PATCH Cuirass 1/4] specification: Ensure name is a symbol.

[Simon Tournier]

Hi,

On Mon, 17 Jun 2024 at 15:16, Ludovic Courtès <ludovic.courtes@inria.fr> wrote:

>                         statically-typed language programmers would be
> right to laugh at us here, I admit

Nah because the new feature is really nice! :-) Thanks.  But it
remembers me one of our first in-person discussion back then on December
2018… My 6-years patience is paying off. ;-)

Cheers,
simon