guix/ci.scm

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