summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--guix/ci.scm68
1 files changed, 27 insertions, 41 deletions
diff --git a/guix/ci.scm b/guix/ci.scm
index 1727297dd7..9e21996023 100644
--- a/guix/ci.scm
+++ b/guix/ci.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -18,9 +18,10 @@
(define-module (guix ci)
#:use-module (guix http-client)
- #:autoload (json parser) (json->scm)
+ #:use-module (guix json)
+ #:use-module (json)
#:use-module (srfi srfi-1)
- #:use-module (srfi srfi-9)
+ #:use-module (ice-9 match)
#:export (build?
build-id
build-derivation
@@ -42,7 +43,7 @@
queued-builds
latest-builds
latest-evaluations
- evaluation-for-commit))
+ evaluations-for-commit))
;;; Commentary:
;;;
@@ -51,28 +52,31 @@
;;;
;;; Code:
-(define-record-type <build>
- (make-build id derivation system status timestamp)
- build?
- (id build-id) ;integer
+(define-json-mapping <build> make-build build?
+ json->build
+ (id build-id "id") ;integer
(derivation build-derivation) ;string | #f
(system build-system) ;string
- (status build-status) ;integer
+ (status build-status "buildstatus" ) ;integer
(timestamp build-timestamp)) ;integer
-(define-record-type <checkout>
- (make-checkout commit input)
- checkout?
+(define-json-mapping <checkout> make-checkout checkout?
+ json->checkout
(commit checkout-commit) ;string (SHA1)
(input checkout-input)) ;string (name)
-(define-record-type <evaluation>
- (make-evaluation id spec complete? checkouts)
- evaluation?
+(define-json-mapping <evaluation> make-evaluation evaluation?
+ json->evaluation
(id evaluation-id) ;integer
(spec evaluation-spec) ;string
- (complete? evaluation-complete?) ;Boolean
- (checkouts evaluation-checkouts)) ;<checkout>*
+ (complete? evaluation-complete? "in-progress"
+ (match-lambda
+ (0 #t)
+ (_ #f))) ;Boolean
+ (checkouts evaluation-checkouts "checkouts" ;<checkout>*
+ (lambda (checkouts)
+ (map json->checkout
+ (vector->list checkouts)))))
(define %query-limit
;; Max number of builds requested in queries.
@@ -84,18 +88,11 @@
(close-port port)
json))
-(define (json->build json)
- (make-build (hash-ref json "id")
- (hash-ref json "derivation")
- (hash-ref json "system")
- (hash-ref json "buildstatus")
- (hash-ref json "timestamp")))
-
(define* (queued-builds url #:optional (limit %query-limit))
"Return the list of queued derivations on URL."
(let ((queue (json-fetch (string-append url "/api/queue?nr="
(number->string limit)))))
- (map json->build queue)))
+ (map json->build (vector->list queue))))
(define* (latest-builds url #:optional (limit %query-limit)
#:key evaluation system)
@@ -114,26 +111,15 @@ string such as \"x86_64-linux\"), restrict to builds for SYSTEM."
(option "system" system)))))
;; Note: Hydra does not provide a "derivation" field for entries in
;; 'latestbuilds', but Cuirass does.
- (map json->build latest)))
-
-(define (json->checkout json)
- (make-checkout (hash-ref json "commit")
- (hash-ref json "input")))
-
-(define (json->evaluation json)
- (make-evaluation (hash-ref json "id")
- (hash-ref json "specification")
- (case (hash-ref json "in-progress")
- ((0) #t)
- (else #f))
- (map json->checkout (hash-ref json "checkouts"))))
+ (map json->build (vector->list latest))))
(define* (latest-evaluations url #:optional (limit %query-limit))
"Return the latest evaluations performed by the CI server at URL."
(map json->evaluation
- (json->scm
- (http-fetch (string-append url "/api/evaluations?nr="
- (number->string limit))))))
+ (vector->list
+ (json->scm
+ (http-fetch (string-append url "/api/evaluations?nr="
+ (number->string limit)))))))
(define* (evaluations-for-commit url commit #:optional (limit %query-limit))