;;; 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 (srfi srfi-26)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 match)
  #:use-module (ice-9 threads)
  #:use-module (ice-9 exceptions)
  #:use-module (gcrypt random)
  #:use-module (fibers channels)
  #:use-module (guix derivations)
  #:use-module (guix-build-coordinator utils)
  #:use-module (guix-build-coordinator config)
  #:use-module (guix-build-coordinator metrics)
  #:use-module (guix-build-coordinator datastore)
  #:use-module (guix-build-coordinator build-allocator)
  #:export (coordinator-metrics-registry

            submit-build
            new-agent
            new-agent-password
            fetch-builds
            agent-details
            make-build-allocator-thread
            make-hook-channel

            build-output-file-location
            build-log-file-location
            handle-build-result
            handle-setup-failure-report))

(define coordinator-metrics-registry
  (make-metrics-registry))

(define* (submit-build datastore derivation
                       #:key
                       requested-uuid
                       (priority 0)
                       (defer-allocation? #f)
                       (ensure-all-related-derivations-have-builds? #f))
  (let ((uuid (or requested-uuid (random-v4-uuid))))
    (datastore-store-derivation datastore derivation)

    (when ensure-all-related-derivations-have-builds?
      (let ((related-derivations
             (datastore-list-related-derivations-with-no-build
              datastore
              (derivation-file-name derivation))))
        (for-each
         (lambda (related-derivation)
           (let ((related-uuid (random-v4-uuid)))
             (simple-format #t "submtiting ~A for related ~A\n"
                            related-uuid
                            related-derivation)
             (datastore-store-build datastore
                                    related-derivation
                                    related-uuid
                                    ;; Let the scheduler take care of
                                    ;; the prioritisation
                                    0)))
         related-derivations)))

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

    (unless defer-allocation?
      ;; This can be removed once allocation in the main coordinator process can
      ;; be triggered
      (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)
  (datastore-replace-build-allocation-plan
   datastore
   (basic-build-allocation-strategy datastore))
  #t)

(define (make-build-allocator-thread datastore)
  (define mtx (make-mutex))
  (define v (make-condition-variable))

  (define (trigger-build-allocation)
    (signal-condition-variable v))

  (call-with-new-thread
   (lambda ()
     (while #t
       (with-mutex mtx
         (wait-condition-variable v mtx)
         (call-with-duration-metric
          coordinator-metrics-registry
          "guixbuildcoordinator_allocate_builds_duration_seconds"
          (lambda ()
            (with-exception-handler
                (lambda (exn)
                  (simple-format
                   (current-error-port)
                   "build-allocator-thread: exception: ~A\n"
                   exn))
              (lambda ()
                (with-exception-handler
                    (lambda (exn)
                      (backtrace)
                      (raise-exception exn))
                  (lambda ()
                    (allocate-builds datastore))))
              #:unwind? #t)))))))

  trigger-build-allocation)


(define (make-hook-channel datastore hooks)
  (let ((channel (make-channel)))
    (call-with-new-thread
     (lambda ()
       (let loop ((message (get-message channel)))
         (match message
           (('build-success build-id)
            (catch
              #t
              (lambda ()
                ((assq-ref hooks 'build-success) datastore build-id))
              (lambda (key . args)
                (simple-format #t "error: running build-success hook: ~A ~A\n"
                               key args)
                #f)))
           (('build-failure build-id)
            (catch
              #t
              (lambda ()
                ((assq-ref hooks 'build-failure) datastore build-id))
              (lambda (key . args)
                (simple-format #t "error: running build-failure hook: ~A ~A\n"
                               key args)
                #f)))
           (('build-missing-inputs build-id missing-inputs)
            (catch
              #t
              (lambda ()
                ((assq-ref hooks 'build-missing-inputs) datastore build-id
                                                        missing-inputs))
              (lambda (key . args)
                (simple-format
                 #t "error: running build-missing-inputs hook: ~A ~A\n"
                 key args)
                #f)))
           (unknown
            (simple-format #t "error: hooks: unknown message: ~A\n"
                           unknown)))
         (loop (get-message channel)))))

    channel))

(define (fetch-builds datastore agent)
  (call-with-duration-metric
   coordinator-metrics-registry
   "guixbuildcoordinator_coordinator_fetch_builds_duration_seconds"
   (lambda ()
     (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")))

(define (build-log-file-directory build-id)
  (string-append (%config 'build-logs-dir) "/"
                 build-id))

(define (build-log-file-location datastore build-id format)
  (string-append (build-log-file-directory build-id) "/"
                 (cond
                  ((string=? format "bzip2") "log.bz2")
                  ((string=? format "gzip")  "log.gz")
                  (else
                   (error "unknown log format" format)))))

(define (build-log-file-exists? build-id)
  (let ((potential-files
         (scandir (build-log-file-directory build-id)
                  (negate (cut member <> '("." ".."))))))
    (match potential-files
      ((file) file)
      (() #f)
      (#f #f)                           ; directory doesn't exist
      (files (error
              (simple-format #f "found multiple files for ~A: ~A"
                             build-id files))))))

(define (handle-build-result datastore hook-channel
                             agent-id build-id result-json)
  (call-with-duration-metric
   coordinator-metrics-registry
   "guixbuildcoordinator_coordinator_handle_build_result_duration_seconds"
   (lambda ()
     (let* ((result (assoc-ref result-json "result"))
            (success? (string=? result "success")))
       (let ((build-details (datastore-find-build datastore build-id)))
         (when (assq-ref build-details 'processed?)
           (raise-exception
            (make-exception-with-message "build already processed"))))

       (when success?
         (unless (build-log-file-exists? build-id)
           (raise-exception
            (make-exception-with-message "missing build log file")))

         (for-each
          (lambda (output)
            (let ((output-location
                   (build-output-file-location datastore build-id
                                               (assq-ref output 'name))))
              (unless (file-exists? output-location)
                (raise-exception
                 (make-exception-with-message
                  (simple-format #f "missing output ~A"
                                 (assq-ref output 'name)))))))
          (datastore-list-build-outputs datastore build-id)))

       (datastore-store-build-result datastore
                                     build-id
                                     agent-id
                                     (if success?
                                         "success"
                                         "failure")
                                     #f    ; failure reason, TODO
                                     (if success?
                                         (vector->list
                                          (assoc-ref result-json "outputs"))
                                         #f))

       (put-message hook-channel
                    (list (if (string=? result "success")
                              'build-success
                              'build-failure)
                          build-id))

       #t))))

(define (handle-setup-failure-report datastore hook-channel
                                     agent-id build-id report-json)
  (let ((failure-reason (assoc-ref report-json "failure_reason")))
    (if (string=? failure-reason "missing_inputs")
        ;; For missing inputs, we need to store the inputs that were missing,
        ;; so that has a special function
        (let ((missing-inputs
               (vector->list (assoc-ref report-json "missing_inputs"))))
          (datastore-store-setup-failure/missing-inputs datastore
                                                        build-id
                                                        agent-id
                                                        missing-inputs)

          (put-message hook-channel
                       (list 'build-missing-inputs
                             build-id
                             missing-inputs)))

        (datastore-store-setup-failure datastore
                                       build-id
                                       agent-id
                                       failure-reason))))