;;; 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 coordinator)
  #:use-module (srfi srfi-1)
  #:use-module (ice-9 match)
  #:use-module (gcrypt random)
  #:use-module (guix derivations)
  #:use-module (guix-build-coordinator utils)
  #:use-module (guix-build-coordinator config)
  #:use-module (guix-build-coordinator datastore)
  #:export (submit-build
            new-agent
            new-agent-password
            fetch-builds
            agent-details

            build-output-file-location))

(define* (submit-build datastore derivation-file
                       #:key
                       requested-uuid
                       (priority 0))
  (unless (file-exists? derivation-file)
    (substitute-derivation derivation-file))

  (let ((derivation
         (read-derivation-from-file derivation-file))
        (uuid
         (or requested-uuid (random-v4-uuid))))

    (datastore-store-derivation datastore derivation)

    (datastore-store-build datastore
                           derivation-file
                           uuid
                           priority)

    (allocate-builds datastore)

    uuid))

(define* (new-agent datastore
                    #:key
                    requested-uuid
                    description)
  (let ((uuid (or requested-uuid
                  (random-v4-uuid))))
    (datastore-new-agent datastore
                         uuid
                         description)

    uuid))

(define* (new-agent-password datastore
                             #:key
                             agent)
  (let ((password (random-token)))
    (datastore-new-agent-password datastore
                                  agent
                                  password)
    password))

(define (allocate-builds datastore)
  (let ((agents (datastore-list-agents datastore))
        (builds (datastore-list-unprocessed-builds datastore)))
    (datastore-replace-build-allocation-plan
     datastore
     (append-map
      (lambda (agent-id)
        (map (lambda (build-id ordering)
               (list build-id
                     agent-id
                     ordering))
             (map (lambda (build)
                    (assq-ref build 'uuid))
                  builds)
             (iota (length builds))))
      (map (lambda (agent)
             (assq-ref agent 'uuid))
           agents))))
  #t)

(define (fetch-builds datastore agent)
  (let ((builds (datastore-list-allocation-plan-builds
                 datastore
                 agent
                 1)))
    (unless (null? builds)
      (datastore-allocate-builds-to-agent
       datastore
       agent
       (map (lambda (build)
              (assq-ref build 'uuid))
            builds)))

    builds))

(define (agent-details datastore agent-id)
  (let ((agent (datastore-find-agent datastore agent-id))
        (allocated-builds (datastore-list-agent-builds datastore agent-id)))
    `(,@agent                           ; description
      (builds . ,(list->vector allocated-builds)))))

(define (build-output-file-location datastore build-id output-name)
  (let ((output (datastore-find-build-output datastore build-id output-name)))
    (string-append (%config 'builds-dir) "/"
                   build-id "/outputs/" output-name "/"
                   (basename output)
                   ".nar.lz")))