blob: f091401000024d1bd925370fdd57041f264760e3 (
plain)
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
|
;;; Guix Build Coordinator
;;;
;;; Copyright © 2020 Christopher Baines <mail@cbaines.net>
;;;
;;; This file is part of the guix-build-coordinator.
;;;
;;; The Guix Build Coordinator 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.
;;;
;;; The Guix Build Coordinator 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 the guix-data-service. If not, see
;;; <http://www.gnu.org/licenses/>.
(define-module (guix-build-coordinator agent)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (ice-9 match)
#:use-module (rnrs bytevectors)
#:use-module (web http)
#:use-module (guix store)
#:use-module (guix derivations)
#:use-module (guix-build-coordinator utils)
#:use-module (guix-build-coordinator agent-messaging http)
#:export (run-agent))
(define (run-agent uuid coordinator-uri password)
(let* ((details (submit-status coordinator-uri uuid password
'idle))
(builds (let ((already-allocated-builds
(vector->list
(assoc-ref details "builds"))))
(if (null? already-allocated-builds)
(fetch-builds-for-agent
coordinator-uri uuid password)
already-allocated-builds))))
(for-each (lambda (build)
(let ((derivation-name (assoc-ref build "derivation-name")))
(pre-build-process derivation-name)
(let ((result (perform-build derivation-name)))
(post-build uuid coordinator-uri password
(assoc-ref build "uuid")
derivation-name))))
builds)))
(define (pre-build-process derivation-name)
(let ((derivation
(if (file-exists? derivation-name)
(read-derivation-from-file derivation-name)
(and (substitute-derivation derivation-name)
(read-derivation-from-file derivation-name)))))
(let* ((outputs (derivation-outputs derivation))
(output-file-names
(map derivation-output-path (map cdr outputs))))
(when (any file-exists? output-file-names)
(with-store store
(delete-paths store output-file-names)))
(let* ((inputs (derivation-inputs derivation))
(output-paths
(append-map derivation-input-output-paths inputs)))
(with-store store
(build-things store output-paths))))))
(define (perform-build derivation-name)
(with-store store
(set-build-options store
#:use-substitutes? #f)
(build-things store (list derivation-name))))
(define (post-build uuid coordinator-uri password
build-id derivation)
(for-each
(match-lambda
((output-name . output)
(submit-output coordinator-uri uuid password
build-id output-name
(derivation-output-path output))))
(derivation-outputs (read-derivation-from-file derivation))))
|