path: root/guix-build-coordinator/build-allocator.scm

;;; 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 memoization)
  #: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)
                                  " "))))

  (define cached/list-builds-for-output
    (mlambda (output)
      (datastore-list-builds-for-output datastore output)))

  (let* ((agents (datastore-list-agents datastore))
         (builds (datastore-list-unprocessed-builds datastore))
         (setup-failures-hash
          (datastore-fetch-setup-failures datastore))
         (derived-build-priorities-hash
          ;; Mapping from build_id to priority, initialised at the individual
          ;; priorities for the builds
          (let ((table (make-hash-table (length builds))))
            (for-each (lambda (build)
                        (hash-set! table
                                   (assq-ref build 'uuid)
                                   (assq-ref build 'priority)))
                      builds)
            table))
         ;; build_id -> (list build_id ...) indicating that for the build_id
         ;; used as the key, the build_ids given as the value should happen
         ;; first.
         (build-ordering-hints-hash
          (make-hash-table)))

    (define (filter-builds-for-agent agent-id)
      (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")
            ;; missing_inputs setup failures that should be resolved have been
            ;; filtered out by this point, so this is a relevant setup failure
            #t)
           ((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 (hash-ref derived-build-priorities-hash
                                    (assq-ref a 'uuid)))
              (b-priority (hash-ref derived-build-priorities-hash
                                    (assq-ref b 'uuid))))
          (< 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))

    (define (break-builds-in-to-priority-sublists all-builds)
      (define (build-priority build)
        (hash-ref derived-build-priorities-hash
                  (assq-ref build 'uuid)))

      (let loop ((result '())
                 (builds all-builds)
                 (current-priority-builds '())
                 (current-priority (build-priority (first all-builds))))
        (if (null? builds)
            (reverse (cons current-priority-builds result))
            (let ((build (car builds)))
              (if (= (build-priority build)
                     current-priority)
                  (loop result
                        (cdr builds)
                        (cons build current-priority-builds)
                        current-priority)
                  (loop (cons current-priority-builds result)
                        (cdr builds)
                        (list build)
                        (build-priority build)))))))

    (define (sort-priority-sublist builds-list)
      (define (build-id build)
        (assq-ref build 'uuid))

      (define (builds-that-should-happen-first build-id)
        (hash-ref build-ordering-hints-hash
                  build-id
                  '()))

      (define seen-builds-hash
        (make-hash-table))

      (define deferred-builds-last-count 0)

      (let loop ((result '())
                 (builds builds-list)
                 (builds-to-defer '()))
        (if (null? builds)
            (if (null? builds-to-defer)
                result
                (if (= (length builds-to-defer)
                       deferred-builds-last-count)
                    ;; There can be loops in the graph of missing inputs, so
                    ;; give up if the ordering doesn't seem to end
                    (append result builds-to-defer)
                    (begin (set! deferred-builds-last-count
                             (length builds-to-defer))
                           (loop result
                                 builds-to-defer
                                 '()))))
            (let ((build (car builds)))
              (if (every (lambda (required-build-id)
                           (hash-ref seen-builds-hash required-build-id))
                         (builds-that-should-happen-first (build-id build)))
                  (begin
                    (hash-set! seen-builds-hash (build-id build) #t)
                    (loop (cons build result)
                          (cdr builds)
                          builds-to-defer))
                  (loop result
                        (cdr builds)
                        (cons build builds-to-defer)))))))

    ;; Go through the setup failures and look specifically at the
    ;; missing_inputs ones. Eliminate any missing_inputs failures if all the
    ;; missing inputs appear to have been built successfully, and update the
    ;; derived-build-priorities-hash to reflect the priorities of builds based
    ;; on the builds that would be "unblocked" if they were completed.
    (for-each
     (lambda (setup-failure-build-id)
       (let ((setup-failures (hash-ref setup-failures-hash
                                       setup-failure-build-id))
             (setup-failure-build-derived-priority
              (hash-ref derived-build-priorities-hash
                        setup-failure-build-id)))
         (for-each
          (lambda (setup-failure)
            (when (string=? "missing_inputs"
                            (assq-ref setup-failure 'failure-reason))
              (for-each
               (lambda (output)
                 (let ((builds (cached/list-builds-for-output output)))
                   (if (any (lambda (output-build)
                              (string=? (or (assq-ref output-build 'result)
                                            "unknown")
                                        "success"))
                            builds)
                       ;; At least one build for this output has been successful,
                       ;; so delete the setup failure
                       (hash-remove! setup-failures-hash
                                     setup-failure-build-id)
                       ;; The missing input isn't available, so set the derived
                       ;; priority to be as least as high as this build
                       (for-each
                        (lambda (build)
                          (when (eq? 0 (assq-ref build 'processed))
                            (let* ((missing-input-build-id
                                    (assq-ref build 'uuid))
                                   (missing-input-build-derived-priority
                                    (hash-ref derived-build-priorities-hash
                                              missing-input-build-id)))
                              ;; Add an entry to the build-ordering-hints-hash
                              ;; to indicate that missing-input-build-id
                              ;; should happen prior to setup-failure-build-id
                              (hash-set!
                               build-ordering-hints-hash
                               setup-failure-build-id
                               (hash-ref build-ordering-hints-hash
                                         setup-failure-build-id
                                         '()))

                              (when (> setup-failure-build-derived-priority
                                       missing-input-build-derived-priority)
                                ;; Bump the priority of the build
                                (hash-set!
                                 derived-build-priorities-hash
                                 missing-input-build-id
                                 setup-failure-build-derived-priority)))))
                        builds))))
               (datastore-list-setup-failure-missing-inputs
                datastore
                (assq-ref setup-failure 'id)))))
          setup-failures)))
     (hash-map->list
      (lambda (key value) key)
      setup-failures-hash))

    (let ((result
           (append-map
            (lambda (agent-id)
              (log "considering builds for" agent-id)
              (let ((builds-sorted-by-derived-priority
                     (sort (filter (filter-builds-for-agent agent-id)
                                   builds)
                           (build-sorting-function-for-agent agent-id))))
                (if (null? builds-sorted-by-derived-priority)
                    '()
                    (let ((final-ordered-builds
                           (concatenate
                            (map sort-priority-sublist
                                 (break-builds-in-to-priority-sublists
                                  builds-sorted-by-derived-priority)))))
                      (let ((builds-for-agent
                             (limit-planned-builds final-ordered-builds)))
                        (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)))