#!@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/>.

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

(let ((columns (string->number (or (getenv "COLUMNS") ""))))
  (setenv "COLUMNS"
          (number->string
           (if columns
               (max 256 columns)
               256))))

(use-modules (srfi srfi-1)
             (srfi srfi-9 gnu)
             (srfi srfi-19)
             (srfi srfi-37)
             (srfi srfi-43)
             (srfi srfi-71)
             (ice-9 match)
             (ice-9 streams)
             (ice-9 exceptions)
             (ice-9 suspendable-ports)
             (web uri)
             (fibers)
             (fibers scheduler)
             (fibers conditions)
             (prometheus)
             ((guix ui) #:select (read/eval))
             (guix progress)
             (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 build-allocator)
             (guix-build-coordinator client-communication))

(install-suspendable-ports!)

;; TODO Work around this causing problems with backtraces
;; https://github.com/wingo/fibers/issues/76
(set-record-type-printer!
 (@@ (fibers scheduler) <scheduler>)
 (lambda (scheduler port)
   (display "#<scheduler>" port)))

(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 . ,(string-append "sqlite://"
                                (getcwd)
                                "/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 %client-options
  (list (option '("coordinator") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'coordinator
                              arg
                              (alist-delete 'coordinator result))))))

(define %client-option-defaults
  '((coordinator . "http://localhost:8746")))

(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-derivation-outputs-have-builds") #f #f
                (lambda (opt name _ result)
                  (alist-cons 'ensure-all-related-derivation-outputs-have-builds
                              #t
                              result)))
        (option '("derivation-substitute-urls") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'derivation-substitute-urls
                              (string-split arg #\space)
                              result)))
        (option '("tag") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'tags
                              (cons (match (string-split arg #\=)
                                      ((key value)
                                       `((key   . ,key)
                                         (value . ,value))))
                                    (or (assq-ref result 'tags)
                                        '()))
                              (alist-delete 'tags result))))
        (option '("defer-until") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'defer-until
                              (string->date arg "~Y-~m-~d ~H:~M:~S")
                              result)))))

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

(define %setup-failure-options
  (list
   (option '("agent-id") #t #f
           (lambda (opt name arg result)
             (alist-cons 'agent-id
                         arg
                         (alist-delete 'agent-id result))))))

(define %setup-failure-option-defaults
  `((agent-id . #f)))

(define %common-build-filtering-options
  (list
   (option '("tag") #t #f
           (lambda (opt name arg result)
             (alist-cons 'tags
                         (cons (match (string-split arg #\=)
                                 ((key value)
                                  `((key   . ,key)
                                    (value . ,value)))
                                 ((key) key))
                               (or (assq-ref result 'tags)
                                   '()))
                         (alist-delete 'tags result))))
   (option '("not-tag") #t #f
           (lambda (opt name arg result)
             (alist-cons 'not-tags
                         (cons (match (string-split arg #\=)
                                 ((key value)
                                  `((key   . ,key)
                                    (value . ,value)))
                                 ((key) key))
                               (or (assq-ref result 'not-tags)
                                   '()))
                         (alist-delete 'not-tags result))))
   (option '("system") #t #f
           (lambda (opt name arg result)
             (alist-cons 'systems
                         (cons arg
                               (or (assq-ref result 'systems)
                                   '()))
                         (alist-delete 'systems result))))
   (option '("not-system") #t #f
           (lambda (opt name arg result)
             (alist-cons 'not-systems
                         (cons arg
                               (or (assq-ref result 'not-systems)
                                   '()))
                         (alist-delete 'not-systems result))))
   (option '("processed") #t #f
           (lambda (opt name arg result)
             (alist-cons 'processed
                         (string=? arg "true")
                         result)))
   (option '("canceled") #t #f
           (lambda (opt name arg result)
             (alist-cons 'canceled
                         (string=? arg "true")
                         result)))
   (option '("priority-gt") #t #f
           (lambda (opt name arg result)
             (alist-cons 'priority->
                         (string->number arg)
                         result)))
   (option '("priority-lt") #t #f
           (lambda (opt name arg result)
             (alist-cons 'priority-<
                         (string->number arg)
                         result)))
   (option '("build-relationship") #t #f
           (lambda (opt name arg result)
             (alist-cons 'relationship
                         (string->symbol arg)
                         result)))))

(define %common-build-filtering-option-defaults
  `((tags         . ())
    (not-tags     . ())
    (systems      . ())
    (not-systems  . ())
    (processed    . unset)
    (canceled     . unset)
    (priority->   . unset)
    (priority-<   . unset)
    (relationship . unset)))

(define %builds-list-options
  (cons* (option '("after-id") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'after-id
                               arg
                               result)))
         (option '("limit") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'limit
                               (string->number arg)
                               result)))
         %common-build-filtering-options))

(define %builds-list-option-defaults
  `(,@%common-build-filtering-option-defaults))

(define %build-cancel-options
  (list (option '("tag") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'tags
                              (cons (match (string-split arg #\=)
                                      ((key value)
                                       `((key   . ,key)
                                         (value . ,value)))
                                      ((key) key))
                                    (or (assq-ref result 'tags)
                                        '()))
                              (alist-delete 'tags result))))
        (option '("not-tag") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'not-tags
                              (cons (match (string-split arg #\=)
                                      ((key value)
                                       `((key   . ,key)
                                         (value . ,value)))
                                      ((key) key))
                                    (or (assq-ref result 'not-tags)
                                        '()))
                              (alist-delete 'not-tags result))))
        (option '("system") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'systems
                              (cons arg
                                    (or (assq-ref result 'systems)
                                        '()))
                              (alist-delete 'systems result))))
        (option '("not-system") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'not-systems
                              (cons arg
                                    (or (assq-ref result 'not-systems)
                                        '()))
                              (alist-delete 'not-systems result))))
        (option '("skip-updating-derived-priorities") #f #f
                (lambda (opt name _ result)
                  (alist-cons 'skip-updating-derived-priorities
                              #t
                              result)))
        (option '("ignore-if-build-required-by-another") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'ignore-if-build-required-by-another
                              (string=? arg "true")
                              result)))
        (option '("build-relationship") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'relationship
                              (string->symbol arg)
                              result)))))

(define %build-cancel-option-defaults
  `((tags                                . ())
    (not-tags                            . ())
    (systems                             . ())
    (not-systems                         . ())
    (ignore-if-build-required-by-another . #t)
    (relationship                        . no-dependent-builds)))

(define %build-update-priority-options
  (cons* (option '("new-priority") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'new-priority
                               (string->number arg)
                               (alist-delete 'new-priority result))))
         (option '("override-derived-priority") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'override-derived-priority
                               (string->number arg)
                               (alist-delete 'override-derived-priority result))))
         (option '("skip-updating-derived-priorities") #f #f
                 (lambda (opt name _ result)
                   (alist-cons 'skip-updating-derived-priorities
                               #t
                               result)))
         %common-build-filtering-options))

(define %build-update-priority-option-defaults
  %common-build-filtering-option-defaults)

(define %build-show-blocking-options
  (list (option '("system") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'system
                              arg
                              (alist-delete 'system result))))
        (option '("include-canceled") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'include-canceled?
                              (string=? arg "true")
                              result)))))

(define %build-show-blocking-option-defaults
  '((include-cancelled? . #f)))

(define %agent-tag-options
  (list (option '("tag") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'tags
                              (cons (match (string-split arg #\=)
                                      ((key value)
                                       `((key   . ,key)
                                         (value . ,value))))
                                    (or (assq-ref result 'tags)
                                        '()))
                              (alist-delete 'tags result))))
        (option '("remove-tag") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'remove-tags
                              (cons (match (string-split arg #\=)
                                      ((key value)
                                       `((key   . ,key)
                                         (value . ,value)))
                                      ((key) key))
                                    (or (assq-ref result 'remove-tags)
                                        '()))
                              (alist-delete 'remove-tags result))))))

(define %agent-tag-option-defaults
  `((tags         . ())
    (remove-tags  . ())))

(define %service-options
  (append
   (list (option '("pid-file") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'pid-file
                               arg
                               result)))
         (option '("agent-communication") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'agent-communication
                               (string->uri arg)
                               (alist-delete 'agent-communication result))))
         (option '("client-communication") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'client-communication
                               (string->uri arg)
                               (alist-delete 'client-communication result))))
         (option '("allocation-strategy") #t #f
                 (lambda (opt name arg result)
                   (alist-cons
                    'allocation-strategy
                    (or (assoc-ref
                         `(("basic" . ,basic-build-allocation-strategy)
                           ("derivation-ordered"
                            . ,derivation-ordered-build-allocation-strategy))
                         arg)
                        (begin
                          (simple-format
                           (current-error-port)
                           "error: ~A is not a known allocation strategy\n"
                           arg)
                          (exit 1)))
                    result))))
   (append-map
    (lambda (hook)
      (list
       (option (list (simple-format #f "~A-hook" hook)) #t #f
               (lambda (opt name arg result)
                 (alist-cons (symbol-append hook '-hook)
                             (read/eval arg)
                             (alist-delete (symbol-append hook '-hook)
                                           result))))
       (option (list (simple-format #f "~A-hook-threads" hook)) #t #f
               (lambda (opt name arg result)
                 (alist-cons 'parallel-hooks
                             `((,hook . ,(string->number arg))
                               ,@(or (assq-ref result 'parallel-hooks)
                                     '()))
                             (alist-delete 'parallel-hooks
                                           result))))))
    %known-hooks)))

(define %service-option-defaults
  ;; Alist of default option values
  `((agent-communication                  . ,%default-agent-uri)
    (client-communication                 . ,%default-client-uri)
    (allocation-strategy                  . ,basic-build-allocation-strategy)))

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

(match (cdr (program-arguments))
  (("build" "show" rest ...)
   (let ((opts (parse-options %base-options
                              (append %base-option-defaults
                                      %client-option-defaults)
                              rest)))
     (define (display-build build-details)
       (simple-format #t "derivation name: ~A
priority:         ~A
processed?:       ~A
canceled?:        ~A
"
                      (assoc-ref build-details "derivation-name")
                      (if (assoc-ref build-details "processed")
                          (assoc-ref build-details "priority")
                          (simple-format #f "~A\nderived priority: ~A"
                                         (assoc-ref build-details "priority")
                                         (assoc-ref build-details "derived-priority")))
                      (if (assoc-ref build-details "processed")
                          "yes"
                          "no")
                      (if (assoc-ref build-details "canceled")
                          "yes"
                          "no"))

       (simple-format
        #t
        "tags:\n~A"
        (string-join
         (map (lambda (tag)
                (let ((key (assoc-ref tag "key"))
                      (val (assoc-ref tag "value")))
                  (string-append "  " key ": " val)))
              (vector->list
               (assoc-ref build-details "tags")))
         "\n"))
       (newline)

       (let ((derivation-inputs
              (vector->list
               (assoc-ref build-details "derivation-inputs"))))
         (unless (null? derivation-inputs)
           (display "\ninputs:\n")
           (for-each
            (lambda (derivation-input-details)
              (simple-format #t " - ~A:\n"
                             (assoc-ref derivation-input-details "output"))
              (for-each (lambda (output-build)
                          (simple-format
                           #t
                           "   - ~A: ~A\n"
                           (assoc-ref output-build "uuid")
                           (or (assoc-ref output-build "result")
                               "unknown")))
                        (vector->list
                         (assoc-ref derivation-input-details "builds"))))
            derivation-inputs)))

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

     (match (assq-ref opts 'arguments)
       ((build-id)
        (let ((response (request-build-details
                         (assq-ref opts 'coordinator)
                         build-id)))
          (display-build `(("uuid" . ,build-id)
                           ,@response)))))))
  (("build" "list" rest ...)
   (let ((opts (parse-options (append %base-options
                                      %client-options
                                      %builds-list-options)
                              (append %base-option-defaults
                                      %client-option-defaults
                                      %builds-list-option-defaults)
                              rest)))
     (fold-builds
      (assq-ref opts 'coordinator)
      (lambda (build-details _)
        (simple-format (current-output-port)
                       "id: ~A
derivation: ~A
processed: ~A
canceled: ~A
priority: ~A
tags:
~A
\n"
                       (assoc-ref build-details "uuid")
                       (assoc-ref build-details "derivation-name")
                       (if (assoc-ref build-details "processed")
                           "true"
                           "false")
                       (if (assoc-ref build-details "canceled")
                           "true"
                           "false")
                       (assoc-ref build-details "priority")
                       (string-join
                        (map (lambda (tag)
                               (let ((key (assoc-ref tag "key"))
                                     (val (assoc-ref tag "value")))
                                 (string-append "  " key ": " val)))
                             (vector->list
                              (assoc-ref build-details "tags")))
                        "\n"))
        #f)
      #f
      #:tags (assq-ref opts 'tags)
      #:not-tags (assq-ref opts 'not-tags)
      #:systems (assq-ref opts 'systems)
      #:not-systems (assq-ref opts 'not-systems)
      #:processed (assq-ref opts 'processed)
      #:canceled (assq-ref opts 'canceled)
      #:priority-> (assq-ref opts 'priority->)
      #:priority-< (assq-ref opts 'priority-<)
      #:relationship (assq-ref opts 'relationship)
      #:after-id (assq-ref opts 'after-id)
      #:limit (assq-ref opts 'limit))))

  (("build" "show-blocking" rest ...)
   (let ((opts (parse-options (append %base-options
                                      %client-options
                                      %build-show-blocking-options)
                              (append %base-option-defaults
                                      %client-option-defaults
                                      %build-show-blocking-option-defaults)
                              rest)))
     (let ((response (request-failed-builds-with-blocking-count-list
                      (assq-ref opts 'coordinator)
                      (assq-ref opts 'system)
                      #:include-cancelled? (assq-ref opts 'include-cancelled?))))
       (for-each
        (lambda (build)
          (format
           #t "~a (~5d): ~a~%"
           (assoc-ref build "uuid")
           (assoc-ref build "blocked_count")
           (assoc-ref build "derivation_name")))
        (vector->list (assoc-ref response "builds"))))))
  (("build" "cancel" rest ...)
   (let ((opts (parse-options (append %client-options
                                      %base-options
                                      %build-cancel-options)
                              (append %client-option-defaults
                                      %base-option-defaults
                                      %build-cancel-option-defaults)
                              rest)))
     (define (get-batch)
       (simple-format (current-error-port)
                      "requesting matching builds\n")
       (force-output (current-error-port))
       (fold-builds
        (assq-ref opts 'coordinator)
        (lambda (build-details result)
          (cons (assoc-ref build-details "uuid")
                result))
        '()
        #:tags (assq-ref opts 'tags)
        #:not-tags (assq-ref opts 'not-tags)
        #:systems (assq-ref opts 'systems)
        #:not-systems (assq-ref opts 'not-systems)
        #:processed #f
        #:canceled #f
        #:relationship (assq-ref opts 'relationship)))

     (match (assq-ref opts 'arguments)
       (#f
        (let loop ((matching-builds (get-batch)))
          (let ((count (length matching-builds)))
            (if (= 0 count)
                (simple-format (current-error-port)
                               "finished cancelling builds matching criteria\n")
                (begin
                  (simple-format (current-error-port)
                                 "cancelling ~A builds matching criteria\n"
                                 count)

                  (call-with-progress-reporter (progress-reporter/bar
                                                count
                                                (simple-format #f "canceling ~A builds"
                                                               count)
                                                (current-error-port))
                    (lambda (report)
                      (for-each
                       (lambda (id)
                         (let ((result
                                (retry-on-error
                                 (lambda ()
                                   (send-cancel-build-request
                                    (assq-ref opts 'coordinator)
                                    id
                                    #:skip-updating-derived-priorities?
                                    (assq-ref opts 'skip-updating-derived-priorities)
                                    #:ignore-if-build-required-by-another?
                                    (assq-ref
                                     opts 'ignore-if-build-required-by-another)))
                                 #:times 6
                                 #:delay 5)))
                           (unless (string=? (assoc-ref result "result")
                                             "build-canceled")
                             (simple-format #t "~A\n"
                                            (assoc-ref result "result"))))
                         (report))
                       matching-builds)))
                  (loop (get-batch)))))))
       ((build-id)
        (let ((result
               (send-cancel-build-request
                (assq-ref opts 'coordinator)
                build-id
                #:skip-updating-derived-priorities?
                (assq-ref opts 'skip-updating-derived-priorities)
                #:ignore-if-build-required-by-another?
                (assq-ref
                 opts 'ignore-if-build-required-by-another))))
          (simple-format #t "~A\n" (assoc-ref result "result")))))))
  (("build" "update-priority" rest ...)
   (let ((opts (parse-options (append %client-options
                                      %base-options
                                      %build-update-priority-options)
                              (append %client-option-defaults
                                      %base-option-defaults
                                      %build-update-priority-option-defaults)
                              rest)))
     (define (find-matching-builds)
       (fold-builds
        (assq-ref opts 'coordinator)
        (lambda (build-details result)
          (cons (assoc-ref build-details "uuid")
                result))
        '()
        #:tags (assq-ref opts 'tags)
        #:not-tags (assq-ref opts 'not-tags)
        #:systems (assq-ref opts 'systems)
        #:not-systems (assq-ref opts 'not-systems)
        #:processed #f
        #:canceled #f
        #:priority-> (assq-ref opts 'priority->)
        #:priority-< (assq-ref opts 'priority-<)))

     (match (assq-ref opts 'arguments)
       (#f
        (simple-format (current-error-port)
                       "requesting matching builds")
        (force-output (current-error-port))
        (let* ((matching-builds
                (find-matching-builds))
               (count (length matching-builds)))
          (simple-format (current-error-port)
                         "\nfound ~A builds matching criteria\n"
                         count)

          (call-with-progress-reporter (progress-reporter/bar
                                        count
                                        (simple-format
                                         #f
                                         "updating priorities for ~A builds" count)
                                        (current-error-port))
            (lambda (report)
              (for-each (lambda (id)
                          (retry-on-error
                           (lambda ()
                             (send-update-build-priority-request
                              (assq-ref opts 'coordinator)
                              id
                              (assq-ref opts 'new-priority)
                              #:skip-updating-derived-priorities?
                              (assq-ref opts 'skip-updating-derived-priorities)
                              #:override-derived-priority
                              (assq-ref opts 'override-derived-priority))
                             (report))
                           #:times 6
                           #:delay 5
                           #:ignore
                           (lambda (exn)
                             (member (assoc-ref (exception-message exn)
                                                "error")
                                     '("build-already-canceled"
                                       "build-already-processed")))))
                        matching-builds)))))
       ((build-id)
        (send-update-build-priority-request (assq-ref opts 'coordinator)
                                            build-id
                                            (assq-ref opts 'new-priority))))))
  (("build" rest ...)
   (let ((opts (parse-options (append %build-options
                                      %base-options)
                              (append %build-option-defaults
                                      %client-option-defaults
                                      %base-option-defaults)
                              rest)))
     (match (assq-ref opts 'arguments)
       ((derivation-file)
        (let ((response
               (send-submit-build-request
                (assq-ref opts 'coordinator)
                derivation-file
                (assq-ref opts 'derivation-substitute-urls)
                #f                 ; TODO requested uuid
                (assq-ref opts 'priority)
                (assq-ref opts 'ignore-if-build-for-derivation-exists)
                (assq-ref opts 'ignore-if-build-for-outputs-exists)
                (assq-ref opts
                          'ensure-all-related-derivation-outputs-have-builds)
                (assq-ref opts 'tags)
                #:defer-until (assq-ref opts 'defer-until))))
          (let ((no-build-submitted-response
                 (assoc-ref response "no-build-submitted")))
            (if no-build-submitted-response
                (simple-format #t "skipped: ~A\n"
                               no-build-submitted-response)
                (simple-format #t "build submitted as ~A\n"
                               (assoc-ref response "build-submitted")))))))))
  (("output" rest ...)
   (let ((opts (parse-options (append %base-options
                                      %client-options)
                              (append %base-option-defaults
                                      %client-option-defaults)
                              rest)))
     (match (assq-ref opts 'arguments)
       ((output)
        (let ((details (request-output-details (assq-ref opts 'coordinator)
                                               output)))
          (for-each
           (lambda (build)
             (simple-format
              #t "~A:\n  result: ~A\n  processed: ~A\n  priority: ~A\n  derivation: ~A\n\n"
              (assoc-ref build "uuid")
              (assoc-ref build "result")
              (assoc-ref build "processed")
              (assoc-ref build "priority")
              (assoc-ref build "derivation")))
           (vector->list (assoc-ref details "builds"))))))))
  (("agent" "new" rest ...)
   (let ((opts (parse-options (append %agent-options
                                      %client-options
                                      %base-options)
                              (append %client-option-defaults
                                      %base-option-defaults)
                              rest)))
     (let ((response (send-create-agent-request
                      (assq-ref opts 'coordinator)
                      #:requested-uuid (assq-ref opts 'uuid)
                      #:description (assq-ref opts 'description))))
       (simple-format #t "agent created as as ~A\n"
                      (assoc-ref response "agent-id")))))
  (("agent" agent-id "activate" rest ...)
   (let ((opts (parse-options %base-options
                              (append %client-option-defaults
                                      %base-option-defaults)
                              rest)))
     (let ((response (send-agent-set-active-request
                      (assq-ref opts 'coordinator)
                      agent-id
                      #true)))
       (if (string=? (assoc-ref response "result")
                     "success")
           (display "successfully activated agent\n")
           (display "error activating agent\n")))))
  (("agent" agent-id "deactivate" rest ...)
   (let ((opts (parse-options %base-options
                              (append %client-option-defaults
                                      %base-option-defaults)
                              rest)))
     (let ((response (send-agent-set-active-request
                      (assq-ref opts 'coordinator)
                      agent-id
                      #false)))
       (if (string=? (assoc-ref response "result")
                     "success")
           (display "successfully deactivated agent\n")
           (display "error activating agent\n")))))
  (("agent" agent-id "password" "new" rest ...)
   (let ((opts (parse-options %base-options
                              (append %client-option-defaults
                                      %base-option-defaults)
                              rest)))
     (let ((response (send-create-agent-password-request
                      (assq-ref opts 'coordinator)
                      agent-id)))
       (simple-format #t "new password: ~A\n"
                      (assoc-ref response "new-password")))))
  (("agent" agent-id "tags" rest ...)
   (let ((opts (parse-options (append %agent-tag-options
                                      %client-options
                                      %base-options)
                              (append %agent-tag-option-defaults
                                      %client-option-defaults
                                      %base-option-defaults)
                              rest)))
     (let ((agent-details (request-agent-details
                           (assq-ref opts 'coordinator)
                           agent-id)))
       (let* ((initial-tags (vector-fold
                             (lambda (_ result tag)
                               (cons `((key   . ,(assoc-ref tag "key"))
                                       (value . ,(assoc-ref tag "value")))
                                     result))
                             '()
                             (assoc-ref agent-details "tags")))
              (new-tags     (remove
                             (match-lambda
                               ((('key   . key)
                                 ('value . val))
                                (any (match-lambda
                                       ((('key   . k)
                                         ('value . v))
                                        (and (string=? key k)
                                             (string=? val v)))
                                       (k
                                        (string=? key k)))
                                     (assq-ref opts 'remove-tags))))
                             (append initial-tags
                                     (assq-ref opts 'tags)))))
         (let ((response (send-replace-agent-tags-request
                          (assq-ref opts 'coordinator)
                          agent-id
                          (list->vector new-tags))))
           (if (equal? initial-tags new-tags)
               (simple-format #t "tags unchanged:\n")
               (simple-format #t "changed tags to:\n"))
           (for-each (match-lambda
                       ((('key   . key)
                         ('value . value))
                        (simple-format #t " - ~A: ~A\n" key value)))
                     new-tags))))))
  (("agent" agent-id "build-allocation-plan" rest ...)
   (let ((opts (parse-options (append %client-options
                                      %base-options)
                              (append %client-option-defaults
                                      %base-option-defaults)
                              rest)))
     (let ((build-allocation-plan (assoc-ref
                                   (request-agent-build-allocation-plan
                                    (assq-ref opts 'coordinator)
                                    agent-id)
                                   "build_allocation_plan")))
       (vector-for-each
        (lambda (index build)
          (simple-format #t "~A: ~A\n" index (assoc-ref build "uuid"))
          (simple-format #t "  derivation name: ~A\n"
                         (assoc-ref build "derivation_name"))
          (simple-format #t "  system: ~A\n"
                         (assoc-ref build "system"))
          (simple-format #t "  priority: ~A\n"
                         (assoc-ref build "priority"))
          (simple-format #t "  derived priority: ~A\n"
                         (assoc-ref build "derived_priority"))
          (let ((tags (assoc-ref build "tags")))
            (unless (= 0 (vector-length tags))
              (simple-format #t "  tags:\n")
              (vector-for-each
               (lambda (_ tag)
                 (let ((key   (assoc-ref tag "key"))
                       (value (assoc-ref tag "value")))
                   (simple-format #t "   - ~A: ~A\n"
                                  key value)))
               tags)))
          (newline))
        build-allocation-plan))))
  (("agent" "list" rest ...)
   (let ((opts (parse-options %base-options
                              (append %base-option-defaults
                                      %client-option-defaults)
                              rest)))
     (for-each (lambda (agent)
                 (simple-format
                  #t "~A: ~A\n"
                  (assoc-ref agent "uuid")
                  (or (assoc-ref agent "name")
                      "(no name)"))
                 (and=> (assoc-ref agent "description")
                        (lambda (description)
                          (simple-format #t "  description:\n  ~A"
                                         description)))
                 (and=> (assoc "active" agent)
                        (match-lambda
                          (("active" . active?)
                           (simple-format #t "  active?: ~A\n"
                                          (if active? "true" "false")))))
                 (let ((allocated-builds
                        (vector->list
                         (assoc-ref agent "allocated_builds"))))
                   (simple-format #t "  ~A allocated builds:\n"
                                  (length allocated-builds))
                   (for-each (lambda (allocated-build)
                               (simple-format #t "   - ~A: ~A\n"
                                              (assoc-ref allocated-build
                                                         "uuid")
                                              (or
                                               (assoc-ref allocated-build
                                                          "derivation_name")
                                               (assoc-ref allocated-build
                                                          "derivation-name"))))
                             allocated-builds))
                 (simple-format #t "  requested systems:\n")
                 (for-each (lambda (requested-system)
                             (simple-format #t "   - ~A\n" requested-system))
                           (vector->list
                            (assoc-ref agent "requested_systems")))
                 (let ((tags (assoc-ref agent "tags")))
                   (simple-format #t "  tags:\n")
                   (for-each (lambda (tag)
                               (let ((key   (assoc-ref tag "key"))
                                     (value (assoc-ref tag "value")))
                                 (simple-format #t "   - ~A: ~A\n"
                                                key value)))
                             (vector->list tags)))
                 (newline))
               (vector->list
                (assoc-ref
                 (request-agents-list (assq-ref opts 'coordinator))
                 "agents")))))
  (("setup-failures" "list" rest ...)
   (let ((opts (parse-options (append %client-options
                                      %base-options
                                      %setup-failure-options)
                              (append %client-option-defaults
                                      %base-option-defaults
                                      %setup-failure-option-defaults)
                              rest)))
     (for-each
      (match-lambda
        ((build-id . setup-failures)
         (for-each
          (lambda (setup-failure)
            (simple-format #t "~A:\n"
                           (assoc-ref setup-failure "id"))
            (simple-format #t "  build-id: ~A\n"
                           build-id)
            (simple-format #t "  agent-id: ~A\n"
                           (assoc-ref setup-failure "agent-id"))
            (simple-format #t "  failure-reason: ~A\n"
                           (assoc-ref setup-failure "failure-reason"))
            (newline))
          (vector->list setup-failures))))
      (assoc-ref
       (request-setup-failures (assq-ref opts 'coordinator)
                               #:agent-id (assq-ref opts 'agent-id))
       "setup_failures"))))
  (("dynamic-auth" "create-token")
   (let ((opts (parse-options (append %client-options
                                      %base-options)
                              (append %client-option-defaults
                                      %base-option-defaults)
                              '())))
     (let ((token
            (assoc-ref (send-create-dynamic-auth-token-request
                        (assq-ref opts 'coordinator))
                       "token")))
       (simple-format #t "~A\n" token))))
  ((arguments ...)
   (simple-format (current-error-port) "locale is ~A\n" (check-locale!))

   (let* ((opts (parse-options (append %service-options
                                       %base-options)
                               (append %service-option-defaults
                                       %base-option-defaults)
                               arguments))
          (unknown-arguments
           (or (assq-ref opts 'arguments)
               '())))

     (unless (null? unknown-arguments)
       (simple-format (current-error-port)
                      "unknown arguments: ~A\n"
                      unknown-arguments)

       (exit 1))

     (let* ((hooks (filter-map
                    (lambda (name)
                      (and=> (assq-ref opts (symbol-append name '-hook))
                             (lambda (value)
                               (cons name value))))
                    %known-hooks))
            (hooks-with-defaults
             `(,@(filter cdr hooks)
               ,@(remove (match-lambda
                           ((name . _) (assq-ref hooks name)))
                         %default-hooks)))
            (build-coordinator (make-build-coordinator
                                #:database-uri-string (assq-ref opts 'database)
                                #:hooks hooks-with-defaults
                                #:allocation-strategy
                                (assq-ref opts 'allocation-strategy))))

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

         (run-coordinator-service
          build-coordinator
          #:update-datastore? (assoc-ref opts 'update-database)
          #:pid-file (assq-ref opts 'pid-file)
          #:agent-communication-uri (assq-ref opts 'agent-communication)
          #:client-communication-uri (assq-ref opts 'client-communication)
          #:parallel-hooks (assq-ref opts 'parallel-hooks)))))))