#!@GUILE@ --no-auto-compile
-*- scheme -*-
-*- geiser-scheme-implementation: guile -*-
!#
;;; 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/>.

(use-modules (srfi srfi-1)
             (srfi srfi-37)
             (ice-9 match)
             ((guix ui) #:select (read/eval))
             (guix derivations)
             (guix-build-coordinator hooks)
             (guix-build-coordinator utils)
             (guix-build-coordinator config)
             (guix-build-coordinator datastore)
             (guix-build-coordinator coordinator)
             (guix-build-coordinator agent-messaging http))

(define %base-options
  ;; Specifications of the command-line options
  (list (option '("secret-key-base-file") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'secret-key-base
                              (string-trim-right
                               (call-with-input-file arg get-string-all))
                              result)))
        (option '("database") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'database
                              arg
                              result)))
        (option '("update-database") #f #f
                (lambda (opt name _ result)
                  (alist-cons 'update-database #t result)))
        (option '("show-error-details") #f #f
                (lambda (opt name _ result)
                  (alist-cons 'show-error-details #t result)))))

(define %base-option-defaults
  ;; Alist of default option values
  `((update-database                      . #f)
    (database . "sqlite://guix_build_coordinator.db")
    (port                                 . 8745)
    (host                                 . "0.0.0.0")
    (show-error-details
     . ,(match (getenv "GUIX_BUILD_COORDINATOR_SHOW_ERROR_DETAILS")
          (#f #f)
          ("" #f)
          (_ #t)))))

(define %build-options
  (list (option '("priority") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'priority
                              (string->number arg)
                              result)))
        (option '("ignore-if-build-for-derivation-exists") #f #f
                (lambda (opt name _ result)
                  (alist-cons 'ignore-if-build-for-derivation-exists #t result)))
        (option '("ignore-if-build-for-outputs-exists") #f #f
                (lambda (opt name _ result)
                  (alist-cons 'ignore-if-build-for-outputs-exists #t result)))
        (option '("ensure-all-related-derivations-have-builds") #f #f
                (lambda (opt name _ result)
                  (alist-cons 'ensure-all-related-derivations-have-builds
                              #t
                              result)))
        (option '("defer-allocation") #f #f
                (lambda (opt name _ result)
                  (alist-cons 'defer-allocation #t result)))))


(define %build-option-defaults
  `((priority                                   . 0)
    (ignore-if-build-for-derivation-exists      . #f)
    (ignore-if-build-for-outputs-exists         . #f)
    (ensure-all-related-derivations-have-builds . #f)
    (defer-allocation                           . #f)))

(define %service-options
  (list (option '("pid-file") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'pid-file
                              arg
                              result)))
        (option '("port") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'port
                              (string->number arg)
                              (alist-delete 'port result))))
        (option '("host") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'host
                              arg
                              (alist-delete 'host result))))
        (option '("build-success-hook") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'build-success-hook
                              (read/eval arg)
                              (alist-delete 'build-success-hook result))))
        (option '("build-failure-hook") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'build-failure-hook
                              (read/eval arg)
                              (alist-delete 'build-failure-hook result))))
        (option '("build-missing-inputs-hook") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'build-missing-inputs-hook
                              (read/eval arg)
                              (alist-delete 'build-missing-inputs-hook result))))))

(define %service-option-defaults
  ;; Alist of default option values
  `((port                                 . 8745)
    (host                                 . "0.0.0.0")
    (build-success-hook                   . ,default-build-success-hook)
    (build-failure-hook                   . ,default-build-failure-hook)
    (build-missing-inputs-hook            . ,default-build-missing-inputs-hook)))

(define %agent-options
  (list (option '("uuid") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'uuid
                              arg
                              result)))
        (option '("description") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'description
                              arg
                              result)))))

(define (parse-options options defaults args)
  (args-fold
   args options
   (lambda (opt name arg result)
     (error "unrecognized option" name))
   (lambda (arg result)
     (alist-cons
      'arguments
      (cons arg
            (or (assoc-ref result 'arguments)
                '()))
      (alist-delete 'arguments result)))
   defaults))

(setvbuf (current-output-port) 'line)
(setvbuf (current-error-port) 'line)

(match (cdr (program-arguments))
  (("build" "show" rest ...)
   (let ((opts (parse-options %base-options
                              %base-option-defaults
                              rest)))
     (let ((datastore (database-uri->datastore
                       (assq-ref opts 'database))))
       (define (display-build build-details)
         (simple-format #t "derivation name: ~A
priority:        ~A
processed?:      ~A
"
                        (assq-ref build-details 'derivation-name)
                        (assq-ref build-details 'priority)
                        (assq-ref build-details 'processed))

         (let ((setup-failures
                (datastore-list-setup-failures-for-build
                 datastore
                 (assq-ref build-details 'uuid))))
           (unless (null? setup-failures)
             (display "\nsetup failures:\n")
             (for-each
              (lambda (setup-failure)
                (simple-format #t "  - agent:          ~A
    failure reason: ~A
"
                               (assq-ref setup-failure 'agent-id)
                               (assq-ref setup-failure 'failure-reason))
                (when (string=? (assq-ref setup-failure 'failure-reason)
                                "missing_inputs")
                  (simple-format #t "    missing inputs:\n")
                  (for-each (lambda (missing-input)
                              (simple-format #t
                                             "     - ~A\n"
                                             missing-input)
                              (let ((builds-for-missing-input
                                     (datastore-list-builds-for-output
                                      datastore
                                      missing-input)))
                                (for-each
                                 (lambda (missing-input-build)
                                   (simple-format
                                    #t
                                    "        - ~A~A\n"
                                    (assq-ref missing-input-build 'uuid)
                                    (if (= 1 (assq-ref missing-input-build
                                                       'processed))
                                        " (finished)"
                                        "")))
                                 builds-for-missing-input)))
                            (datastore-list-setup-failure-missing-inputs
                             datastore
                             (assq-ref setup-failure 'id)))
                  (newline)))
              setup-failures))))

       (define (output? s)
         (string-prefix? "/gnu/store/" s))

       (match (assq-ref opts 'arguments)
         (((? output? output))
          (for-each display-build
                    (datastore-list-builds-for-output datastore output)))
         ((build-id)
          (match (datastore-find-build datastore build-id)
            (#f (display "no build found\n"))
            (build-details
             (display-build `((uuid . ,build-id)
                              ,@build-details)))))))))
  (("build" rest ...)
   (let ((opts (parse-options (append %build-options
                                      %base-options)
                              (append %build-option-defaults
                                      %base-option-defaults)
                              rest)))

     (match (assq-ref opts 'arguments)
       ((derivation-file)
        (let ((datastore
               (database-uri->datastore
                (assq-ref opts 'database))))

          (when (assq-ref opts 'ignore-if-build-for-derivation-exists)
            (let ((builds-for-derivation
                   (datastore-list-builds-for-derivation datastore
                                                         derivation-file)))
              (unless (null? builds-for-derivation)
                (simple-format #t "there are already ~A builds for ~A, skipping\n"
                               (length builds-for-derivation)
                               derivation-file)
                (exit 0))))

          (unless (file-exists? derivation-file)
            (substitute-derivation derivation-file))

          (let ((derivation (read-derivation-from-file derivation-file)))

            (when (assq-ref opts 'ignore-if-build-for-outputs-exists)
              (for-each
               (match-lambda
                 ((name . derivation-output)
                  (let ((builds-for-output
                         (datastore-list-builds-for-output
                          datastore
                          (derivation-output-path derivation-output))))

                    (unless (null? builds-for-output)
                      (simple-format
                       #t "there are already ~A builds for ~A, skipping\n"
                       (length builds-for-output)
                       (derivation-output-path derivation-output))
                      (exit 0)))))
               (derivation-outputs derivation)))

            (let ((uuid (submit-build
                         datastore
                         derivation
                         #:priority (assq-ref opts 'priority)
                         #:defer-allocation? (assq-ref opts 'defer-allocation)
                         #:ensure-all-related-derivations-have-builds?
                         (assq-ref
                          opts 'ensure-all-related-derivations-have-builds))))
              (simple-format #t "build submitted as ~A\n" uuid))))))))
  (("agent" "new" rest ...)
   (let ((opts (parse-options (append %agent-options
                                      %base-options)
                              %base-option-defaults
                              rest)))
     (let ((uuid (new-agent (database-uri->datastore
                             (assq-ref opts 'database))
                            #:requested-uuid (assq-ref opts 'uuid)
                            #:description (assq-ref opts 'description))))
       (simple-format #t "agent created as as ~A\n" uuid))))
  (("agent" id "password" "new" rest ...)
   (let ((opts (parse-options %base-options
                              %base-option-defaults
                              rest)))
     (let ((password (new-agent-password
                      (database-uri->datastore
                       (assq-ref opts 'database))
                      #:agent id)))
       (simple-format #t "new password: ~A\n" password))))
  (("agent" "list" rest ...)
   (let ((opts (parse-options %base-options %base-option-defaults rest)))
     (for-each (lambda (agent)
                 (simple-format
                  #t "~A: ~A\n"
                  (assq-ref agent 'uuid)
                  (or (assq-ref agent 'description)
                      "(no description)")))
               (datastore-list-agents
                (database-uri->datastore
                 (assq-ref opts 'database))))))
  ((arguments ...)
   (let* ((opts (parse-options (append %service-options
                                       %base-options)
                               (append %service-option-defaults
                                       %base-option-defaults)
                               arguments))
          (datastore (database-uri->datastore
                      (assq-ref opts 'database)
                      #:metrics-registry
                      coordinator-metrics-registry))
          (hooks
           `((build-success        . ,(assq-ref opts 'build-success-hook))
             (build-failure        . ,(assq-ref opts 'build-failure-hook))
             (build-missing-inputs . ,(assq-ref opts 'build-missing-inputs-hook)))))

     (when (assoc-ref opts 'update-database)
       (datastore-update datastore))

     (let ((pid-file (assq-ref opts 'pid-file)))
       (when pid-file
         (call-with-output-file pid-file
           (lambda (port)
             (simple-format port "~A\n" (getpid))))))

     (parameterize ((%show-error-details
                     (assoc-ref opts 'show-error-details)))

       (simple-format #t "listening on ~A:~A\n"
                      (assq-ref opts 'host)
                      (assq-ref opts 'port))
       (http-agent-messaging-start-server
        (assq-ref opts 'port)
        (assq-ref opts 'host)
        (assq-ref opts 'secret-key-base)
        datastore
        hooks)))))