path: root/guix-build-coordinator/hooks.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 hooks)
  #:use-module (srfi srfi-1)
  #:use-module (ice-9 match)
  #:use-module (gcrypt pk-crypto)
  #:use-module (guix pki)
  #:use-module (guix config)
  #:use-module (guix build utils)
  #:use-module (guix-build-coordinator config)
  #:use-module (guix-build-coordinator utils)
  #:use-module (guix-build-coordinator datastore)
  #:use-module (guix-build-coordinator coordinator)
  #:use-module (guix-build-coordinator guix-data-service)
  #:export (default-build-submitted-hook
            default-build-started-hook
            default-build-success-hook
            build-success-publish-hook
            build-success-s3-publish-hook
            default-build-failure-hook
            build-failure-retry-hook
            default-build-missing-inputs-hook

            %default-hooks

            build-submitted-send-event-to-guix-data-service-hook
            build-started-send-event-to-guix-data-service-hook
            build-success-send-event-to-guix-data-service-hook
            build-failure-send-event-to-guix-data-service-hook))

(define (default-build-submitted-hook build-coordinator build-id)
  (display
   (simple-format #f "build ~A submtited\n" build-id)
   (current-error-port)))

(define (default-build-started-hook build-coordinator build-id agent-id)
  (display
   (simple-format #f "build ~A started on agent ~A\n" build-id agent-id)
   (current-error-port)))

(define (default-build-success-hook build-coordinator build-id)
  (define datastore
    (build-coordinator-datastore build-coordinator))

  (let ((agent-id
         (datastore-agent-for-build datastore build-id)))
    (display
     (simple-format #f
                    "build ~A succeeded (on agent ~A)\n"
                    build-id agent-id)
     (current-error-port))))

(define* (build-success-publish-hook
          publish-directory
          #:key
          (public-key  (read-file-sexp %public-key-file))
          (private-key (read-file-sexp %private-key-file))
          post-publish-hook)
  (mkdir-p (string-append publish-directory "/nar/lzip"))

  (lambda (build-coordinator build-id)
    (define datastore
      (build-coordinator-datastore build-coordinator))

    (let* ((build-details
            (datastore-find-build datastore build-id))
           (derivation-name
            (assq-ref build-details 'derivation-name)))
      (for-each
       (lambda (output)
         (let* ((output-name
                 (assq-ref output 'name))
                (output-filename
                 (assq-ref output 'output))
                (nar-location
                 (build-output-file-location datastore build-id
                                             output-name))
                (nar-filename
                 (string-append "nar/lzip/"
                                (basename output-filename)))
                (nar-destination
                 (string-append publish-directory "/"
                                nar-filename))
                (narinfo-filename
                 (string-append (string-take (basename output-filename) 32)
                                ".narinfo"))

                (narinfo-location
                 (string-append publish-directory "/"
                                narinfo-filename)))

           (copy-file nar-location nar-destination)

           (call-with-output-file narinfo-location
             (lambda (port)
               (display (narinfo-string
                         output-filename
                         (assq-ref output 'hash)
                         (assq-ref output 'size)
                         (vector->list
                          (assq-ref output 'references))
                         `((lzip ,(stat:size (stat nar-location #f))))
                         #:system (datastore-find-derivation-system
                                   datastore
                                   derivation-name)
                         #:derivation derivation-name
                         #:public-key public-key
                         #:private-key private-key)
                        port)))

           (when post-publish-hook
             (post-publish-hook publish-directory
                                narinfo-filename
                                nar-filename))))
       (datastore-list-build-outputs datastore build-id)))))

(define* (build-success-s3-publish-hook
          s3-bucket
          #:key
          (command-line-arguments '())
          (public-key  (read-file-sexp %public-key-file))
          (private-key (read-file-sexp %private-key-file)))
  (define (s3-file-exists? name)
    (if (null?
         (retry-on-error
          (lambda ()
            (s3-list-objects s3-bucket name
                             #:command-line-arguments
                             command-line-arguments))
          #:times 6
          #:delay 20))
        #f
        #t))

  (let ((temp-dir (string-append (%config 'data-dir)
                                 "/temp-s3-uploads")))
    (unless (file-exists? temp-dir)
      (mkdir temp-dir))

    (build-success-publish-hook
     temp-dir
     #:public-key public-key
     #:private-key private-key
     #:post-publish-hook
     (lambda (directory narinfo-filename nar-filename)
       (unless (s3-file-exists? narinfo-filename)
         (retry-on-error
          (lambda ()
            (s3-cp s3-bucket
                   (string-append directory "/" nar-filename)
                   nar-filename
                   #:command-line-arguments
                   command-line-arguments))
          #:times 6
          #:delay 20)
         (retry-on-error
          (lambda ()
            (s3-cp s3-bucket
                   (string-append directory "/" narinfo-filename)
                   narinfo-filename
                   #:command-line-arguments
                   command-line-arguments))
          #:times 6
          #:delay 20))

       (delete-file (string-append directory "/" narinfo-filename))
       (delete-file (string-append directory "/" nar-filename))))))

(define (default-build-failure-hook build-coordinator build-id)
  (define datastore
    (build-coordinator-datastore build-coordinator))

  (let ((agent-id
         (datastore-agent-for-build datastore build-id)))
    (display
     (simple-format #f
                    "build ~A failed (on agent ~A)\n"
                    build-id agent-id)
     (current-error-port))))

(define* (build-failure-retry-hook #:key (retries 2))
  (lambda (build-coordinator build-id)
    (define datastore
      (build-coordinator-datastore build-coordinator))

    (let* ((build-details (datastore-find-build datastore build-id))
           (derivation-name (assq-ref build-details 'derivation-name))
           (all-builds-for-derivation (datastore-list-builds-for-derivation
                                       datastore derivation-name))
           (all-builds-for-derivation-count (length all-builds-for-derivation)))

      (when (= 1 all-builds-for-derivation-count)
        (display
         (simple-format #f "~A: submitting ~A retries for\n  ~A\n"
                        build-id retries derivation-name))
        (for-each
         (lambda (retry)
           (let ((details
                  (submit-build build-coordinator derivation-name
                                #:priority (assq-ref build-details 'priority))))
             (display
              (simple-format #f "~A: submitted retry ~A as ~A\n"
                             build-id
                             (+ 1 retry)
                             (assq-ref details 'build-submitted)))))
         (iota retries))))))

(define (default-build-missing-inputs-hook build-coordinator
                                           build-id missing-inputs)
  (define datastore
    (build-coordinator-datastore build-coordinator))

  (let ((build (datastore-find-build datastore build-id)))
    (let ((derivation-inputs
           (datastore-find-derivation-inputs datastore
                                             (assq-ref build 'derivation-name))))
      (simple-format #t "missing-inputs: ~A\n~A\n"
                     build-id
                     (string-join (map (lambda (input)
                                         (string-append " - " input))
                                       missing-inputs)
                                  "\n"))
      (for-each (lambda (missing-input)
                  (let ((input-derivation
                         (any (lambda (derivation-input)
                                (if (string=? (assq-ref derivation-input 'output)
                                              missing-input)
                                    (assq-ref derivation-input 'derivation)
                                    #f))
                              derivation-inputs)))
                    (unless input-derivation
                      (error "couldn't find a derivation for " missing-input))

                    (let ((builds-for-output
                           (datastore-list-builds-for-output datastore
                                                             missing-input)))
                      (if (null? builds-for-output)
                          (begin
                            (simple-format #t
                                           "submitting build for ~A\n"
                                           input-derivation)
                            (submit-build build-coordinator input-derivation))
                          (simple-format #t "~A builds exist for ~A, skipping\n"
                                         (length builds-for-output)
                                         missing-input)))))
                missing-inputs))))

(define %default-hooks
  `((build-submitted      . ,default-build-submitted-hook)
    (build-started        . ,default-build-started-hook)
    (build-success        . ,default-build-success-hook)
    (build-failure        . ,default-build-failure-hook)
    (build-missing-inputs . ,default-build-missing-inputs-hook)))

(define (build-submitted-send-event-to-guix-data-service-hook target-url)
  (lambda (build-coordinator build-id)
    (define datastore
      (build-coordinator-datastore build-coordinator))

    (let ((build-details
           (datastore-find-build datastore build-id)))

      (send-build-event-to-guix-data-service
       target-url
       `((type       . build)
         (event      . scheduled)
         (build_id   . ,build-id)
         (derivation . ,(assq-ref build-details 'derivation-name))
         ,@(let ((created-at (assq-ref build-details 'created-at)))
             (if created-at
                 `((timestamp . ,(string->number
                                  (strftime
                                   "%s"
                                   (assq-ref build-details 'created-at)))))
                 '())))))))

(define (build-started-send-event-to-guix-data-service-hook target-url)
  (lambda (build-coordinator build-id agent-id)
    (define datastore
      (build-coordinator-datastore build-coordinator))

    (let ((build-details
           (datastore-find-build datastore build-id))
          (timestamp
           (string->number
            (strftime
             "%s"
             (assq-ref
              (first
               (filter (lambda (start-time-and-agent)
                         (string=? agent-id
                                   (assq-ref start-time-and-agent 'agent-id)))
                       (datastore-find-build-starts datastore build-id)))
              'start-time)))))

      (send-build-event-to-guix-data-service
       target-url
       `((type       . build)
         (event      . started)
         (build_id   . ,build-id)
         (derivation . ,(assq-ref build-details 'derivation-name))
         (timestamp  . ,timestamp))))))

(define (build-success-send-event-to-guix-data-service-hook target-url)
  (lambda (build-coordinator build-id)
    (define datastore
      (build-coordinator-datastore build-coordinator))

    (let ((build-details
           (datastore-find-build datastore build-id)))

      (send-build-event-to-guix-data-service
       target-url
       `((type      . build)
         (event     . succeeded)
         (build_id  . ,build-id)
         (derivation . ,(assq-ref build-details 'derivation-name))
         ,@(let ((end-time (assq-ref build-details 'end-time)))
             (if end-time
                 `((timestamp . ,(string->number
                                  (strftime "%s"
                                            (assq-ref build-details
                                                      'end-time)))))
                 '())))))))

(define (build-failure-send-event-to-guix-data-service-hook target-url)
  (lambda (build-coordinator build-id)
    (define datastore
      (build-coordinator-datastore build-coordinator))

    (let ((build-details
           (datastore-find-build datastore build-id)))

      (send-build-event-to-guix-data-service
       target-url
       `((type      . build)
         (event     . failed)
         (build_id  . ,build-id)
         (derivation . ,(assq-ref build-details 'derivation-name))
         ,@(let ((end-time (assq-ref build-details 'end-time)))
             (if end-time
                 `((timestamp . ,(string->number
                                  (strftime "%s"
                                            (assq-ref build-details
                                                      'end-time)))))
                 '())))))))