#!@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-19)
             (srfi srfi-37)
             (srfi srfi-43)
             (ice-9 match)
             (web uri)
             (fibers)
             (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))

(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 %builds-list-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 '("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)))))

(define %builds-list-option-defaults
  `((tags         . ())
    (not-tags     . ())
    (systems      . ())
    (not-systems  . ())
    (processed    . 'unset)
    (canceled     . 'unset)
    (limit        . 1000)))

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

(define %build-cancel-option-defaults
  `((tags         . ())
    (not-tags     . ())
    (systems      . ())
    (not-systems  . ())))

(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")
                      (assoc-ref build-details "priority")
                      (if (assoc-ref build-details "processed")
                          "yes"
                          "no")
                      (if (assoc-ref build-details "canceled")
                          "yes"
                          "no"))

       (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)))
     (let loop ((after-id #f))
       (let ((response (request-builds-list
                        (assq-ref opts 'coordinator)
                        #: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)
                        #:after-id (or after-id (assq-ref opts 'after-id))
                        #:limit (assq-ref opts 'limit))))
         (for-each
          (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")))
          (vector->list (assoc-ref response "builds")))

         (when (= (vector-length (assoc-ref response "builds"))
                  (assq-ref opts 'limit))
           (loop
            (assoc-ref (vector-ref
                        (assoc-ref response "builds")
                        (- (vector-length (assoc-ref response "builds")) 1))
                       "uuid")))))))
  (("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 (find-matching-builds)
       (define limit 1000)

       (let loop ((after-id #f)
                  (result '()))
         (let* ((response (request-builds-list
                           (assq-ref opts 'coordinator)
                           #: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
                           #:after-id after-id
                           #:limit 1000))
                (received-builds
                 (vector-length (assoc-ref response "builds")))
                (new-result
                 (fold
                  (lambda (build-details result)
                    (cons (assoc-ref build-details "uuid")
                          result))
                  result
                  (vector->list (assoc-ref response "builds")))))
           (display "." (current-error-port))
           (force-output (current-error-port))
           (if (< received-builds limit)
               new-result
               (loop (assoc-ref (vector-ref (assoc-ref response "builds")
                                            (- received-builds 1))
                                "uuid")
                     new-result)))))

     (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 "canceling ~A builds"
                                                       count)
                                        (current-error-port))
            (lambda (report)
              (for-each (lambda (id)
                          (send-cancel-build-request (assq-ref opts 'coordinator)
                                                     id)
                          (report))
                        matching-builds)))))
       ((build-id)
        (send-cancel-build-request (assq-ref opts 'coordinator)
                                   build-id)))))
  (("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" "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")))))
  (("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* ((metrics-registry (make-metrics-registry
                               #:namespace
                               "guixbuildcoordinator"))
            (datastore (database-uri->datastore
                        (assq-ref opts 'database)
                        #:metrics-registry metrics-registry))
            (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
                                #:datastore datastore
                                #:hooks hooks-with-defaults
                                #:metrics-registry metrics-registry
                                #: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)))))))