;;; forgejo.scm -- Forgejo JSON mappings
;;; Copyright © 2024 Romain Garbage <romain.garbage@inria.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 forges forgejo)
  #:use-module (cuirass specification)
  #:use-module (cuirass forges)
  #:use-module (json)
  #:use-module (web http)
  #:use-module (guix channels)
  #:use-module (ice-9 match)
  #:export (forgejo-pull-request-event-pull-request
            forgejo-pull-request-event-action
            json->forgejo-pull-request-event

            forgejo-repository-name
            forgejo-repository-url

            json->forgejo-pull-request

            forgejo-pull-request->specification))

;;; Commentary:
;;;
;;; This module implements a subset of the Forgejo Webhook API described at
;;; <https://forgejo.org/docs/latest/user/webhooks/>.
;;;
;;; Code:

;; This declares a specific header for internal consumption, specifically when
;; generating requests during tests.
(declare-opaque-header! "X-Forgejo-Event")

(define-json-mapping <forgejo-repository>
  make-forgejo-repository
  forgejo-repository?
  json->forgejo-repository
  (name forgejo-repository-name "name"
        string->symbol)
  (url  forgejo-repository-url "clone_url"))

;; This maps to the top level JSON object.
(define-json-mapping <forgejo-pull-request-event>
  make-forgejo-pull-request-event
  forgejo-pull-request-event?
  json->forgejo-pull-request-event
  (action       forgejo-pull-request-event-action "action"
                string->symbol)
  (pull-request forgejo-pull-request-event-pull-request "pull_request"
                json->forgejo-pull-request))

(define-json-mapping <forgejo-pull-request>
  make-forgejo-pull-request
  forgejo-pull-request?
  json->forgejo-pull-request
  (number  forgejo-pull-request-number "number")
  (base    forgejo-pull-request-base "base"
           json->forgejo-repository-reference)
  (head    forgejo-pull-request-head "head"
           json->forgejo-repository-reference))

;; This mapping is used to define various JSON objects such as "base" or
;; "head".
(define-json-mapping <forgejo-repository-reference>
  make-forgejo-repository-reference
  forgejo-repository-reference?
  json->forgejo-repository-reference
  (label      forgejo-repository-reference-label "label")
  (ref        forgejo-repository-reference-ref "ref")
  (sha        forgejo-repository-reference-sha "sha")
  (repository forgejo-repository-reference-repository "repo"
              json->forgejo-repository))

(define* (forgejo-pull-request->specification pull-request #:optional (cuirass-options #f))
  "Returns a SPECIFICATION built out of a FORGEJO-PULL-REQUEST."
  (let* ((source-repo-reference (forgejo-pull-request-head pull-request))
         (project-name (forgejo-repository-name
                        (forgejo-repository-reference-repository
                         (forgejo-pull-request-base pull-request))))
         (source-branch (forgejo-repository-reference-ref source-repo-reference))
         (source-url (forgejo-repository-url
                      (forgejo-repository-reference-repository source-repo-reference)))
         (id (forgejo-pull-request-number pull-request))
         (name-prefix (if (and cuirass-options
                               (jobset-options-name-prefix cuirass-options))
                          (jobset-options-name-prefix cuirass-options)
                          'forgejo-pull-requests))
         (spec-name (string->symbol
                     (format #f "~a-~a-~a-~a" name-prefix
                             project-name
                             source-branch
                             id)))
         (build (if (and cuirass-options
                         (jobset-options-build cuirass-options))
                    (jobset-options-build cuirass-options)
                    `(channels ,project-name)))
         (period (if (and cuirass-options
                          (jobset-options-period cuirass-options))
                     (jobset-options-period cuirass-options)
                     %default-jobset-options-period))
         (priority (if (and cuirass-options
                            (jobset-options-priority cuirass-options))
                       (jobset-options-priority cuirass-options)
                       %default-jobset-options-priority))
         (systems (if (and cuirass-options
                           (jobset-options-systems cuirass-options))
                      (jobset-options-systems cuirass-options)
                      %default-jobset-options-systems)))
    (specification
     (name spec-name)
     (build build)
     (channels
      (cons* (channel
              (name project-name)
              (url source-url)
              (branch source-branch))
             %default-channels))
     (priority priority)
     (period period)
     (systems systems))))