;;; Guix Build Coordinator
;;;
;;; Copyright © 2020 Christopher Baines <mail@cbaines.net>
;;;
;;; This file is part of the guix-build-coordinator.
;;;
;;; The Guix Build Coordinator is free software; you can redistribute
;;; it and/or modify it under the terms of the GNU General Public
;;; License as published by the Free Software Foundation; either
;;; version 3 of the License, or (at your option) any later version.
;;;
;;; The Guix Build Coordinator is distributed in the hope that it will
;;; be useful, but WITHOUT ANY WARRANTY; without even the implied
;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
;;; See the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with the guix-data-service.  If not, see
;;; <http://www.gnu.org/licenses/>.

(define-module (guix-build-coordinator agent-messaging http server)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-71)
  #:use-module (ice-9 match)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 threads)
  #:use-module (ice-9 format)
  #:use-module (ice-9 exceptions)
  #:use-module (ice-9 textual-ports)
  #:use-module (ice-9 binary-ports)
  #:use-module (system repl error-handling)
  #:use-module (rnrs bytevectors)
  #:use-module (logging logger)
  #:use-module (json)
  #:use-module (web http)
  #:use-module (web client)
  #:use-module (web request)
  #:use-module (web response)
  #:use-module (web uri)
  #:use-module (lzlib)
  #:use-module (gcrypt base16)
  #:use-module (gcrypt hash)
  #:use-module (fibers)
  #:use-module (fibers timers)
  #:use-module (fibers channels)
  #:use-module (fibers operations)
  #:use-module (prometheus)
  #:use-module (guix base32)
  #:use-module (guix base64)
  #:use-module (guix progress)
  #:use-module (guix build utils)
  #:use-module ((guix build syscalls)
                #:select (set-thread-name))
  #:use-module (guix-build-coordinator utils)
  #:use-module (guix-build-coordinator utils fibers)
  #:use-module (guix-build-coordinator datastore)
  #:use-module (guix-build-coordinator coordinator)
  #:export (make-output-hash-channel

            http-agent-messaging-start-server))

