;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2020 Mathieu Othacehe <othacehe@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix 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.
;;;
;;; GNU Guix 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 GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix ci)
  #:use-module (gnu packages)
  #:use-module (guix channels)
  #:use-module (guix http-client)
  #:use-module (guix packages)
  #:use-module (guix profiles)
  #:use-module (guix ui)
  #:use-module (guix utils)
  #:use-module (json)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 match)
  #:use-module (guix i18n)
  #:use-module (guix diagnostics)
  #:autoload   (guix channels) (channel)
  #:export (build-product?
            build-product-id
            build-product-type
            build-product-file-size
            build-product-path

            build?
            build-id
            build-derivation
            build-evaluation
            build-system
            build-status
            build-timestamp
            build-products

            checkout?
            checkout-commit
            checkout-channel

            evaluation?
            evaluation-id
            evaluation-spec
            evaluation-complete?
            evaluation-checkouts

            %query-limit
            queued-builds
            latest-builds
            evaluation
            latest-evaluations
            evaluations-for-commit

            manifest->jobs
            channel-with-substitutes-available))

;;; Commentary:
;;;
;;; This module provides a client to the HTTP interface of the Hydra and
;;; Cuirass continuous integration (CI) tools.
;;;
;;; Code:

;; The name of the CI specification building the 'guix-modular' package.
(define %default-guix-specification
  (make-parameter "guix"))

;; The default name of the CI specification building all the packages.
(define %default-package-specification
  (make-parameter "master"))

(define-json-mapping <build-product> make-build-product
  build-product?
  json->build-product
  (id          build-product-id)                  ;integer
  (type        build-product-type)                ;string
  (file-size   build-product-file-size)           ;integer
  (path        build-product-path))               ;string

