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 (ice-9 popen)
  #:use-module (ice-9 exceptions)
  #:use-module (gcrypt pk-crypto)
  #:use-module (zlib)
  #:use-module (lzlib)
  #:use-module (guix pki)
  #:use-module (guix store)
  #:use-module (guix base32)
  #:use-module (guix config)
  #:use-module (guix derivations)
  #:use-module (guix serialization)
  #:use-module ((guix utils) #:select (default-keyword-arguments))
  #: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
            default-build-canceled-hook
            build-failure-retry-hook
            build-recompress-log-file-hook
            default-build-missing-inputs-hook
            default-build-submit-outputs-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
            build-canceled-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))
          (narinfo-directory publish-directory)
          (skip-publishing-proc
           (lambda (narinfo-filename narinfo-directory)
             (file-exists? (string-append
                            narinfo-directory "/" narinfo-filename))))
          post-publish-hook
          combined-post-publish-hook
          (publish-referenced-derivation-source-files? #t)
          derivation-substitute-urls)
  (mkdir-p (string-append publish-directory "/nar/lzip"))

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

    (define (process-referenced-derivation-source-files drv-name)
      (let* ((build-outputs
              (datastore-list-build-outputs datastore build-id))
             (potential-referenced-source-files
              ;; Just subtract the inputs from the output references
              (lset-difference
               string=?
               (delete-duplicates
                (append-map (lambda (output)
                              ;; References don't include the store path
                              (or (and=> (assq-ref output 'references)
                                         vector->list)
                                  '()))
                            build-outputs)
                string=?)
               (map basename
                    (datastore-find-recursive-derivation-input-outputs
                     datastore
                     drv-name)))))

        (unless (null? potential-referenced-source-files)
          (display
           (simple-format
            #f
            "build-success-publish-hook (~A): looking at potential referenced source files: ~A\n"
            build-id
            potential-referenced-source-files)
           (current-error-port)))

        (if (null? potential-referenced-source-files)
            '()
            (with-store/non-blocking store
              (unless (valid-path? store drv-name)
                ;; TODO This isn't ideal as it can be blocked by GC
                (with-port-timeouts
                 (lambda ()
                   (substitute-derivation store
                                          drv-name
                                          #:substitute-urls
                                          derivation-substitute-urls)))
                (add-temp-root store drv-name))

              (let* ((drv (read-derivation-from-file* drv-name))
                     (drv-sources
                      (derivation-sources drv))
                     (referenced-source-files
                      (filter
                       (lambda (source)
                         (if (member (basename source)
                                     potential-referenced-source-files)
                             source
                             #f))
                       drv-sources)))

                (filter-map
                 (lambda (source-filename)
                   (let* ((nar-filename
                           (string-append "nar/lzip/"
                                          (basename source-filename)))
                          (nar-destination
                           (string-append publish-directory "/"
                                          nar-filename))
                          (tmp-nar-destination
                           (string-append publish-directory "/"
                                          nar-filename
                                          ".tmp"))
                          (narinfo-filename
                           (string-append (string-take (basename source-filename) 32)
                                          ".narinfo"))

                          (narinfo-location
                           (string-append narinfo-directory "/"
                                          narinfo-filename))
                          (path-info
                           (query-path-info store source-filename)))

                     (if (skip-publishing-proc narinfo-filename narinfo-directory)
                         #f
                         (begin
                           (call-with-output-file tmp-nar-destination
                             (lambda (out)
                               (call-with-lzip-output-port out
                                 (lambda (port)
                                   (write-file source-filename port))
                                 #:level 9)))

                           (rename-file tmp-nar-destination nar-destination)

                           (call-with-output-file narinfo-location
                             (lambda (port)
                               (display (narinfo-string
                                         source-filename
                                         (bytevector->nix-base32-string
                                          (path-info-hash path-info))
                                         (path-info-nar-size path-info)
                                         (map basename
                                              (path-info-references
                                               path-info))
                                         `((lzip ,(stat:size (stat nar-destination #f))))
                                         #:public-key public-key
                                         #:private-key private-key)
                                        port)))

                           (when post-publish-hook
                             (with-exception-handler
                                 (lambda (exn)
                                   ;; Rollback narinfo creation, to make this more
                                   ;; transactional
                                   (delete-file narinfo-location)

                                   (raise-exception exn))
                               (lambda ()
                                 (post-publish-hook publish-directory
                                                    narinfo-filename
                                                    nar-filename))
                               #:unwind? #t))

                           (cons narinfo-filename
                                 nar-filename)))))
                 referenced-source-files))))))

    (define (process-output drv-name 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 narinfo-directory "/"
                             narinfo-filename)))

        (if (skip-publishing-proc narinfo-filename narinfo-directory)
            #f
            (begin
              (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
                                      drv-name)
                            #:derivation drv-name
                            #:public-key public-key
                            #:private-key private-key)
                           port)))

              (when post-publish-hook
                (with-exception-handler
                    (lambda (exn)
                      ;; Rollback narinfo creation, to make this more
                      ;; transactional
                      (delete-file narinfo-location)

                      (raise-exception exn))
                  (lambda ()
                    (post-publish-hook publish-directory
                                       narinfo-filename
                                       nar-filename))
                  #:unwind? #t))

              (cons narinfo-filename
                    nar-filename)))))

    (let* ((build-details
            (datastore-find-build datastore build-id))
           (drv-name
            (assq-ref build-details 'derivation-name))
           (narinfos-and-nars
            (append
             (if publish-referenced-derivation-source-files?
                 (process-referenced-derivation-source-files drv-name)
                 '())
             (filter-map
              (lambda (output)
                (process-output drv-name output))
              (datastore-list-build-outputs datastore build-id)))))
      (when (and combined-post-publish-hook
                 (not (null? narinfos-and-nars)))
        (with-exception-handler
            (lambda (exn)
              ;; Rollback narinfo creation, to make this more
              ;; transactional
              (for-each
               (match-lambda
                 ((narinfo-filename . _)
                  (delete-file
                   (string-append
                    narinfo-directory "/" narinfo-filename))))
               narinfos-and-nars)

              (raise-exception exn))
          (lambda ()
            (combined-post-publish-hook publish-directory
                                        narinfos-and-nars))
          #:unwind? #t)))))

(define* (build-success-s3-publish-hook
          s3-bucket
          #:key
          (aws-command "aws")
          (command-line-arguments '())
          (narinfo-directory #f)
          (public-key  (read-file-sexp %public-key-file))
          (private-key (read-file-sexp %private-key-file))
          post-publish-hook)
  (define (s3-file-exists? name)
    (if (null?
         (retry-on-error
          (lambda ()
            (s3-list-objects s3-bucket name
                             #:command aws-command
                             #: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
     #:narinfo-directory (or narinfo-directory temp-dir)
     #:public-key public-key
     #:private-key private-key
     #:post-publish-hook
     (lambda (directory narinfo-filename nar-filename)
       (let ((narinfo-full-filename
              (string-append (or narinfo-directory temp-dir)
                             "/" narinfo-filename)))
         (unless (s3-file-exists? narinfo-filename)
           (retry-on-error
            (lambda ()
              (s3-cp s3-bucket
                     (string-append directory "/" nar-filename)
                     nar-filename
                     #:command aws-command
                     #:command-line-arguments
                     command-line-arguments))
            #:times 6
            #:delay 20)

           (when post-publish-hook
             (post-publish-hook directory
                                narinfo-filename
                                nar-filename))

           (retry-on-error
            (lambda ()
              (s3-cp s3-bucket
                     narinfo-full-filename
                     narinfo-filename
                     #:command aws-command
                     #:command-line-arguments
                     command-line-arguments))
            #:times 6
            #:delay 20))

         (unless narinfo-directory
           (delete-file narinfo-full-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 (default-build-canceled-hook build-coordinator build-id)
  (display
   (simple-format #f
                  "build ~A canceled\n"
                  build-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-count (datastore-count-builds-for-derivation
                                             datastore
                                             derivation-name
                                             #:include-canceled? #f))
           (retries-list
            (if (procedure? retries)
                (retries #:build-details build-details
                         #:derivation-details (datastore-find-derivation
                                               datastore
                                               derivation-name)
                         #:builds-for-derivation-count
                         all-builds-for-derivation-count)
                (if (= 1 all-builds-for-derivation-count)
                    (make-list retries '())
                    '()))))
      (unless (null? retries-list)
        (display
         (simple-format #f "~A: submitting ~A retries for\n  ~A\n"
                        build-id (length retries-list) derivation-name))
        (for-each
         (lambda (retry-arguments index)
           (let ((details
                  (apply submit-build
                         build-coordinator derivation-name
                         (default-keyword-arguments
                           retry-arguments
                           (list
                            #:priority (assq-ref build-details 'priority)
                            #:tags (datastore-fetch-build-tags
                                    datastore
                                    build-id))))))
             (display
              (simple-format #f "~A: submitted retry ~A as ~A\n"
                             build-id
                             index
                             (assq-ref details 'build-submitted)))))
         retries-list
         (iota (length retries-list) 1))))))

(define* (build-recompress-log-file-hook #:key
                                         recompress-to
                                         (timeout 60))
  (define* (call-with-compressed-input-file
            name
            compression
            proc)
    (cond
     ((eq? compression 'gzip)
      (call-with-input-file name
        (lambda (compressed-input-port)
          (call-with-gzip-input-port
              compressed-input-port
            proc))))
     ((eq? compression 'bzip2)
      (let ((pipe (open-pipe* OPEN_READ
                              (%config 'bzip2)
                              "-dc"
                              name)))
        (dynamic-wind
          (const #f)
          (lambda ()
            (proc pipe))
          (lambda ()
            (close-pipe pipe)))))
     (else
      (error
       (simple-format #f "unsupported compression ~A"
                      compression)))))

  (define* (call-with-compressed-output-file
            name
            compression
            proc
            #:key (compression-level 9))
    (cond
     ((eq? compression 'gzip)
      (call-with-output-file name
        (lambda (uncompressed-output-port)
          (call-with-gzip-output-port
              uncompressed-output-port
            proc))))
     ((eq? compression 'bzip2)
      (let ((pipe (open-pipe OPEN_WRITE
                             (simple-format
                              #f
                              "~A --compress -~A > ~A"
                              (%config 'bzip2)
                              compression-level
                              name))))
        (dynamic-wind
          (const #f)
          (lambda ()
            (proc pipe))
          (lambda ()
            (close-pipe pipe)))))
     (else
      (error
       (simple-format #f "unsupported compression ~A"
                      compression)))))

  (lambda (build-coordinator build-id)
    (let* ((source-log-file
            (build-log-file-location build-id))
           (source-compression
            (cond
             ((string-suffix? ".gz" source-log-file)  'gzip)
             ((string-suffix? ".bz2" source-log-file) 'bzip2)
             (else (error "unknown source compression"))))
           (output-log-file
            (build-log-file-destination build-id
                                        (symbol->string recompress-to)))
           (tmp-output-log-file
            (string-append output-log-file ".tmp")))
      (unless (eq? source-compression recompress-to)
        (when (file-exists? tmp-output-log-file)
          (delete-file tmp-output-log-file))
        (with-timeout timeout
          (raise-exception
           (make-exception-with-message "timeout recompressing log file"))
          (call-with-compressed-input-file
           source-log-file
           source-compression
           (lambda (input-port)
             (call-with-compressed-output-file
              tmp-output-log-file
              recompress-to
              (lambda (output-port)
                (dump-port input-port output-port))))))
        (rename-file tmp-output-log-file
                     output-log-file)
        (delete-file source-log-file)))))

(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)))
    (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
                       (datastore-find-derivation-for-output
                        datastore
                        (assq-ref build 'derivation-name)
                        missing-input)))
                  (if input-derivation
                      (let* ((builds-for-output
                              (datastore-list-builds-for-output datastore
                                                                missing-input))
                             (successful-builds
                              (filter (lambda (build-details)
                                        (and
                                         (assq-ref build-details 'processed)
                                         (string=? (assq-ref build-details 'result)
                                                   "success")))
                                      builds-for-output))
                             (pending-builds
                              (filter (lambda (build-details)
                                        (and
                                         (not (assq-ref build-details 'processed))
                                         (not (assq-ref build-details 'canceled))))
                                      builds-for-output)))
                        (if (and (null? successful-builds)
                                 (null? pending-builds))
                            (begin
                              (simple-format #t
                                             "submitting build for ~A\n"
                                             input-derivation)
                              (submit-build build-coordinator
                                            input-derivation
                                            #:tags (datastore-fetch-build-tags
                                                    datastore
                                                    build-id)))
                            (simple-format #t "~A builds exist for ~A, skipping\n"
                                           (length builds-for-output)
                                           missing-input)))
                      (begin
                        (simple-format (current-error-port)
                                       "warning: default-build-missing-inputs-hook:
  couldn't find a derivation for ~A\n"
                                       missing-input)))))
              missing-inputs)))

(define (default-build-submit-outputs-hook build-coordinator build-id)
  (define datastore
    (build-coordinator-datastore build-coordinator))

  (let* ((build (datastore-find-build datastore build-id))
         (unbuilt-outputs (datastore-list-unbuilt-derivation-outputs
                           datastore
                           (assq-ref build 'derivation-name))))
    (not (null? unbuilt-outputs))))

(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-canceled       . ,default-build-canceled-hook)
    (build-missing-inputs . ,default-build-missing-inputs-hook)
    (build-submit-outputs . ,default-build-submit-outputs-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))
         ,@(or
            (and=>
             (datastore-find-derivation-output-details
              datastore
              (assq-ref build-details 'derivation-name))
             (lambda (output-details)
               `((derivation_outputs
                  . ,(list->vector
                      (map
                       (lambda (output-details)
                         `((output . ,(assq-ref output-details 'output))
                           (name   . ,(assq-ref output-details 'name))
                           ,@(if (assq-ref output-details 'hash)
                                 `((hash_algorithm . ,(assq-ref output-details
                                                                'hash-algorithm))
                                   (hash           . ,(assq-ref output-details
                                                                'hash)))
                                 '())
                           (recursive . ,(assq-ref output-details 'recursive?))))
                       output-details))))))
            '())
         ,@(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)))))
                 '())))))))

(define (build-canceled-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      . canceled)
         (build_id   . ,build-id)
         (derivation . ,(assq-ref build-details 'derivation-name))
         ;; TODO Maybe the time of the actual cancelation should be stored or
         ;; included in the event
         (timestamp  . ,(current-time)))))))