;;; 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 (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
            default-build-canceled-hook
            build-failure-retry-hook
            build-recompress-log-file-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
            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))
          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)))

           (unless (file-exists? narinfo-location)
             (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
               (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)))))
       (datastore-list-build-outputs datastore build-id)))))

(define* (build-success-s3-publish-hook
          s3-bucket
          #:key
          (aws-command "aws")
          (command-line-arguments '())
          (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
     #: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 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
                   (string-append directory "/" narinfo-filename)
                   narinfo-filename
                   #:command aws-command
                   #: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 (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 (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* (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-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)))

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

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