(define-json-mapping <build> make-build build?
  json->build
  (id          build-id "id")                     ;integer
  (derivation  build-derivation)                  ;string | #f
  (evaluation  build-evaluation)                  ;integer
  (system      build-system)                      ;string
  (status      build-status "buildstatus" )       ;integer
  (timestamp   build-timestamp)                   ;integer
  (products    build-products "buildproducts"     ;<build-product>*
               (lambda (products)
                 (map json->build-product
                      ;; Before Cuirass 3db603c1, #f is always returned.
                      (if (vector? products)
                          (vector->list products)
                          '())))))

(define-json-mapping <checkout> make-checkout checkout?
  json->checkout
  (commit      checkout-commit)                   ;string (SHA1)
  (channel     checkout-channel))                 ;string (name)

(define-json-mapping <evaluation> make-evaluation evaluation?
  json->evaluation
  (id          evaluation-id)                     ;integer
  (spec        evaluation-spec "specification")   ;string
  (complete?   evaluation-complete? "in-progress"
               (match-lambda
                 (0 #t)
                 (_ #f)))                         ;Boolean
  (checkouts   evaluation-checkouts "checkouts"   ;<checkout>*
               (lambda (checkouts)
                 (map json->checkout
                      (vector->list checkouts)))))

(define-json-mapping <job> make-job job?
  json->job
  (name        job-name)                   ;string
  (build       job-build)                  ;integer
  (status      job-status))                ;integer

(define-json-mapping <history> make-history history?
  json->history
  (evaluation  history-evaluation)                ;integer
  (checkouts   history-checkouts "checkouts"      ;<checkout>*
               (lambda (checkouts)
                 (map json->checkout
                      (vector->list checkouts))))
  (jobs        history-jobs "jobs"
               (lambda (jobs)
                 (map json->job
                      (vector->list jobs)))))

(define %query-limit
  ;; Max number of builds requested in queries.
  1000)

(define (json-fetch url)
  (let* ((port (http-fetch url))
         (json (json->scm port)))
    (close-port port)
    json))

(define* (queued-builds url #:optional (limit %query-limit))
  "Return the list of queued derivations on URL."
  (let ((queue (json-fetch (string-append url "/api/queue?nr="
                                          (number->string limit)))))
    (map json->build (vector->list queue))))

(define* (latest-builds url #:optional (limit %query-limit)
                        #:key evaluation system job status)
  "Return the latest builds performed by the CI server at URL.  If EVALUATION
is an integer, restrict to builds of EVALUATION.  If SYSTEM is true (a system
string such as \"x86_64-linux\"), restrict to builds for SYSTEM."
  (define* (option name value #:optional (->string identity))
    (if value
        (string-append "&" name "=" (->string value))
        ""))

  (let ((latest (json-fetch (string-append url "/api/latestbuilds?nr="
                                           (number->string limit)
                                           (option "evaluation" evaluation
                                                   number->string)
                                           (option "system" system)
                                           (option "job" job)
                                           (option "status" status
                                                   number->string)))))
    ;; Note: Hydra does not provide a "derivation" field for entries in
    ;; 'latestbuilds', but Cuirass does.
    (map json->build (vector->list latest))))

(define (evaluation url evaluation)
  "Return the given EVALUATION performed by the CI server at URL."
  (let ((evaluation (json-fetch
                     (string-append url "/api/evaluation?id="
                                    (number->string evaluation)))))
    (json->evaluation evaluation)))

(define* (latest-evaluations url #:optional (limit %query-limit))
  "Return the latest evaluations performed by the CI server at URL."
  (map json->evaluation
       (vector->list
        (json->scm
         (http-fetch (string-append url "/api/evaluations?nr="
                                    (number->string limit)))))))


(define* (evaluations-for-commit url commit #:optional (limit %query-limit))
  "Return the evaluations among the latest LIMIT evaluations that have COMMIT
as one of their inputs."
  (filter (lambda (evaluation)
            (find (lambda (checkout)
                    (string=? (checkout-commit checkout) commit))
                  (evaluation-checkouts evaluation)))
          (latest-evaluations url limit)))

(define* (job url name #:key evaluation)
  "Return the job which name is NAME for the given EVALUATION, from the CI
server at URL."
  (map json->job
       (vector->list
        (json->scm
         (http-fetch
          (format #f "~a/api/jobs?evaluation=~a&names=~a"
                  url evaluation name))))))

(define* (jobs-history url jobs
                       #:key
                       (specification "master")
                       (limit 20))
  "Return the job history for the SPECIFICATION jobs which names are part of
the JOBS list, from the CI server at URL.  Limit the history to the latest
LIMIT evaluations. "
  (let ((names (string-join jobs ",")))
    (map json->history
         (vector->list
          (json->scm
           (http-fetch
            (format #f "~a/api/jobs/history?spec=~a&names=~a&nr=~a"
                    url specification names (number->string limit))))))))

(define (sort-history-by-coverage history)
  "Sort and return the given evaluation HISTORY list by descending successful
jobs count.  This means that the first element of the list will be the
evaluation with the higher successful jobs count."
  (let ((coverage
         (map (cut fold
                   (lambda (status prev)
                     (if (eq? status 0) ;successful
                         (1+ prev)
                         prev))
                   0 <>)
              (map (compose
                    (cut map job-status <>) history-jobs)
                   history))))
    (map (match-lambda
           ((cov . hist) hist))
         (sort (map cons coverage history)
               (match-lambda*
                 (((c1 . h1) (c2 . h2))
                  (> c1 c2)))))))

(define (channel-commit checkouts channel)
  "Return the CHANNEL commit from CHECKOUTS."
  (any (lambda (checkout)
         (and (string=? (checkout-channel checkout) channel)
              (checkout-commit checkout)))
       checkouts))

(define (package->job-name package)
  "Return the CI job name for the given PACKAGE name."
  (string-append package "." (%current-system)))

(define (manifest->jobs manifest)
  "Return the list of job names that are part of the given MANIFEST."
  (define (load-manifest file)
    (let ((user-module (make-user-module '((guix profiles) (gnu)))))
      (load* file user-module)))

  (let* ((manifest (cond
                   ((string? manifest)
                    (load-manifest manifest))
                   ((manifest? manifest)
                    manifest)
                   (else #f)))
         (packages (delete-duplicates
                    (map manifest-entry-item
                         (manifest-transitive-entries manifest))
                    eq?)))
    (map (lambda (package)
           (package->job-name (package-name package)))
         packages)))

(define* (latest-checkouts-with-substitutes url jobs)
  "Return a list of latest checkouts, sorted by descending substitutes
coverage of the given JOBS list on the CI server at URL. Only evaluations for
which the Guix package is built are considered.

If JOBS is false, return a list of latest checkouts for which the Guix package
is built.  Return false if no checkouts were found."
  (define guix-history
    (filter (lambda (hist)
              (let ((jobs (history-jobs hist)))
                (match jobs
                  ((job)
                   (eq? (job-status job) 0))
                  (else #f))))
            (jobs-history url (list (package->job-name "guix"))
                          #:specification
                          (%default-guix-specification))))

  (define (guix-commit checkouts)
    (let ((name (symbol->string
                 (channel-name %default-guix-channel))))
      (channel-commit checkouts name)))

  (define (guix-package-available? hist)
    (any (lambda (guix-hist)
           (string=? (guix-commit
                      (history-checkouts hist))
                     (guix-commit
                      (history-checkouts guix-hist)))
           hist)
         guix-history))

  (define (first-checkout checkouts)
    (match checkouts
      ((checkouts _ ...)
       checkouts)
      (() #f)))

  (if jobs
      (let* ((jobs-history
              (sort-history-by-coverage
               (jobs-history url jobs
                             #:specification
                             (%default-package-specification))))
             (checkouts
              (map history-checkouts
                   (filter-map guix-package-available?
                               jobs-history))))
        (first-checkout checkouts))
      (first-checkout
       (map history-checkouts guix-history))))

(define* (channel-with-substitutes-available chan url
                                             #:optional manifest)
  "Return a channel inheriting from CHAN but which commit field is set to the
latest commit with available substitutes for the Guix package definitions at
URL.  If the MANIFEST argument is passed, return the latest commit with the
maximal substitutes coverage of MANIFEST.  MANIFEST can be an absolute path as
a string, or a <manifest> record.  The current system is taken into account.

If no commit with available substitutes were found, the commit field is set to
false and a warning message is printed."
  (let* ((jobs (and manifest
                    (manifest->jobs manifest)))
         (checkouts
          (latest-checkouts-with-substitutes url jobs)))
    (unless checkouts
      (warning (G_ "could not find available substitutes at ~a~%")
               url))
    (let* ((name (channel-name chan))
           (name-str (if (symbol? name)
                         (symbol->string name)
                         name))
           (commit (and checkouts
                        (channel-commit checkouts name-str))))
      (channel
       (inherit chan)
       (commit commit)))))