guix/ci.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2018, 2019, 2020 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 json)
  23   #:use-module (json)
  24   #:use-module (srfi srfi-1)
  25   #:use-module (ice-9 match)
  26   #:export (build-product?
  27             build-product-id
  28             build-product-type
  29             build-product-file-size
  30             build-product-path
  31
  32             build?
  33             build-id
  34             build-derivation
  35             build-system
  36             build-status
  37             build-timestamp
  38             build-products
  39
  40             checkout?
  41             checkout-commit
  42             checkout-input
  43
  44             evaluation?
  45             evaluation-id
  46             evaluation-spec
  47             evaluation-complete?
  48             evaluation-checkouts
  49
  50             %query-limit
  51             queued-builds
  52             latest-builds
  53             latest-evaluations
  54             evaluations-for-commit))
  55
  56 ;;; Commentary:
  57 ;;;
  58 ;;; This module provides a client to the HTTP interface of the Hydra and
  59 ;;; Cuirass continuous integration (CI) tools.
  60 ;;;
  61 ;;; Code:
  62
  63 (define-json-mapping <build-product> make-build-product
  64   build-product?
  65   json->build-product
  66   (id          build-product-id)                  ;integer
  67   (type        build-product-type)                ;string
  68   (file-size   build-product-file-size)           ;integer
  69   (path        build-product-path))               ;string
  70
  71 (define-json-mapping <build> make-build build?
  72   json->build
  73   (id          build-id "id")                     ;integer
  74   (derivation  build-derivation)                  ;string | #f
  75   (system      build-system)                      ;string
  76   (status      build-status "buildstatus" )       ;integer
  77   (timestamp   build-timestamp)                   ;integer
  78   (products    build-products "buildproducts"     ;<build-product>*
  79                (lambda (products)
  80                  (map json->build-product
  81                       ;; Before Cuirass 3db603c1, #f is always returned.
  82                       (if (vector? products)
  83                           (vector->list products)
  84                           '())))))
  85
  86 (define-json-mapping <checkout> make-checkout checkout?
  87   json->checkout
  88   (commit      checkout-commit)                   ;string (SHA1)
  89   (input       checkout-input))                   ;string (name)
  90
  91 (define-json-mapping <evaluation> make-evaluation evaluation?
  92   json->evaluation
  93   (id          evaluation-id)                     ;integer
  94   (spec        evaluation-spec "specification")   ;string
  95   (complete?   evaluation-complete? "in-progress"
  96                (match-lambda
  97                  (0 #t)
  98                  (_ #f)))                         ;Boolean
  99   (checkouts   evaluation-checkouts "checkouts"   ;<checkout>*
 100                (lambda (checkouts)
 101                  (map json->checkout
 102                       (vector->list checkouts)))))
 103
 104 (define %query-limit
 105   ;; Max number of builds requested in queries.
 106   1000)
 107
 108 (define (json-fetch url)
 109   (let* ((port (http-fetch url))
 110          (json (json->scm port)))
 111     (close-port port)
 112     json))
 113
 114 (define* (queued-builds url #:optional (limit %query-limit))
 115   "Return the list of queued derivations on URL."
 116   (let ((queue (json-fetch (string-append url "/api/queue?nr="
 117                                           (number->string limit)))))
 118     (map json->build (vector->list queue))))
 119
 120 (define* (latest-builds url #:optional (limit %query-limit)
 121                         #:key evaluation system job status)
 122   "Return the latest builds performed by the CI server at URL.  If EVALUATION
 123 is an integer, restrict to builds of EVALUATION.  If SYSTEM is true (a system
 124 string such as \"x86_64-linux\"), restrict to builds for SYSTEM."
 125   (define* (option name value #:optional (->string identity))
 126     (if value
 127         (string-append "&" name "=" (->string value))
 128         ""))
 129
 130   (let ((latest (json-fetch (string-append url "/api/latestbuilds?nr="
 131                                            (number->string limit)
 132                                            (option "evaluation" evaluation
 133                                                    number->string)
 134                                            (option "system" system)
 135                                            (option "job" job)
 136                                            (option "status" status
 137                                                    number->string)))))
 138     ;; Note: Hydra does not provide a "derivation" field for entries in
 139     ;; 'latestbuilds', but Cuirass does.
 140     (map json->build (vector->list latest))))
 141
 142 (define* (latest-evaluations url #:optional (limit %query-limit))
 143   "Return the latest evaluations performed by the CI server at URL."
 144   (map json->evaluation
 145        (vector->list
 146         (json->scm
 147          (http-fetch (string-append url "/api/evaluations?nr="
 148                                     (number->string limit)))))))
 149
 150
 151 (define* (evaluations-for-commit url commit #:optional (limit %query-limit))
 152   "Return the evaluations among the latest LIMIT evaluations that have COMMIT
 153 as one of their inputs."
 154   (filter (lambda (evaluation)
 155             (find (lambda (checkout)
 156                     (string=? (checkout-commit checkout) commit))
 157                   (evaluation-checkouts evaluation)))
 158           (latest-evaluations url limit)))