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             %query-limit
  55             queued-builds
  56             latest-builds
  57             evaluation
  58             latest-evaluations
  59             evaluations-for-commit
  60
  61             channel-with-substitutes-available))
  62
  63 ;;; Commentary:
  64 ;;;
  65 ;;; This module provides a client to the HTTP interface of the Hydra and
  66 ;;; Cuirass continuous integration (CI) tools.
  67 ;;;
  68 ;;; Code:
  69
  70 (define-json-mapping <build-product> make-build-product
  71   build-product?
  72   json->build-product
  73   (id          build-product-id)                  ;integer
  74   (type        build-product-type)                ;string
  75   (file-size   build-product-file-size)           ;integer
  76   (path        build-product-path))               ;string
  77
  78 (define-syntax-rule (define-enumeration-mapping proc
  79                       (names integers) ...)
  80   (define (proc value)
  81     (match value
  82       (integers 'names) ...)))
  83
  84 (define-enumeration-mapping integer->build-status
  85   ;; Copied from 'build-status' in Cuirass.
  86   (submitted        -3)
  87   (scheduled        -2)
  88   (started          -1)
  89   (succeeded         0)
  90   (failed            1)
  91   (failed-dependency 2)
  92   (failed-other      3)
  93   (canceled          4))
  94
  95 (define-json-mapping <build> make-build build?
  96   json->build
  97   (id          build-id "id")                     ;integer
  98   (derivation  build-derivation)                  ;string | #f
  99   (evaluation  build-evaluation)                  ;integer
 100   (system      build-system)                      ;string
 101   (status      build-status "buildstatus"         ;symbol
 102                integer->build-status)
 103   (timestamp   build-timestamp)                   ;integer
 104   (products    build-products "buildproducts"     ;<build-product>*
 105                (lambda (products)
 106                  (map json->build-product
 107                       ;; Before Cuirass 3db603c1, #f is always returned.
 108                       (if (vector? products)
 109                           (vector->list products)
 110                           '())))))
 111
 112 (define-json-mapping <checkout> make-checkout checkout?
 113   json->checkout
 114   (commit      checkout-commit)                   ;string (SHA1)
 115   (channel     checkout-channel))                 ;string (name)
 116
 117 (define-json-mapping <evaluation> make-evaluation evaluation?
 118   json->evaluation
 119   (id          evaluation-id)                     ;integer
 120   (spec        evaluation-spec "specification")   ;string
 121   (complete?   evaluation-complete? "status"
 122                (match-lambda
 123                  (0 #t)
 124                  (_ #f)))                         ;Boolean
 125   (checkouts   evaluation-checkouts "checkouts"   ;<checkout>*
 126                (lambda (checkouts)
 127                  (map json->checkout
 128                       (vector->list checkouts)))))
 129
 130 (define %query-limit
 131   ;; Max number of builds requested in queries.
 132   1000)
 133
 134 (define (json-fetch url)
 135   (let* ((port (http-fetch url))
 136          (json (json->scm port)))
 137     (close-port port)
 138     json))
 139
 140 (define* (queued-builds url #:optional (limit %query-limit))
 141   "Return the list of queued derivations on URL."
 142   (let ((queue (json-fetch (string-append url "/api/queue?nr="
 143                                           (number->string limit)))))
 144     (map json->build (vector->list queue))))
 145
 146 (define* (latest-builds url #:optional (limit %query-limit)
 147                         #:key evaluation system job status)
 148   "Return the latest builds performed by the CI server at URL.  If EVALUATION
 149 is an integer, restrict to builds of EVALUATION.  If SYSTEM is true (a system
 150 string such as \"x86_64-linux\"), restrict to builds for SYSTEM."
 151   (define* (option name value #:optional (->string identity))
 152     (if value
 153         (string-append "&" name "=" (->string value))
 154         ""))
 155
 156   (let ((latest (json-fetch (string-append url "/api/latestbuilds?nr="
 157                                            (number->string limit)
 158                                            (option "evaluation" evaluation
 159                                                    number->string)
 160                                            (option "system" system)
 161                                            (option "job" job)
 162                                            (option "status" status
 163                                                    number->string)))))
 164     ;; Note: Hydra does not provide a "derivation" field for entries in
 165     ;; 'latestbuilds', but Cuirass does.
 166     (map json->build (vector->list latest))))
 167
 168 (define (evaluation url evaluation)
 169   "Return the given EVALUATION performed by the CI server at URL."
 170   (let ((evaluation (json-fetch
 171                      (string-append url "/api/evaluation?id="
 172                                     (number->string evaluation)))))
 173     (json->evaluation evaluation)))
 174
 175 (define* (latest-evaluations url
 176                              #:optional (limit %query-limit)
 177                              #:key spec)
 178   "Return the latest evaluations performed by the CI server at URL.  If SPEC
 179 is passed, only consider the evaluations for the given SPEC specification."
 180   (let ((spec (if spec
 181                   (format #f "&spec=~a" spec)
 182                   "")))
 183     (map json->evaluation
 184          (vector->list
 185           (json->scm
 186            (http-fetch
 187             (string-append url "/api/evaluations?nr="
 188                            (number->string limit)
 189                            spec)))))))
 190
 191 (define* (evaluations-for-commit url commit #:optional (limit %query-limit))
 192   "Return the evaluations among the latest LIMIT evaluations that have COMMIT
 193 as one of their inputs."
 194   (filter (lambda (evaluation)
 195             (find (lambda (checkout)
 196                     (string=? (checkout-commit checkout) commit))
 197                   (evaluation-checkouts evaluation)))
 198           (latest-evaluations url limit)))
 199
 200 (define (find-latest-commit-with-substitutes url)
 201   "Return the latest commit with available substitutes for the Guix package
 202 definitions at URL.  Return false if no commit were found."
 203   (let* ((job-name (string-append "guix." (%current-system)))
 204          (build (match (latest-builds url 1
 205                                       #:job job-name
 206                                       #:status 0) ;success
 207                   ((build) build)
 208                   (_ #f)))
 209          (evaluation (and build
 210                           (evaluation url (build-evaluation build))))
 211          (commit (and evaluation
 212                       (match (evaluation-checkouts evaluation)
 213                         ((checkout)
 214                          (checkout-commit checkout))))))
 215     commit))
 216
 217 (define (channel-with-substitutes-available chan url)
 218   "Return a channel inheriting from CHAN but which commit field is set to the
 219 latest commit with available substitutes for the Guix package definitions at
 220 URL.  The current system is taken into account.
 221
 222 If no commit with available substitutes were found, the commit field is set to
 223 false and a warning message is printed."
 224   (let ((commit (find-latest-commit-with-substitutes url)))
 225     (unless commit
 226       (warning (G_ "could not find available substitutes at ~a~%")
 227                url))
 228     (channel
 229      (inherit chan)
 230      (commit commit))))