;;; 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)
                                  " "))))

  (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?
        (mlambda (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")
            ;; If all outputs have had at least one successful build, then the
            ;; inputs should be available. Otherwise, treat the setup failure
            ;; as still relevant (return #t)
            (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)))