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

[Romain GARBAGE <romain.garbage@inria.fr>]

* 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