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