#!@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)
             (web uri)
             (fibers)
             (fibers conditions)
             (prometheus)
             ((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 build-allocator)
             (guix-build-coordinator agent-messaging http)
             (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) (cons key value)))
                                    (or (assq-ref result 'tags)
                                        '()))
                              (alist-delete 'tags 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 %service-options
  (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)))
        (option '("build-submitted-hook") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'build-submitted-hook
                              (read/eval arg)
                              (alist-delete 'build-submitted-hook result))))
        (option '("build-started-hook") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'build-started-hook
                              (read/eval arg)
                              (alist-delete 'build-started-hook 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
  `((agent-communication                  . "http://0.0.0.0:8745")
    (client-communication                 . "http://127.0.0.1:8746")
    (allocation-strategy                  . ,basic-build-allocation-strategy)
    (build-submitted-hook                 . ,default-build-submitted-hook)
    (build-started-hook                   . ,default-build-started-hook)
    (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))

;; Patch the fibers web server to allow running multiple servers

(let ((fibers-web-server-module
       (resolve-module '(fibers web server))))

  (define set-nonblocking!
    (module-ref fibers-web-server-module 'set-nonblocking!))

  (define make-default-socket
    (module-ref fibers-web-server-module 'make-default-socket))

  (define socket-loop
    (module-ref fibers-web-server-module 'socket-loop))

  (define* (run-server/patched handler #:key
                               (host #f)
                               (family AF_INET)
                               (addr (if host
                                         (inet-pton family host)
                                         INADDR_LOOPBACK))
                               (port 8080)
                               (socket (make-default-socket family addr port)))
    ;; We use a large backlog by default.  If the server is suddenly hit
    ;; with a number of connections on a small backlog, clients won't
    ;; receive confirmation for their SYN, leading them to retry --
    ;; probably successfully, but with a large latency.
    (listen socket 1024)
    (set-nonblocking! socket)
    (sigaction SIGPIPE SIG_IGN)
    (spawn-fiber (lambda () (socket-loop socket handler))))

  (module-set! fibers-web-server-module
               'run-server
               run-server/patched))

(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)))
     (define (display-build build-details)
       (simple-format #t "derivation name: ~A
priority:        ~A
processed?:      ~A
"
                      (assoc-ref build-details "derivation-name")
                      (assoc-ref build-details "priority")
                      (if (assoc-ref build-details "processed")
                          "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 (= 1 (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" "show-blocking" rest ...)
   (let ((opts (parse-options %base-options
                              %base-option-defaults
                              rest)))
     (let ((response (request-failed-builds-with-blocking-count-list
                      (assq-ref opts 'coordinator))))
       (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" 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 ((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))))
          (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 "password" "new" rest ...)
   (let ((opts (parse-options %base-options
                              %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" "list" rest ...)
   (let ((opts (parse-options %base-options %base-option-defaults rest)))
     (for-each (lambda (agent)
                 (simple-format
                  #t "~A: ~A\n"
                  (assoc-ref agent "uuid")
                  (or (assoc-ref agent "description")
                      "(no description)")))
               (vector->list
                (assoc-ref
                 (request-agents-list (assq-ref opts 'coordinator))
                 "agents")))))
  ((arguments ...)
   (let* ((opts (parse-options (append %service-options
                                       %base-options)
                               (append %service-option-defaults
                                       %base-option-defaults)
                               arguments))
          (metrics-registry (make-metrics-registry
                             #:namespace
                             "guixbuildcoordinator_"))
          (datastore (database-uri->datastore
                      (assq-ref opts 'database)
                      #:metrics-registry metrics-registry))
          (hooks
           `((build-submitted      . ,(assq-ref opts 'build-submitted-hook))
             (build-started        . ,(assq-ref opts 'build-started-hook))
             (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))))
          (build-coordinator (make-build-coordinator
                              #:datastore datastore
                              #:hooks hooks
                              #:metrics-registry metrics-registry
                              #:allocation-strategy
                              (assq-ref opts 'allocation-strategy))))

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

       (let* ((agent-communication-thunk
               (let ((agent-communication-uri
                      (assq-ref opts 'agent-communication)))
                 (match (uri-scheme agent-communication-uri)
                   ('http
                    (let ((host (uri-host agent-communication-uri))
                          (port (uri-port agent-communication-uri))
                          (chunked-request-channel
                           ;; There are fibers issues when trying to read the
                           ;; chunked requests
                           (make-worker-thread-channel (const '())
                                                       #:parallelism 8)))
                      (lambda ()
                        (simple-format #t "listening on ~A:~A\n"
                                       host port)
                        (http-agent-messaging-start-server
                         port
                         host
                         (assq-ref opts 'secret-key-base)
                         build-coordinator
                         chunked-request-channel)))))))
              (client-communication-thunk
               (let ((client-communication-uri
                      (assq-ref opts 'client-communication))
                     (substitutes-channel
                      (make-worker-thread-channel (const '())
                                                  #:parallelism 2)))
                 (lambda ()
                   (start-client-request-server
                    (assq-ref opts 'secret-key-base)
                    (uri-host client-communication-uri)
                    (uri-port client-communication-uri)
                    build-coordinator
                    substitutes-channel)))))

         (start-hook-processing-threads build-coordinator)
         (trigger-build-allocation build-coordinator)

         (let ((finished? (make-condition)))
           (call-with-sigint
            (lambda ()
              (run-fibers
               (lambda ()
                 (agent-communication-thunk)
                 (client-communication-thunk)

                 (wait finished?))))
            finished?)))))))