kreyren/guix-kreyren
1
0
Fork 0
Code Issues 1 Pull Requests 1 Releases Activity

ci: Use (guix json) and adjust for Guile-JSON 3.x.

Browse Source 
This is in part a followup to 81c3dc32244a17241d74eea9fa265edfcb326f6d.

* 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:
Ludovic Courtès 2019-09-01 14:58:40 +02:00
parent 76073d29e1
commit a85a74ce6c
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
1 changed files with 27 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

68
guix/ci.scm
View File

@ -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))