You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

158 lines
6.0 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
  3. ;;; Copyright © 2020 Mathieu Othacehe <othacehe@gnu.org>
  4. ;;;
  5. ;;; This file is part of GNU Guix.
  6. ;;;
  7. ;;; GNU Guix is free software; you can redistribute it and/or modify it
  8. ;;; under the terms of the GNU General Public License as published by
  9. ;;; the Free Software Foundation; either version 3 of the License, or (at
  10. ;;; your option) any later version.
  11. ;;;
  12. ;;; GNU Guix is distributed in the hope that it will be useful, but
  13. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  15. ;;; GNU General Public License for more details.
  16. ;;;
  17. ;;; You should have received a copy of the GNU General Public License
  18. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
  19. (define-module (guix ci)
  20. #:use-module (guix http-client)
  21. #:use-module (guix json)
  22. #:use-module (json)
  23. #:use-module (srfi srfi-1)
  24. #:use-module (ice-9 match)
  25. #:export (build-product?
  26. build-product-id
  27. build-product-type
  28. build-product-file-size
  29. build-product-path
  30. build?
  31. build-id
  32. build-derivation
  33. build-system
  34. build-status
  35. build-timestamp
  36. build-products
  37. checkout?
  38. checkout-commit
  39. checkout-input
  40. evaluation?
  41. evaluation-id
  42. evaluation-spec
  43. evaluation-complete?
  44. evaluation-checkouts
  45. %query-limit
  46. queued-builds
  47. latest-builds
  48. latest-evaluations
  49. evaluations-for-commit))
  50. ;;; Commentary:
  51. ;;;
  52. ;;; This module provides a client to the HTTP interface of the Hydra and
  53. ;;; Cuirass continuous integration (CI) tools.
  54. ;;;
  55. ;;; Code:
  56. (define-json-mapping <build-product> make-build-product
  57. build-product?
  58. json->build-product
  59. (id build-product-id) ;integer
  60. (type build-product-type) ;string
  61. (file-size build-product-file-size) ;integer
  62. (path build-product-path)) ;string
  63. (define-json-mapping <build> make-build build?
  64. json->build
  65. (id build-id "id") ;integer
  66. (derivation build-derivation) ;string | #f
  67. (system build-system) ;string
  68. (status build-status "buildstatus" ) ;integer
  69. (timestamp build-timestamp) ;integer
  70. (products build-products "buildproducts" ;<build-product>*
  71. (lambda (products)
  72. (map json->build-product
  73. ;; Before Cuirass 3db603c1, #f is always returned.
  74. (if (vector? products)
  75. (vector->list products)
  76. '())))))
  77. (define-json-mapping <checkout> make-checkout checkout?
  78. json->checkout
  79. (commit checkout-commit) ;string (SHA1)
  80. (input checkout-input)) ;string (name)
  81. (define-json-mapping <evaluation> make-evaluation evaluation?
  82. json->evaluation
  83. (id evaluation-id) ;integer
  84. (spec evaluation-spec "specification") ;string
  85. (complete? evaluation-complete? "in-progress"
  86. (match-lambda
  87. (0 #t)
  88. (_ #f))) ;Boolean
  89. (checkouts evaluation-checkouts "checkouts" ;<checkout>*
  90. (lambda (checkouts)
  91. (map json->checkout
  92. (vector->list checkouts)))))
  93. (define %query-limit
  94. ;; Max number of builds requested in queries.
  95. 1000)
  96. (define (json-fetch url)
  97. (let* ((port (http-fetch url))
  98. (json (json->scm port)))
  99. (close-port port)
  100. json))
  101. (define* (queued-builds url #:optional (limit %query-limit))
  102. "Return the list of queued derivations on URL."
  103. (let ((queue (json-fetch (string-append url "/api/queue?nr="
  104. (number->string limit)))))
  105. (map json->build (vector->list queue))))
  106. (define* (latest-builds url #:optional (limit %query-limit)
  107. #:key evaluation system job status)
  108. "Return the latest builds performed by the CI server at URL. If EVALUATION
  109. is an integer, restrict to builds of EVALUATION. If SYSTEM is true (a system
  110. string such as \"x86_64-linux\"), restrict to builds for SYSTEM."
  111. (define* (option name value #:optional (->string identity))
  112. (if value
  113. (string-append "&" name "=" (->string value))
  114. ""))
  115. (let ((latest (json-fetch (string-append url "/api/latestbuilds?nr="
  116. (number->string limit)
  117. (option "evaluation" evaluation
  118. number->string)
  119. (option "system" system)
  120. (option "job" job)
  121. (option "status" status
  122. number->string)))))
  123. ;; Note: Hydra does not provide a "derivation" field for entries in
  124. ;; 'latestbuilds', but Cuirass does.
  125. (map json->build (vector->list latest))))
  126. (define* (latest-evaluations url #:optional (limit %query-limit))
  127. "Return the latest evaluations performed by the CI server at URL."
  128. (map json->evaluation
  129. (vector->list
  130. (json->scm
  131. (http-fetch (string-append url "/api/evaluations?nr="
  132. (number->string limit)))))))
  133. (define* (evaluations-for-commit url commit #:optional (limit %query-limit))
  134. "Return the evaluations among the latest LIMIT evaluations that have COMMIT
  135. as one of their inputs."
  136. (filter (lambda (evaluation)
  137. (find (lambda (checkout)
  138. (string=? (checkout-commit checkout) commit))
  139. (evaluation-checkouts evaluation)))
  140. (latest-evaluations url limit)))