blob: 49868a3a1bfbb21cd9f0ab155166edc83d959858 (
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
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
|
;;; 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 build-allocator)
#:use-module (srfi srfi-1)
#:use-module (guix-build-coordinator datastore)
#:use-module (guix-build-coordinator coordinator)
#:export (basic-build-allocation-strategy))
(define* (basic-build-allocation-strategy datastore
#:key
(planned-builds-for-agent-limit 2048))
(define (log . args)
(when #f
(simple-format #t "allocator: ~A\n"
(string-join (map (lambda (arg)
(simple-format #f "~A" arg))
args)
" "))))
(let ((agents (datastore-list-agents datastore))
(builds (datastore-list-unprocessed-builds datastore))
(setup-failures-hash
(datastore-fetch-setup-failures datastore)))
(define (filter-builds-for-agent agent-id)
(define (output-has-successful-build? output)
(log "considering missing input:" output)
(any (lambda (output-build)
(let ((build-successful?
(string=? (or (assq-ref output-build 'result)
"unknown")
"success")))
(when build-successful?
(log "found successful build:" (assq-ref output-build 'uuid)))
build-successful?))
(datastore-list-builds-for-output datastore output)))
(define (relevant-setup-failure? setup-failure)
(log "setup failure:" setup-failure)
(let ((failure-reason
(assq-ref setup-failure 'failure-reason)))
(cond
((string=? failure-reason "missing_inputs")
(not
(every output-has-successful-build?
(datastore-list-setup-failure-missing-inputs
datastore
(assq-ref setup-failure 'id)))))
((string=? failure-reason "could_not_delete_outputs")
;; This problem might go away, but just don't try the same agent
;; again for now.
(string=? (assq-ref setup-failure 'agent-id)
agent-id))
(else
(error "Unknown setup failure " failure-reason)))))
(lambda (build)
(log "build:" (assq-ref build 'uuid))
(let* ((build-id (assq-ref build 'uuid))
(setup-failures-for-build
(or (hash-ref setup-failures-hash build-id)
'()))
(relevant-setup-failures
(filter relevant-setup-failure?
setup-failures-for-build)))
(log "relevant setup failures:" relevant-setup-failures)
(if (null? relevant-setup-failures)
#t
#f))))
(define (build-sorting-function-for-agent agent-id)
(lambda (a b)
(let ((a-priority (assq-ref a 'priority))
(b-priority (assq-ref b 'priority)))
(< b-priority a-priority))))
(define (limit-planned-builds builds)
(if planned-builds-for-agent-limit
(if (> (length builds) planned-builds-for-agent-limit)
(take builds planned-builds-for-agent-limit)
builds)
builds))
(let ((result
(append-map
(lambda (agent-id)
(log "considering builds for" agent-id)
(let ((builds-for-agent
(limit-planned-builds
(sort (filter (filter-builds-for-agent agent-id)
builds)
(build-sorting-function-for-agent agent-id)))))
(map (lambda (build-id ordering)
(list build-id
agent-id
ordering))
(map (lambda (build)
(assq-ref build 'uuid))
builds-for-agent)
(iota (length builds-for-agent)))))
(map (lambda (agent)
(assq-ref agent 'uuid))
agents))))
(log "finished")
result)))
|