me
/
guix
Archived
1
0
Fork 0
Code

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.
master
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 ;;; 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. ;;; This file is part of GNU Guix.
;;; ;;;
@ -18,9 +18,10 @@
(define-module (guix ci) (define-module (guix ci)
#:use-module (guix http-client) #: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-1)
#:use-module (srfi srfi-9) #:use-module (ice-9 match)
#:export (build? #:export (build?
build-id build-id
build-derivation build-derivation
@ -42,7 +43,7 @@
queued-builds queued-builds
latest-builds latest-builds
latest-evaluations latest-evaluations
evaluation-for-commit)) evaluations-for-commit))
;;; Commentary: ;;; Commentary:
;;; ;;;
@ -51,28 +52,31 @@
;;; ;;;
;;; Code: ;;; Code:
(define-record-type <build> (define-json-mapping <build> make-build build?
(make-build id derivation system status timestamp) json->build
build? (id build-id "id") ;integer
(id build-id) ;integer
(derivation build-derivation) ;string | #f (derivation build-derivation) ;string | #f
(system build-system) ;string (system build-system) ;string
(status build-status) ;integer (status build-status "buildstatus" ) ;integer
(timestamp build-timestamp)) ;integer (timestamp build-timestamp)) ;integer
(define-record-type <checkout> (define-json-mapping <checkout> make-checkout checkout?
(make-checkout commit input) json->checkout
checkout?
(commit checkout-commit) ;string (SHA1) (commit checkout-commit) ;string (SHA1)
(input checkout-input)) ;string (name) (input checkout-input)) ;string (name)
(define-record-type <evaluation> (define-json-mapping <evaluation> make-evaluation evaluation?
(make-evaluation id spec complete? checkouts) json->evaluation
evaluation?
(id evaluation-id) ;integer (id evaluation-id) ;integer
(spec evaluation-spec) ;string (spec evaluation-spec) ;string
(complete? evaluation-complete?) ;Boolean (complete? evaluation-complete? "in-progress"
(checkouts evaluation-checkouts)) ;<checkout>* (match-lambda
(0 #t)
(_ #f))) ;Boolean
(checkouts evaluation-checkouts "checkouts" ;<checkout>*
(lambda (checkouts)
(map json->checkout
(vector->list checkouts)))))
(define %query-limit (define %query-limit
;; Max number of builds requested in queries. ;; Max number of builds requested in queries.
@ -84,18 +88,11 @@
(close-port port) (close-port port)
json)) 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)) (define* (queued-builds url #:optional (limit %query-limit))
"Return the list of queued derivations on URL." "Return the list of queued derivations on URL."
(let ((queue (json-fetch (string-append url "/api/queue?nr=" (let ((queue (json-fetch (string-append url "/api/queue?nr="
(number->string limit))))) (number->string limit)))))
(map json->build queue))) (map json->build (vector->list queue))))
(define* (latest-builds url #:optional (limit %query-limit) (define* (latest-builds url #:optional (limit %query-limit)
#:key evaluation system) #:key evaluation system)
@ -114,26 +111,15 @@ string such as \"x86_64-linux\"), restrict to builds for SYSTEM."
(option "system" system))))) (option "system" system)))))
;; Note: Hydra does not provide a "derivation" field for entries in ;; Note: Hydra does not provide a "derivation" field for entries in
;; 'latestbuilds', but Cuirass does. ;; 'latestbuilds', but Cuirass does.
(map json->build latest))) (map json->build (vector->list 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"))))
(define* (latest-evaluations url #:optional (limit %query-limit)) (define* (latest-evaluations url #:optional (limit %query-limit))
"Return the latest evaluations performed by the CI server at URL." "Return the latest evaluations performed by the CI server at URL."
(map json->evaluation (map json->evaluation
(json->scm (vector->list
(http-fetch (string-append url "/api/evaluations?nr=" (json->scm
(number->string limit)))))) (http-fetch (string-append url "/api/evaluations?nr="
(number->string limit)))))))
(define* (evaluations-for-commit url commit #:optional (limit %query-limit)) (define* (evaluations-for-commit url commit #:optional (limit %query-limit))