1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
|
;;; build-farm-url.el --- Build farm URLs -*- lexical-binding: t -*-
;; Copyright © 2015–2018 Alex Kost <alezost@gmail.com>
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; This file provides the code to determine various URLs of the build
;; farms and to receive data from them.
;;; Code:
(require 'url-handlers)
(require 'url-expand)
(require 'json)
(require 'build-farm-utils)
(defvar build-farm-url-alist
'(("https://hydra.nixos.org" . hydra)
("https://hydra.gnu.org" . hydra)
("https://berlin.guixsd.org" . cuirass))
"Alist of URLs and their types of the available build farms.")
(defun build-farm-guess-url ()
"Return URL of a build farm that a user probably wants to use."
(if (eq 'guix build-farm-preferred-package-manager)
"https://hydra.gnu.org"
"https://hydra.nixos.org"))
(defun build-farm-urls ()
"Return a list of available build farm URLs."
(mapcar #'car build-farm-url-alist))
(defcustom build-farm-url (build-farm-guess-url)
"URL of the default build farm."
:type `(choice ,@(mapcar (lambda (url) (list 'const url))
(build-farm-urls))
(string :tag "Other URL"))
:group 'build-farm)
(defun build-farm-read-url ()
"Read from minibuffer and return build farm URL."
(completing-read "Build farm URL: "
(build-farm-urls)
nil nil nil nil
build-farm-url))
;;;###autoload
(defun build-farm-set-url (url)
"Set variable `build-farm-url' to URL.
Interactively, prompt for URL."
(interactive (list (build-farm-read-url)))
(setq build-farm-url url))
(defun build-farm-url-type (&optional url)
"Return build farm type by its URL.
If URL is nil, use variable `build-farm-url'."
(or (bui-assoc-value build-farm-url-alist
(or url build-farm-url))
(let ((type (if (string-match-p "cuirass" url)
'cuirass
'hydra)))
(message "Unknown URL: <%s>.
Consider adding it to `build-farm-url-alist'.
Arbitrarily choosing `%S' type for this URL."
url type)
type)))
(defun build-farm-url-package-manager (&optional url)
"Return a package manager for the build farm URL.
The returned value is either `nix' or `guix' symbols or nil, if
the package manager cannot be determined.
If URL is nil, use variable `build-farm-url'."
(or url (setq url build-farm-url))
(cond ((or (string-match-p (regexp-opt '("gnu" "guix")) url)
(eq 'cuirass (build-farm-url-type url)))
'guix)
((string-match-p "nix" url)
'nix)))
(defun build-farm-url (&optional root-url &rest url-parts)
"Return build farm ROOT-URL with URL-PARTS concatenated to it.
If ROOT-URL is nil, use variable `build-farm-url'."
(url-expand-file-name (mapconcat #'identity url-parts "")
(or root-url build-farm-url)))
(cl-defun build-farm-api-url (type args &key root-url)
"Return URL for receiving data using build farm API.
See function `build-farm-url' for the meaning of ROOT-URL.
TYPE is the name of an allowed method.
ARGS is alist of (KEY . VALUE) pairs.
Skip ARG, if VALUE is nil or an empty string."
(let* ((fields (mapcar
(lambda (arg)
(pcase arg
(`(,key . ,value)
(unless (or (null value)
(equal "" value))
(concat (build-farm-hexify key) "="
(build-farm-hexify value))))
(_ (error "Wrong argument '%s'" arg))))
args))
(fields (mapconcat #'identity (delq nil fields) "&")))
(build-farm-url root-url "api/" type "?" fields)))
(cl-defun build-farm-build-url (id &key root-url)
"Return URL of a build ID.
See function `build-farm-url' for the meaning of ROOT-URL."
(build-farm-url root-url "build/" (number-to-string id)))
(cl-defun build-farm-build-log-url (id &key root-url raw)
"Return URL of the build log of a build ID.
If RAW is non-nil, return url of the raw build log file.
See function `build-farm-url' for the meaning of ROOT-URL."
(concat (build-farm-build-url id :root-url root-url)
"/log"
(if raw "/raw" "")))
(cl-defun build-farm-build-latest-api-url
(number &key root-url project jobset job system)
"Return API URL to receive latest NUMBER of builds.
See function `build-farm-url' for the meaning of ROOT-URL."
(build-farm-api-url
"latestbuilds"
`(("nr" . ,number)
("project" . ,project)
("jobset" . ,jobset)
("job" . ,job)
("system" . ,system))
:root-url root-url))
(cl-defun build-farm-build-queue-api-url (number &key root-url)
"Return API URL to receive the NUMBER of queued builds.
See function `build-farm-url' for the meaning of ROOT-URL."
(build-farm-api-url
"queue"
`(("nr" . ,number))
:root-url root-url))
(cl-defun build-farm-jobset-url (&key root-url project jobset jobset-id)
"Return URL of a PROJECT's JOBSET.
Above that, you should specify either a single JOBSET-ID
argument (it should have a form 'project/jobset') or PROJECT and
JOBSET arguments.
See function `build-farm-url' for the meaning of ROOT-URL."
(build-farm-url root-url "/jobset/"
(or jobset-id
(concat project "/" jobset))))
(cl-defun build-farm-jobset-api-url (project &key root-url)
"Return API URL for jobsets by PROJECT.
See function `build-farm-url' for the meaning of ROOT-URL."
(build-farm-api-url
"jobsets"
`(("project" . ,project))
:root-url root-url))
(cl-defun build-farm-project-url (&key root-url project)
"Return URL with build farm PROJECT.
If PROJECT is nil, return URL with all projects.
See function `build-farm-url' for the meaning of ROOT-URL."
(if project
(build-farm-url root-url "project/" project)
(build-farm-url root-url)))
;;; Receiving data from a build farm
(defvar url-http-codes)
(defun build-farm-retrieve-url (url)
"Retrieve URL synchronously and return buffer containing the data.
This function is similar to `url-retrieve-synchronously' but it
also raises an error if URL has not been retrieved properly."
;; This code is taken from `url-insert-file-contents'.
(let ((buffer (url-retrieve-synchronously url)))
(unless buffer
(signal 'file-error (list url "No Data")))
(with-current-buffer buffer
(when (bound-and-true-p url-http-response-status)
(unless (and (>= url-http-response-status 200)
(< url-http-response-status 300))
(let ((desc (nth 2 (assq url-http-response-status
url-http-codes))))
(kill-buffer buffer)
(signal 'file-error (list url desc))))))
buffer))
(defun build-farm-receive-data (url)
"Return output received from URL and processed with `json-read'."
(let* ((url-request-extra-headers '(("Accept" . "application/json")))
(url-buffer (build-farm-retrieve-url url))
(content-type (buffer-local-value 'url-http-content-type
url-buffer)))
;; Do not use `string=' here because the content type may look like
;; this: "application/json;charset=utf-8".
(unless (string-match-p "application/json" content-type)
;; Currently Cuirass does not support "Accept" extra header, so it
;; does not return json data from "non-api" URLs.
(if (eq (build-farm-url-type) 'cuirass)
(error "Sorry, Cuirass does not support this API")
(error "\
The server has not returned 'application/json' content type.
Perhaps, API has changed:\n%s"
url)))
(with-temp-buffer
(url-insert-buffer-contents url-buffer url)
(goto-char (point-min))
(let ((json-false nil) ; default value is `:json-false'
(json-key-type 'symbol)
(json-array-type 'list)
(json-object-type 'alist))
(json-read)))))
(provide 'build-farm-url)
;;; build-farm-url.el ends here
|
