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-9)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 match)
  #:use-module (ice-9 atomic)
  #: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 utils)
  #: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 (make-build-coordinator
            build-coordinator-datastore
            build-coordinator-hooks
            build-coordinator-metrics-registry
            build-coordinator-allocation-strategy

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

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

(define-record-type <build-coordinator>
  (make-build-coordinator-record datastore hooks metrics-registry
                                 allocation-strategy)
  build-coordinator?
  (datastore            build-coordinator-datastore)
  (hooks                build-coordinator-hooks)
  (metrics-registry     build-coordinator-metrics-registry)
  (allocation-strategy  build-coordinator-allocation-strategy))

(define* (make-build-coordinator #:key datastore hooks
                                 (metrics-registry (make-metrics-registry))
                                 (allocation-strategy
                                  basic-build-allocation-strategy))
  (make-build-coordinator-record
   datastore
   hooks
   metrics-registry
   allocation-strategy))

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

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

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

    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 build-coordinator)
  (define datastore
    (build-coordinator-datastore build-coordinator))

  (let* ((allocator-proc
          (build-coordinator-allocation-strategy build-coordinator))
         (new-plan
          (with-time-logging "allocating builds"
            (allocator-proc datastore))))
    (datastore-replace-build-allocation-plan datastore new-plan))
  #t)

(define (make-build-allocator-thread build-coordinator)
  (define mtx (make-mutex))
  (define v (make-condition-variable))
  (define allocation-needed (make-atomic-box #f))

  (define (trigger-build-allocation)
    (atomic-box-set! allocation-needed #t)
    (signal-condition-variable v))

  (parameterize (((@@ (fibers internal) current-fiber) #f))
    (call-with-new-thread
     (lambda ()
       (while #t
         (with-mutex mtx
           (let ((previous-allocation-needed-value
                  (atomic-box-swap! allocation-needed #f)))
             (when (eq? #f previous-allocation-needed-value)
               (wait-condition-variable v mtx)
               (atomic-box-set! allocation-needed #f)))
           (call-with-duration-metric
            (build-coordinator-metrics-registry build-coordinator)
            "guixbuildcoordinator_allocate_builds_duration_seconds"
            (lambda ()
              (with-exception-handler
                  (lambda (exn)
                    (simple-format
                     (current-error-port)
                     "build-allocator-thread: exception: ~A\n"
                     exn)
                    (atomic-box-set! allocation-needed #t))
                (lambda ()
                  (with-exception-handler
                      (lambda (exn)
                        (with-exception-handler
                            (lambda (exn)
                              (simple-format
                               (current-error-port)
                               "exception when printing backtrace: ~A\n"
                               exn)
                              (backtrace)
                              (raise-exception exn))
                          (lambda ()
                            (backtrace)
                            (simple-format #t "\nfinished printing backtrace\n")
                            (force-output)))
                        (raise-exception exn))
                    (lambda ()
                      (allocate-builds build-coordinator))))
                #:unwind? #t))))))))

  trigger-build-allocation)

(define (start-hook-processing-thread build-coordinator)
  (define datastore
    (build-coordinator-datastore build-coordinator))

  (parameterize (((@@ (fibers internal) current-fiber) #f))
    (call-with-new-thread
     (lambda ()
       (while #t
         (match (datastore-list-unprocessed-hook-events datastore 1)
           (() (sleep 1))
           (((id event arguments))
            (catch
              #t
              (lambda ()
                (apply (assq-ref (build-coordinator-hooks build-coordinator)
                                 event)
                       build-coordinator arguments)
                (datastore-delete-unprocessed-hook-event datastore id)

                ;; If this is the hook for a successful build, once the hook
                ;; completed successfully, delete the nar files for this build.
                (when (eq? 'build-success event)
                  (match arguments
                    ((build-id)
                     (let ((data-location (build-data-location build-id)))
                       (when (file-exists? data-location)
                         (delete-file-recursively data-location)))))))
              (lambda (key . args)
                (simple-format #t "error: running ~A hook: ~A ~A\n"
                               event key args)
                #f))))))))
  #t)

(define (fetch-builds build-coordinator agent)
  (call-with-duration-metric
   (build-coordinator-metrics-registry build-coordinator)
   "guixbuildcoordinator_coordinator_fetch_builds_duration_seconds"
   (lambda ()
     (let ((builds (datastore-list-allocation-plan-builds
                    (build-coordinator-datastore build-coordinator)
                    agent
                    1)))
       (unless (null? builds)
         (datastore-allocate-builds-to-agent
          (build-coordinator-datastore build-coordinator)
          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-data-location build-id )
  (string-append (%config 'builds-dir) "/"
                 build-id))

(define (build-output-file-location datastore build-id output-name)
  (let ((output (datastore-find-build-output datastore build-id output-name)))
    (string-append (build-data-location 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 build-coordinator
                             agent-id build-id result-json)
  (define datastore
    (build-coordinator-datastore build-coordinator))

  (call-with-duration-metric
   (build-coordinator-metrics-registry build-coordinator)
   "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))
       #t))))

(define (handle-setup-failure-report datastore
                                     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))
        (datastore-store-setup-failure datastore
                                       build-id
                                       agent-id
                                       failure-reason))))