guix/ci.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2020 Mathieu Othacehe <othacehe@gnu.org>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 3 of the License, or (at
  10 ;;; your option) any later version.
  11 ;;;
  12 ;;; GNU Guix is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 (define-module (guix ci)
  21   #:use-module (guix http-client)
  22   #:use-module (guix utils)
  23   #:use-module (json)
  24   #:use-module (srfi srfi-1)
  25   #:use-module (ice-9 match)
  26   #:use-module (guix i18n)
  27   #:use-module (guix diagnostics)
  28   #:autoload   (guix channels) (channel)
  29   #:export (build-product?
  30             build-product-id
  31             build-product-type
  32             build-product-file-size
  33             build-product-path
  34
  35             build?
  36             build-id
  37             build-derivation
  38             build-evaluation
  39             build-system
  40             build-status
  41             build-timestamp
  42             build-products
  43
  44             checkout?
  45             checkout-commit
  46             checkout-channel
  47
  48             evaluation?
  49             evaluation-id
  50             evaluation-spec
  51             evaluation-complete?
  52             evaluation-checkouts
  53
  54             job?
  55             job-build-id
  56             job-status
  57             job-name
  58
  59             %query-limit
  60             queued-builds
  61             latest-builds
  62             evaluation
  63             evaluation-jobs
  64             build
  65             job-build
  66             latest-evaluations
  67             evaluations-for-commit
  68
  69             channel-with-substitutes-available))
  70
  71 ;;; Commentary:
  72 ;;;
  73 ;;; This module provides a client to the HTTP interface of the Hydra and
  74 ;;; Cuirass continuous integration (CI) tools.
  75 ;;;
  76 ;;; Code:
  77
  78 (define-json-mapping <build-product> make-build-product
  79   build-product?
  80   json->build-product
  81   (id          build-product-id)                  ;integer
  82   (type        build-product-type)                ;string
  83   (file-size   build-product-file-size)           ;integer
  84   (path        build-product-path))               ;string
  85
  86 (define-syntax-rule (define-enumeration-mapping proc
  87                       (names integers) ...)
  88   (define (proc value)
  89     (match value
  90       (integers 'names) ...)))
  91
  92 (define-enumeration-mapping integer->build-status
  93   ;; Copied from 'build-status' in Cuirass.
  94   (submitted        -3)
  95   (scheduled        -2)
  96   (started          -1)
  97   (succeeded         0)
  98   (failed            1)
  99   (failed-dependency 2)
 100   (failed-other      3)
 101   (canceled          4))
 102
 103 (define-json-mapping <build> make-build build?
 104   json->build
 105   (id          build-id "id")                     ;integer
 106   (derivation  build-derivation)                  ;string | #f
 107   (evaluation  build-evaluation)                  ;integer
 108   (system      build-system)                      ;string
 109   (status      build-status "buildstatus"         ;symbol
 110                integer->build-status)
 111   (timestamp   build-timestamp)                   ;integer
 112   (products    build-products "buildproducts"     ;<build-product>*
 113                (lambda (products)
 114                  (map json->build-product
 115                       ;; Before Cuirass 3db603c1, #f is always returned.
 116                       (if (vector? products)
 117                           (vector->list products)
 118                           '())))))
 119
 120 (define-json-mapping <job> make-job job?
 121   json->job
 122   (build-id    job-build-id "build")              ;integer
 123   (status      job-status "status"                ;symbol
 124                integer->build-status)
 125   (name        job-name))                         ;string
 126
 127 (define-json-mapping <checkout> make-checkout checkout?
 128   json->checkout
 129   (commit      checkout-commit)                   ;string (SHA1)
 130   (channel     checkout-channel))                 ;string (name)
 131
 132 (define-json-mapping <evaluation> make-evaluation evaluation?
 133   json->evaluation
 134   (id          evaluation-id)                     ;integer
 135   (spec        evaluation-spec "specification")   ;string
 136   (complete?   evaluation-complete? "status"
 137                (match-lambda
 138                  (0 #t)
 139                  (_ #f)))                         ;Boolean
 140   (checkouts   evaluation-checkouts "checkouts"   ;<checkout>*
 141                (lambda (checkouts)
 142                  (map json->checkout
 143                       (vector->list checkouts)))))
 144
 145 (define %query-limit
 146   ;; Max number of builds requested in queries.
 147   1000)
 148
 149 (define (json-fetch url)
 150   (let* ((port (http-fetch url))
 151          (json (json->scm port)))
 152     (close-port port)
 153     json))
 154
 155 (define* (queued-builds url #:optional (limit %query-limit))
 156   "Return the list of queued derivations on URL."
 157   (let ((queue (json-fetch (string-append url "/api/queue?nr="
 158                                           (number->string limit)))))
 159     (map json->build (vector->list queue))))
 160
 161 (define* (latest-builds url #:optional (limit %query-limit)
 162                         #:key evaluation system job status)
 163   "Return the latest builds performed by the CI server at URL.  If EVALUATION
 164 is an integer, restrict to builds of EVALUATION.  If SYSTEM is true (a system
 165 string such as \"x86_64-linux\"), restrict to builds for SYSTEM."
 166   (define* (option name value #:optional (->string identity))
 167     (if value
 168         (string-append "&" name "=" (->string value))
 169         ""))
 170
 171   (let ((latest (json-fetch (string-append url "/api/latestbuilds?nr="
 172                                            (number->string limit)
 173                                            (option "evaluation" evaluation
 174                                                    number->string)
 175                                            (option "system" system)
 176                                            (option "job" job)
 177                                            (option "status" status
 178                                                    number->string)))))
 179     ;; Note: Hydra does not provide a "derivation" field for entries in
 180     ;; 'latestbuilds', but Cuirass does.
 181     (map json->build (vector->list latest))))
 182
 183 (define (evaluation url evaluation)
 184   "Return the given EVALUATION performed by the CI server at URL."
 185   (let ((evaluation (json-fetch
 186                      (string-append url "/api/evaluation?id="
 187                                     (number->string evaluation)))))
 188     (json->evaluation evaluation)))
 189
 190 (define* (latest-evaluations url
 191                              #:optional (limit %query-limit)
 192                              #:key spec)
 193   "Return the latest evaluations performed by the CI server at URL.  If SPEC
 194 is passed, only consider the evaluations for the given SPEC specification."
 195   (let ((spec (if spec
 196                   (format #f "&spec=~a" spec)
 197                   "")))
 198     (map json->evaluation
 199          (vector->list
 200           (json->scm
 201            (http-fetch
 202             (string-append url "/api/evaluations?nr="
 203                            (number->string limit)
 204                            spec)))))))
 205
 206 (define* (evaluations-for-commit url commit #:optional (limit %query-limit))
 207   "Return the evaluations among the latest LIMIT evaluations that have COMMIT
 208 as one of their inputs."
 209   (filter (lambda (evaluation)
 210             (find (lambda (checkout)
 211                     (string=? (checkout-commit checkout) commit))
 212                   (evaluation-checkouts evaluation)))
 213           (latest-evaluations url limit)))
 214
 215 (define (evaluation-jobs url evaluation-id)
 216   "Return the list of jobs of evaluation EVALUATION-ID."
 217   (map json->job
 218        (vector->list
 219         (json->scm (http-fetch
 220                     (string-append url "/api/jobs?evaluation="
 221                                    (number->string evaluation-id)))))))
 222
 223 (define (build url id)
 224   "Look up build ID at URL and return it.  Raise &http-get-error if it is not
 225 found (404)."
 226   (json->build
 227    (http-fetch (string-append url "/build/"       ;note: no "/api" here
 228                               (number->string id)))))
 229
 230 (define (job-build url job)
 231   "Return the build associated with JOB."
 232   (build url (job-build-id job)))
 233
 234 ;; TODO: job history:
 235 ;; https://ci.guix.gnu.org/api/jobs/history?spec=master&names=coreutils.x86_64-linux&nr=10
 236
 237 (define (find-latest-commit-with-substitutes url)
 238   "Return the latest commit with available substitutes for the Guix package
 239 definitions at URL.  Return false if no commit were found."
 240   (let* ((job-name (string-append "guix." (%current-system)))
 241          (build (match (latest-builds url 1
 242                                       #:job job-name
 243                                       #:status 0) ;success
 244                   ((build) build)
 245                   (_ #f)))
 246          (evaluation (and build
 247                           (evaluation url (build-evaluation build))))
 248          (commit (and evaluation
 249                       (match (evaluation-checkouts evaluation)
 250                         ((checkout)
 251                          (checkout-commit checkout))))))
 252     commit))
 253
 254 (define (channel-with-substitutes-available chan url)
 255   "Return a channel inheriting from CHAN but which commit field is set to the
 256 latest commit with available substitutes for the Guix package definitions at
 257 URL.  The current system is taken into account.
 258
 259 If no commit with available substitutes were found, the commit field is set to
 260 false and a warning message is printed."
 261   (let ((commit (find-latest-commit-with-substitutes url)))
 262     (unless commit
 263       (warning (G_ "could not find available substitutes at ~a~%")
 264                url))
 265     (channel
 266      (inherit chan)
 267      (commit commit))))