path: root/guix-build-coordinator/coordinator.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 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-file
                       #:key
                       requested-uuid
                       (priority 0)
                       (defer-allocation? #f)
                       (ensure-all-related-derivations-have-builds? #f))
  (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)

    (when ensure-all-related-derivations-have-builds?
      (let ((related-derivations
             (datastore-list-related-derivations-with-no-build datastore
                                                               derivation-file)))
        (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
                           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)
         (allocate-builds datastore)))))

  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)
  (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)
  (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))))


(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))))