(define (bad-request message . args)
  (throw 'bad-request message args))

(define (read-request-body/patch r)
  "Reads the request body from R, as a bytevector.  Return ‘#f’
if there was no request body."
  (cond
   ;; TODO Change Guile to handle chunked request bodies
   ((member '(chunked) (request-transfer-encoding r))
    (make-chunked-input-port (request-port r)
                             ;; closing the port is handled elsewhere
                             #:keep-alive? #t))
   ;; Since the guile-fibers webserver/Guile force reading the request body as
   ;; a bytevector, patching read-request-body in this way to detect this
   ;; custom header allows handling some request bodies without reading it in
   ;; to a bytevector. This is used when handling file uploads.
   ((assq-ref (request-headers r) 'stream-body)
    (request-port r))
   (else
    (let ((nbytes (request-content-length r)))
      (and nbytes
           (let ((bv (get-bytevector-n (request-port r) nbytes)))
             (if (= (bytevector-length bv) nbytes)
                 bv
                 (bad-request "EOF while reading request body: ~a bytes of ~a"
                              (bytevector-length bv) nbytes))))))))

(module-set! (resolve-module '(web request))
             'read-request-body
             read-request-body/patch)

(define* (port-hash* algorithm port
                     #:key (reporter progress-reporter/silent))
  (let ((out get (open-hash-port algorithm)))
    (dump-port* port out #:reporter reporter)
    (close-port out)
    (get)))

(define (rate-limited proc interval)
  "Return a procedure that will forward the invocation to PROC when the time
elapsed since the previous forwarded invocation is greater or equal to
INTERVAL (a time-duration object), otherwise does nothing and returns #f."
  (let ((previous-at #f))
    (lambda args
      (let* ((now (current-time time-monotonic))
             (forward-invocation (lambda ()
                                   (set! previous-at now)
                                   (apply proc args))))
        (if previous-at
            (let ((elapsed (time-difference now previous-at)))
              (if (time>=? elapsed interval)
                  (forward-invocation)
                  #f))
            (forward-invocation))))))

(define* (progress-reporter/hash size callback
                                 #:key (progress-interval
                                        (make-time time-duration 0 10)))
  (define total 0)

  (progress-reporter
   (start (lambda ()
            (set! total 0)
            (callback 0)))
   (report (let ((report (rate-limited callback progress-interval)))
             (lambda (transferred)
               (set! total transferred)
               (report transferred))))
   (stop (lambda ()
           (let ((size (or size total)))
             (callback size))))))

(define (http-agent-messaging-start-server port host secret-key-base
                                           build-coordinator
                                           chunked-request-channel
                                           output-hash-channel)
  (define gc-metrics-updater
    (get-gc-metrics-updater
     (build-coordinator-metrics-registry build-coordinator)))

  (define port-metrics-updater
    (get-port-metrics-updater
     (build-coordinator-metrics-registry build-coordinator)))

  (define thread-metric
    (make-gauge-metric
     (build-coordinator-metrics-registry build-coordinator)
     "guile_threads_total"))

  (define datastore-metrics-updater
    (base-datastore-metrics-updater build-coordinator))

  (define (update-managed-metrics!)
    (call-with-delay-logging gc-metrics-updater)
    (metric-set thread-metric
                (length (all-threads)))
    (call-with-delay-logging port-metrics-updater)
    (call-with-delay-logging datastore-metrics-updater))

  (with-exception-handler
      (lambda (exn)
        (simple-format
         (current-error-port)
         "exception when starting: ~A\n" exn)
        (primitive-exit 1))
   (lambda ()
     (run-server/patched
      (lambda (request body)
        (log-msg (build-coordinator-logger build-coordinator)
                 'INFO
                 (format #f "~4a ~a\n"
                         (request-method request)
                         (uri-path (request-uri request))))
        (apply values
               (controller request
                           (cons (request-method request)
                                 (split-and-decode-uri-path
                                  (uri-path (request-uri request))))
                           body
                           secret-key-base
                           build-coordinator
                           chunked-request-channel
                           output-hash-channel
                           update-managed-metrics!)))
      #:host host
      #:port port))
   #:unwind? #t))

(define* (render-json json #:key (extra-headers '())
                      (code 200))
  (list (build-response
         #:code code
         #:headers (append extra-headers
                           '((content-type . (application/json))
                             (vary . (accept)))))
        (scm->json-string json)))

(define* (render-text text #:key (extra-headers '())
                      (code 200))
  (list (build-response
         #:code code
         #:headers (append extra-headers
                           '((content-type . (text/plain))
                             (vary . (accept)))))
        text))

(define (no-content)
  (list (build-response #:code 204)
        ""))

(define (base-datastore-metrics-updater build-coordinator)
  (define datastore
    (build-coordinator-datastore build-coordinator))

  (define registry
    (build-coordinator-metrics-registry build-coordinator))

  (let ((internal-real-time
         (make-gauge-metric registry "guile_internal_real_time"))
        (internal-run-time
         (make-gauge-metric registry "guile_internal_run_time"))
        (allocated-builds-total
         (make-gauge-metric registry
                            "allocated_builds_total"
                            #:labels '(agent_id)))
        (unprocessed-hook-events-total
         (make-gauge-metric registry
                            "unprocessed_hook_events_total"
                            #:labels '(event))))
    (define (zero-metric-for-agents metric)
      (for-each (lambda (agent-details)
                  (metric-set metric
                              0
                              #:label-values
                              `((agent_id . ,(assq-ref agent-details 'uuid)))))
                (datastore-list-agents datastore)))

    (define (update-agent-allocated-builds)
      (zero-metric-for-agents allocated-builds-total)
      (for-each (match-lambda
                  ((agent-id . count)
                   (metric-set allocated-builds-total
                               count
                               #:label-values
                               `((agent_id . ,agent-id)))))
                (datastore-count-allocated-builds datastore)))

    (define (update-unprocessed-hook-events)
      (for-each (match-lambda
                  ((event . _)
                   (metric-set unprocessed-hook-events-total
                               0
                               #:label-values
                               `((event . ,event)))))
                (build-coordinator-hooks build-coordinator))
      (for-each (lambda (event-count)
                  (metric-set unprocessed-hook-events-total
                              (assq-ref event-count 'count)
                              #:label-values
                              `((event . ,(assq-ref event-count 'event)))))
                (datastore-count-unprocessed-hook-events datastore)))

    (lambda ()
      (metric-set internal-real-time
                  (get-internal-real-time))
      (metric-set internal-run-time
                  (get-internal-run-time))

      ;; These are the db size metrics
      (call-with-delay-logging datastore-update-metrics!
                               #:args (list datastore))

      (call-with-delay-logging update-agent-allocated-builds)
      (call-with-delay-logging update-unprocessed-hook-events))))

(define-record-type <hash-progress>
  (make-hash-progress build-uuid file size bytes-hashed)
  hash-progress?
  (build-uuid    hash-progress-build-uuid)
  (file          hash-progress-file)
  (size          hash-progress-size)
  (bytes-hashed  hash-progress-bytes-hashed
                 set-hash-progress-bytes-hashed!))

(define (make-output-hash-channel build-coordinator)
  (define logger
    (build-coordinator-logger build-coordinator))

  (define (log-msg/safe . args)
    (with-exception-handler
        (const #t)
      (lambda ()
        (apply log-msg args))
      #:unwind? #t))

  (define (compute-hash-of-uploaded-output channel filename output-filename)
     (with-exception-handler
         (lambda (exn)
           (log-msg/safe
            logger
            'WARN
            "error computing hash: " exn)

           (when (file-exists? filename)
             (let ((md5-hash
                    (bytevector->base16-string
                     (file-hash (hash-algorithm md5) filename)))
                   (file-bytes
                    (stat:size (stat filename))))
               ;; I've seen exceptions happen here from lzip, so try
               ;; deleting the tmp file so that it's re-uploaded.
               (log-msg/safe logger 'WARN "deleting " filename)
               (delete-file filename)

               (raise-exception
                (make-exception
                 exn
                 (make-exception-with-irritants
                  `((file-bytes . ,file-bytes)
                    (md5-hash   . ,md5-hash)))))))

           exn)
       (lambda ()
         (let ((hash
                (bytevector->nix-base32-string
                 (call-with-input-file filename
                   (lambda (compressed-port)
                     (call-with-lzip-input-port
                         compressed-port
                       (lambda (port)
                         (port-hash* (hash-algorithm sha256)
                                     port
                                     #:reporter
                                     (progress-reporter/hash
                                      (stat:size (stat filename))
                                      (lambda (processed-bytes)
                                        (put-message
                                         channel
                                         `(update ,filename ,processed-bytes))))))))
                   #:binary #t))))

           (log-msg/safe
            logger
            'DEBUG
            "computed the hash of " filename ", renaming")

           (call-with-output-file (string-append output-filename ".hash")
             (lambda (port)
               (simple-format port "~A\n" hash)))

           (rename-file filename
                        output-filename)

           hash))
       #:unwind? #t))

  (let ((channel (make-channel))
        (update-channels-by-filename
         (make-hash-table))
        (hash-progress-by-filename
         (make-hash-table)))
    (define display-info
      (rate-limited
       (lambda ()
         (log-msg logger 'DEBUG "currently hashing "
                  (hash-count (const #t)
                              hash-progress-by-filename)
                  " files")
         (hash-for-each
          (lambda (filename progress)
            (match progress
              (($ <hash-progress> build-uuid filename size
                                  bytes-hashed)
               (log-msg logger 'DEBUG build-uuid ": hashing " filename
                        (if (= size bytes-hashed)
                            " finished"
                            "")
                        (format
                         #f
                         " ~2,2f/~2,2fMB"
                         (/ bytes-hashed 1000000)
                         (/ size 1000000))))))
          hash-progress-by-filename))
       (make-time time-duration 0 30)))

    (call-with-new-thread
     (lambda ()
       (set-thread-name "hash thread")

       (while #t
         (with-exception-handler
             (lambda (exn)
               (log-msg/safe logger 'ERROR "exception in output hash thread: " exn))
           (lambda ()
             (display-info)

             (match (get-message channel)
               (('request build-uuid filename output-filename update-channel)
                (or (and=>
                     (hash-ref update-channels-by-filename
                               filename)
                     (lambda (existing-channels)
                       (log-msg/safe logger 'DEBUG build-uuid
                                     ": adding channel to list for " filename)
                       (hash-set! update-channels-by-filename
                                  filename
                                  (cons update-channel
                                        existing-channels))))
                    (begin
                      (log-msg/safe logger 'DEBUG build-uuid
                                    ": starting thread to compute hash for " filename)
                      (let ((size
                             ;; This call could fail
                             (stat:size (stat filename))))
                        (hash-set! hash-progress-by-filename
                                   filename
                                   (make-hash-progress
                                    build-uuid
                                    filename
                                    size
                                    0))

                        (hash-set! update-channels-by-filename
                                   filename
                                   (list update-channel)))

                      (call-with-new-thread
                       (lambda ()
                         (catch 'system-error
                           (lambda ()
                             (set-thread-name "compute hash"))
                           (const #t))

                         (with-exception-handler
                             (lambda (exn)
                               (put-message channel
                                            (list 'result
                                                  filename
                                                  exn)))
                           (lambda ()
                             (set-thread-name "hash output")
                             (log-msg/safe logger 'DEBUG build-uuid
                                           ": computing hash of " filename)

                             (put-message
                              channel
                              (list 'result
                                    filename
                                    (compute-hash-of-uploaded-output channel
                                                                     filename
                                                                     output-filename))))
                           #:unwind? #t))))))
               (('update filename bytes-processed)
                (set-hash-progress-bytes-hashed!
                 (hash-ref hash-progress-by-filename filename)
                 bytes-processed)
                (for-each
                 (lambda (update-channel)
                   (spawn-fiber
                    (lambda ()
                      (perform-operation
                       (choice-operation
                        (put-operation update-channel bytes-processed)
                        (sleep-operation 5))))
                    (build-coordinator-scheduler build-coordinator)
                    #:parallel? #t))
                 (hash-ref update-channels-by-filename filename)))
               (('result filename result)
                (for-each
                 (lambda (update-channel)
                   (spawn-fiber
                    (lambda ()
                      (perform-operation
                       (choice-operation
                        (put-operation update-channel (list 'result result))
                        (sleep-operation 60))))
                    (build-coordinator-scheduler build-coordinator)
                    #:parallel? #t))
                 (hash-ref update-channels-by-filename filename))

                (hash-remove! update-channels-by-filename filename)
                (hash-remove! hash-progress-by-filename filename))))
           #:unwind? #t))))
    channel))

(define (start-computing-output-hash-via-channel output-hash-channel
                                                 request
                                                 response-port
                                                 build-uuid
                                                 tmp-output-file-name
                                                 output-file-name)
  (let ((channel (make-channel)))
    (put-message output-hash-channel
                 (list 'request build-uuid tmp-output-file-name output-file-name channel))

    channel))

(define (report-progress-computing-hash channel
                                        request
                                        response-port)
  (define (write-to-response-port response)
    (display response response-port)
    (force-output response-port)
    ;; TODO because the chunked output port
    ;; doesn't call force-output on the
    ;; underlying port, do that here. We
    ;; want this event to be sent now,
    ;; rather than when some buffer fills
    ;; up.
    (force-output (request-port request)))

  (define (get-message* channel)
    (perform-operation
     (choice-operation
      (get-operation channel)
      (wrap-operation
       (sleep-operation 20)
       (const 'timeout)))))

  (let loop ((previous-bytes-processed 0)
             (message (get-message* channel)))
    (match message
      (('result result) result)
      ('timeout
       (write-to-response-port
        (simple-format #f "~A\n" previous-bytes-processed))
       (loop previous-bytes-processed
             (get-message* channel)))
      (bytes-processed
       (if (> bytes-processed previous-bytes-processed)
           (begin
             (write-to-response-port
              (simple-format #f "~A\n" bytes-processed))
             (loop bytes-processed
                   (get-message* channel)))
           (begin
             ;; Still write to keep the connection open
             (write-to-response-port
              (simple-format #f "~A\n" previous-bytes-processed))
             (loop previous-bytes-processed
                   (get-message* channel))))))))

(define* (receive-file body
                       length
                       output-file-name
                       #:key append?)
  (define body-port
    (if (bytevector? body)
        ;; If the Stream-Body header isn't set, then it's possible
        ;; that the body will be a port
        (open-bytevector-input-port body)
        body))

  (call-with-port
      (if append?
          (open-file output-file-name "a")
          (open-output-file output-file-name #:binary #t))
    (lambda (output-port)
      (let ((start-time (current-time time-utc)))

        (define output-progress
          (rate-limited
           (lambda (bytes-read)
             (display
              (simple-format
               #f
               "receiving ~A
  ~AMB read so far...
"
               (basename output-file-name)
               (format #f "~2,2f"
                       (/ bytes-read
                          1000000)))))
           (make-time time-duration 0 20)))

        (dump-port
         body-port
         output-port
         length
         #:progress
         (lambda (bytes-transfered continue-thunk)
           (output-progress bytes-transfered)
           (continue-thunk)))

        (when length
          (let* ((end-time (current-time time-utc))
                 (elapsed (time-difference end-time
                                           start-time))
                 (seconds-elapsed
                  (+ (time-second elapsed)
                     (/ (time-nanosecond elapsed) 1e9))))
            (display
             (simple-format
              #f
              "received ~A
  took ~A seconds
  data transfered: ~AMB (~A bytes)
  speed (MB/s): ~A
"
              (basename output-file-name)
              seconds-elapsed
              (format #f "~2,2f" (/ length 1000000))
              length
              (format #f "~2,2f" (/ (/ length 1000000)
                                    seconds-elapsed))))))))))

(define (controller request
                    method-and-path-components
                    body
                    secret-key-base
                    build-coordinator
                    chunked-request-channel
                    output-hash-channel
                    update-managed-metrics!)
  (define (authenticated? uuid request)
    (let* ((authorization-base64
            (match (assq-ref (request-headers request)
                             'authorization)
              (('basic . s) s)))
           (authorization
            (utf8->string
             (base64-decode authorization-base64))))
      (match (string-split authorization #\:)
        ((auth-uuid auth-password)
         (and
          (string? uuid)
          (string=? auth-uuid uuid)
          (datastore-agent-password-exists? datastore
                                            uuid
                                            auth-password)))
        (_ #f))))

  (define datastore
    (build-coordinator-datastore build-coordinator))

  (define logger
    (build-coordinator-logger build-coordinator))

  (define (controller-thunk)
    (match method-and-path-components
      (('GET "agent" uuid)
       (let ((agent (datastore-find-agent datastore uuid)))
         (if agent
             (render-json
              `((agent . ,uuid)
                ,@agent))
             (render-json
              (simple-format #f "no agent found with id: ~A"
                             uuid)
              #:code 404))))
      (('PUT "agent" uuid)
       (if (authenticated? uuid request)
           (begin
             (let* ((json-body (json-string->scm (utf8->string body)))
                    (status (assoc-ref json-body "status"))
                    (1min-load-average (and=> (assoc-ref json-body "load_average")
                                              (lambda (load-average)
                                                (assoc-ref load-average "1"))))
                    (system-uptime (assoc-ref json-body "system_uptime"))
                    (processor-count (assoc-ref json-body "processor_count"))
                    (initial-status-update
                     (eq? #t (assoc-ref json-body "initial_status_update"))))

               (update-agent-status build-coordinator uuid
                                    status 1min-load-average
                                    system-uptime
                                    processor-count
                                    #:initial-status-update?
                                    initial-status-update))

             (render-json
              (agent-details build-coordinator uuid)))
           (render-json
            '(("error" . "access denied"))
            #:code 403)))
      (('POST "agent" "fetch-session-credentials")
       (let* ((query-parameters (request-query-parameters request))
              (name             (assq-ref query-parameters 'name))
              (token            (assq-ref query-parameters 'token)))
         (if (and (string? name)
                  (string? token))
             (if (datastore-dynamic-auth-token-exists? datastore token)
                 (let ((agent-uuid (or (datastore-find-agent-by-name
                                        datastore
                                        name)
                                       (new-agent datastore
                                                  #:name name))))
                   (let ((password
                          (match (datastore-agent-list-passwords datastore
                                                                 agent-uuid)
                            (()
                             (new-agent-password datastore #:agent agent-uuid))
                            ((password . rest)
                             password))))
                     (render-json
                      `((id       . ,agent-uuid)
                        (password . ,password)))))
                 (render-json
                  '(("error" . "token not recognised"))
                  #:code 403))
             (render-json
              '(("error" . "access denied"))
              #:code 403))))
      (('POST "agent" uuid "fetch-builds")
       (if (authenticated? uuid request)
           (let* ((json-body (json-string->scm (utf8->string body)))
                  ;; count is deprecated, use target_count instead
                  (count (assoc-ref json-body "count"))
                  (target-count (assoc-ref json-body "target_count"))
                  (systems (assoc-ref json-body "systems"))
                  (builds (fetch-builds build-coordinator uuid
                                        (vector->list systems)
                                        target-count
                                        count)))
             (render-json
              `((builds . ,(list->vector builds)))))
           (render-json
            '(("error" . "access denied"))
            #:code 403)))
      (('PUT "build" uuid)
       (let ((agent-id-for-build
              (datastore-agent-for-build datastore uuid)))
         (if (authenticated? agent-id-for-build request)
             (begin
               (handle-build-result build-coordinator
                                    agent-id-for-build uuid
                                    (json-string->scm (utf8->string body)))
               (render-json
                "message received"))
             (render-json
              '(("error" . "access denied"))
              #:code 403))))
      (('POST "build" uuid "report-build-start")
       (let ((agent-id-for-build
              (datastore-agent-for-build datastore uuid)))
         (if (authenticated? agent-id-for-build request)
             (begin
               (handle-build-start-report build-coordinator
                                          agent-id-for-build
                                          uuid)
               (render-json
                "message received"))
             (render-json
              '(("error" . "access denied"))
              #:code 403))))
      (('POST "build" uuid "report-setup-failure")
       (let ((agent-id-for-build
              (datastore-agent-for-build datastore uuid)))
         (if (authenticated? agent-id-for-build request)
             (begin
               (handle-setup-failure-report
                build-coordinator
                agent-id-for-build uuid
                (json-string->scm (utf8->string body)))
               (render-json
                "message received"))
             (render-json
              '(("error" . "access denied"))
              #:code 403))))
      (('PUT "build" uuid "log" format)
       (let ((agent-id-for-build
              (datastore-agent-for-build datastore uuid)))
         (if (authenticated? agent-id-for-build request)
             (let* ((output-file-name
                     (build-log-file-destination uuid format))
                    (tmp-output-file-name
                     (string-append output-file-name ".tmp")))
               (mkdir-p (dirname output-file-name))
               (when (file-exists? tmp-output-file-name)
                 (delete-file tmp-output-file-name))

               (for-each
                (lambda (file)
                  (log-msg logger 'WARN uuid ": removing stale log file " file)

                  (delete-file (string-append (dirname output-file-name)
                                              "/"
                                              file)))
                (scandir (dirname output-file-name)
                         (lambda (file)
                           (not (member file '("." ".."))))))

               (let ((body-port
                      (if (bytevector? body)
                          ;; If the Stream-Body header isn't set, then it's possible
                          ;; that the body will be a port
                          (open-bytevector-input-port body)
                          body)))
                 (call-with-output-file tmp-output-file-name
                   (lambda (output-port)
                     ;; Older agents may still attempt to use chunked encoding
                     ;; for this request
                     (if (member '(chunked) (request-transfer-encoding request))
                         (call-with-worker-thread
                          chunked-request-channel
                          (lambda ()
                            (dump-port body-port
                                       output-port
                                       (request-content-length request))))
                         (dump-port body-port
                                    output-port
                                    (request-content-length request))))))
               (rename-file tmp-output-file-name
                            output-file-name)
               (no-content))
             (render-json
              '(("error" . "access denied"))
              #:code 403))))
      (('HEAD "build" uuid "output" output-name)
       (let ((agent-id-for-build
              (datastore-agent-for-build datastore uuid)))
         (if (authenticated? agent-id-for-build request)
             (let* ((output-file-name
                     (build-output-file-location datastore uuid output-name)))
               (if (file-exists? output-file-name)
                   (let ((bytes (stat:size (stat output-file-name))))
                     (list (build-response
                            #:code 200
                            #:headers `((content-length . ,bytes)))
                           #f))
                   (list (build-response #:code 404)
                         #f)))
             (list (build-response #:code 403)
                   #f))))
      (('PUT "build" uuid "output" output-name)
       (let ((agent-id-for-build
              (datastore-agent-for-build datastore uuid)))

         (if (authenticated? agent-id-for-build request)
             (let* ((output-file-name
                     (build-output-file-location datastore uuid output-name))
                    (tmp-output-file-name
                     (string-append output-file-name ".tmp")))
               (mkdir-p (dirname output-file-name))

               (when (file-exists? output-file-name)
                 (log-msg logger
                          'WARN
                          "PUT /build/" uuid "/output/" output-name ": "
                          "deleting " output-file-name)
                 (delete-file output-file-name))
               (when (file-exists? tmp-output-file-name)
                 (log-msg logger
                          'WARN
                          "PUT /build/" uuid "/output/" output-name ": "
                          "deleting " tmp-output-file-name)
                 (delete-file tmp-output-file-name))

               (if (member '(chunked) (request-transfer-encoding request))
                   ;; Older agents may use chunked encoding for this request
                   (call-with-worker-thread
                    chunked-request-channel
                    (lambda ()
                      (receive-file body
                                    #f
                                    tmp-output-file-name)))
                   (let ((content-length
                          (request-content-length request)))
                     (when (> content-length 0)
                       (receive-file body
                                     content-length
                                     tmp-output-file-name))))

               (if (file-exists? output-file-name)
                   (render-json
                    '(("success" . "upload already finished"))
                    #:code 200)
                   (if (file-exists? tmp-output-file-name)
                       (let ((channel
                              (start-computing-output-hash-via-channel
                               output-hash-channel
                               request
                               response-port
                               uuid
                               tmp-output-file-name
                               output-file-name)))

                         (log-msg logger
                                  'DEBUG
                                  "PUT /build/" uuid "/output/" output-name ": "
                                  "finished receiving " tmp-output-file-name)

                         (list
                          (build-response
                           #:code 200
                           #:headers '((content-type . (text/plain))))
                          (lambda (response-port)
                            ;; Make sure NGinx gets the response headers
                            (force-output (request-port request))

                            (report-progress-computing-hash channel
                                                            request
                                                            response-port))))
                       (render-json
                        '(("error" . "tmp file missing"))
                        #:code 400))))
             (render-json
              '(("error" . "access denied"))
              #:code 403))))
      (('HEAD "build" uuid "output" output-name "partial")
       (let ((agent-id-for-build
              (datastore-agent-for-build datastore uuid)))
         (if (authenticated? agent-id-for-build request)
             (let* ((output-file-name
                     (build-output-file-location datastore uuid output-name))
                    (tmp-output-file-name
                     (string-append output-file-name ".tmp")))
               (if (file-exists? tmp-output-file-name)
                   (let ((bytes (stat:size (stat tmp-output-file-name))))
                     (list (build-response
                            #:code 200
                            #:headers `((content-length . ,bytes)))
                           #f))
                   (list (build-response #:code 404)
                         #f)))
             (list (build-response #:code 403)
                   #f))))
      (('POST "build" uuid "output" output-name "partial")
       (let ((agent-id-for-build
              (datastore-agent-for-build datastore uuid)))

         (if (authenticated? agent-id-for-build request)
             (let* ((output-file-name
                     (build-output-file-location datastore uuid output-name))
                    (tmp-output-file-name
                     (string-append output-file-name ".tmp"))
                    (content-length
                     (request-content-length request)))

               ;; An agent may make this request with a content length of 0 to
               ;; resume waiting for the hash to be computed
               (unless (= content-length 0)
                 ;; If the output file exists, delete it, as it's being uploaded
                 ;; again
                 (when (file-exists? output-file-name)
                   (log-msg logger
                            'WARN
                            "POST /build/" uuid "/output/" output-name "/partial: "
                            "deleting " output-file-name)
                   (delete-file output-file-name))

                 (if (member '(chunked) (request-transfer-encoding request))
                     ;; Older agents may use chunked encoding for this request
                     (call-with-worker-thread
                      chunked-request-channel
                      (lambda ()
                        (receive-file body
                                      #f
                                      tmp-output-file-name
                                      #:append? #t)))
                     (receive-file body
                                   (request-content-length request)
                                   tmp-output-file-name
                                   #:append? #t)))

               (if (file-exists? output-file-name)
                   (render-json
                    '(("success" . "upload already finished"))
                    #:code 200)
                   (if (file-exists? tmp-output-file-name)
                       (let ((channel
                              (start-computing-output-hash-via-channel
                               output-hash-channel
                               request
                               response-port
                               uuid
                               tmp-output-file-name
                               output-file-name)))

                         (apply log-msg
                                logger
                                'DEBUG
                                "POST /build/" uuid "/output/" output-name "/partial: "
                                (if (= content-length 0)
                                    `("sending response for " ,tmp-output-file-name
                                      " upload")
                                    `("finished receiving " ,tmp-output-file-name)))

                         (list
                          (build-response
                           #:code 200
                           #:headers '((content-type . (text/plain))))
                          (lambda (response-port)
                            ;; Make sure NGinx gets the response headers
                            (force-output (request-port request))

                            (report-progress-computing-hash channel
                                                            request
                                                            response-port))))
                       (render-json
                        '(("error" . "tmp file missing"))
                        #:code 400))))
             (render-json
              '(("error" . "access denied"))
              #:code 403))))
      (('GET "metrics")
       (call-with-duration-metric
        (build-coordinator-metrics-registry build-coordinator)
        "metrics_duration_seconds"
        (lambda ()
          (with-fibers-timeout
           (lambda ()
             (call-with-delay-logging update-managed-metrics!
                                      #:threshold 0.5))
           #:timeout 8
           #:on-timeout (const #f))

          (list (build-response
                 #:code 200
                 #:headers '((content-type . (text/plain))
                             (vary . (accept))))
                (lambda (port)
                  (write-metrics (build-coordinator-metrics-registry
                                  build-coordinator)
                                 port))))))
      (_
       (render-json
        "not-found"
        #:code 404))))

  (with-exception-handler
      (lambda (exn)
        (cond
         ((agent-error? exn)
          (render-json
           `((error . ,(agent-error-details exn)))
           #:code 400))
         ((chunked-input-ended-prematurely-error? exn)
          (render-json
           `((error . chunked-input-ended-prematurely))
           #:code 400))
         ((worker-thread-timeout-error? exn)
          (render-json
           `((error . ,(simple-format #f "~A" exn)))
           #:code 503))
         (else
          (render-json
           `((error . ,(simple-format #f "~A" exn)))
           #:code 500))))
    (lambda ()
      (with-throw-handler #t
        controller-thunk
        (lambda (key . args)
          (unless (and (eq? '%exception key)
                       (or (agent-error? (car args))
                           (worker-thread-timeout-error? (car args))
                           (chunked-input-ended-prematurely-error? (car args))))
            (match method-and-path-components
              ((method path-components ...)
               (simple-format
                (current-error-port)
                "error: when processing: /~A ~A\n  ~A ~A\n"
                method (string-join path-components "/")
                key args)))

            (let* ((stack (make-stack #t 4))
                   (backtrace
                    (call-with-output-string
                      (lambda (port)
                        (display "\nBacktrace:\n" port)
                        (display-backtrace stack port)
                        (newline port)
                        (newline port)))))
              (display
               backtrace
               (current-error-port)))))))
    #:unwind? #t))