mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 21:38:07 -05:00
ci: Use (guix json) and adjust for Guile-JSON 3.x.
This is in part a followup to 81c3dc3224
.
* guix/ci.scm (<build>, <checkout>, <evaluation>): Define using
'define-json-mapping'.
(json->build, json->checkout, json->evaluation): Remove.
(queued-builds, latest-builds, latest-evaluations): Pass JSON arrays
through 'vector->list' to adjust for Guile-JSON 3.x.
(evaluations-for-commit): Fix typo to really export.
This commit is contained in:
parent
76073d29e1
commit
a85a74ce6c
1 changed files with 27 additions and 41 deletions
68
guix/ci.scm
68
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 @@ (define-module (guix ci)
|
|||
queued-builds
|
||||
latest-builds
|
||||
latest-evaluations
|
||||
evaluation-for-commit))
|
||||
evaluations-for-commit))
|
||||
|
||||
;;; Commentary:
|
||||
;;;
|
||||
|
@ -51,28 +52,31 @@ (define-module (guix ci)
|
|||
;;;
|
||||
;;; 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 @@ (define (json-fetch url)
|
|||
(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 @@ (define* (option name value #:optional (->string identity))
|
|||
(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))
|
||||
|
|
Loading…
Reference in a new issue