1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
4 ;;; This file is part of GNU Guix.
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.
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.
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/>.
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)
45 evaluation-for-commit))
49 ;;; This module provides a client to the HTTP interface of the Hydra and
50 ;;; Cuirass continuous integration (CI) tools.
54 (define-record-type <build>
55 (make-build id derivation system status timestamp)
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
63 (define-record-type <checkout>
64 (make-checkout commit input)
66 (commit checkout-commit) ;string (SHA1)
67 (input checkout-input)) ;string (name)
69 (define-record-type <evaluation>
70 (make-evaluation id spec complete? checkouts)
72 (id evaluation-id) ;integer
73 (spec evaluation-spec) ;string
74 (complete? evaluation-complete?) ;Boolean
75 (checkouts evaluation-checkouts)) ;<checkout>*
78 ;; Max number of builds requested in queries.
81 (define (json-fetch url)
82 (let* ((port (http-fetch url))
83 (json (json->scm port)))
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")))
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)))
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))
107 (string-append "&" name "=" (->string value))
110 (let ((latest (json-fetch (string-append url "/api/latestbuilds?nr="
111 (number->string limit)
112 (option "evaluation" evaluation
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)))
119 (define (json->checkout json)
120 (make-checkout (hash-ref json "commit")
121 (hash-ref json "input")))
123 (define (json->evaluation json)
124 (make-evaluation (hash-ref json "id")
125 (hash-ref json "specification")
126 (case (hash-ref json "in-progress")
129 (map json->checkout (hash-ref json "checkouts"))))
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
135 (http-fetch (string-append url "/api/evaluations?nr="
136 (number->string limit))))))
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)))