guix/ci.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (guix ci)
  20   #:use-module (guix http-client)
  21   #:use-module (guix json)
  22   #:use-module (json)
  23   #:use-module (srfi srfi-1)
  24   #:use-module (ice-9 match)
  25   #:export (build?
  26             build-id
  27             build-derivation
  28             build-system
  29             build-status
  30             build-timestamp
  31
  32             checkout?
  33             checkout-commit
  34             checkout-input
  35
  36             evaluation?
  37             evaluation-id
  38             evaluation-spec
  39             evaluation-complete?
  40             evaluation-checkouts
  41
  42             %query-limit
  43             queued-builds
  44             latest-builds
  45             latest-evaluations
  46             evaluations-for-commit))
  47
  48 ;;; Commentary:
  49 ;;;
  50 ;;; This module provides a client to the HTTP interface of the Hydra and
  51 ;;; Cuirass continuous integration (CI) tools.
  52 ;;;
  53 ;;; Code:
  54
  55 (define-json-mapping <build> make-build build?
  56   json->build
  57   (id          build-id "id")                     ;integer
  58   (derivation  build-derivation)                  ;string | #f
  59   (system      build-system)                      ;string
  60   (status      build-status "buildstatus" )       ;integer
  61   (timestamp   build-timestamp))                  ;integer
  62
  63 (define-json-mapping <checkout> make-checkout checkout?
  64   json->checkout
  65   (commit      checkout-commit)                   ;string (SHA1)
  66   (input       checkout-input))                   ;string (name)
  67
  68 (define-json-mapping <evaluation> make-evaluation evaluation?
  69   json->evaluation
  70   (id          evaluation-id)                     ;integer
  71   (spec        evaluation-spec)                   ;string
  72   (complete?   evaluation-complete? "in-progress"
  73                (match-lambda
  74                  (0 #t)
  75                  (_ #f)))                         ;Boolean
  76   (checkouts   evaluation-checkouts "checkouts"   ;<checkout>*
  77                (lambda (checkouts)
  78                  (map json->checkout
  79                       (vector->list checkouts)))))
  80
  81 (define %query-limit
  82   ;; Max number of builds requested in queries.
  83   1000)
  84
  85 (define (json-fetch url)
  86   (let* ((port (http-fetch url))
  87          (json (json->scm port)))
  88     (close-port port)
  89     json))
  90
  91 (define* (queued-builds url #:optional (limit %query-limit))
  92   "Return the list of queued derivations on URL."
  93   (let ((queue (json-fetch (string-append url "/api/queue?nr="
  94                                           (number->string limit)))))
  95     (map json->build (vector->list queue))))
  96
  97 (define* (latest-builds url #:optional (limit %query-limit)
  98                         #:key evaluation system)
  99   "Return the latest builds performed by the CI server at URL.  If EVALUATION
 100 is an integer, restrict to builds of EVALUATION.  If SYSTEM is true (a system
 101 string such as \"x86_64-linux\"), restrict to builds for SYSTEM."
 102   (define* (option name value #:optional (->string identity))
 103     (if value
 104         (string-append "&" name "=" (->string value))
 105         ""))
 106
 107   (let ((latest (json-fetch (string-append url "/api/latestbuilds?nr="
 108                                            (number->string limit)
 109                                            (option "evaluation" evaluation
 110                                                    number->string)
 111                                            (option "system" system)))))
 112     ;; Note: Hydra does not provide a "derivation" field for entries in
 113     ;; 'latestbuilds', but Cuirass does.
 114     (map json->build (vector->list latest))))
 115
 116 (define* (latest-evaluations url #:optional (limit %query-limit))
 117   "Return the latest evaluations performed by the CI server at URL."
 118   (map json->evaluation
 119        (vector->list
 120         (json->scm
 121          (http-fetch (string-append url "/api/evaluations?nr="
 122                                     (number->string limit)))))))
 123
 124
 125 (define* (evaluations-for-commit url commit #:optional (limit %query-limit))
 126   "Return the evaluations among the latest LIMIT evaluations that have COMMIT
 127 as one of their inputs."
 128   (filter (lambda (evaluation)
 129             (find (lambda (checkout)
 130                     (string=? (checkout-commit checkout) commit))
 131                   (evaluation-checkouts evaluation)))
 132           (latest-evaluations url limit)))