path: root/guix-build-coordinator/client-communication.scm

;;; 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 client-communication)
  #:use-module (srfi srfi-11)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (ice-9 exceptions)
  #:use-module (rnrs bytevectors)
  #:use-module (json)
  #:use-module (logging logger)
  #:use-module (web uri)
  #:use-module (web client)
  #:use-module (web request)
  #:use-module (web response)
  #:use-module (system repl error-handling)
  #:use-module (guix store)
  #:use-module (guix derivations)
  #: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 (start-client-request-server

            send-submit-build-request
            request-build-details
            request-output-details
            request-agents-list
            request-failed-builds-with-blocking-count-list
            send-create-agent-request
            send-create-agent-password-request))

(define (start-client-request-server secret-key-base
                                     host
                                     port
                                     build-coordinator
                                     substitutes-channel)
  (call-with-error-handling
   (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
                           substitutes-channel)))
      #:host host
      #:port port))
   #:on-error 'backtrace))

(define (controller request
                    method-and-path-components
                    raw-body
                    secret-key-base
                    build-coordinator
                    substitutes-channel)
  (define datastore
    (build-coordinator-datastore build-coordinator))

  (define body
    (if raw-body
        (json-string->scm (utf8->string raw-body))
        '()))

  (define (controller-thunk)
    (match method-and-path-components
      (('GET "build" uuid)
       (match (datastore-find-build datastore uuid)
         (#f
          (render-json '((error . "no build found"))
                       #:code 404))
         (build-details
          (let ((derivation-inputs
                 (map
                  (lambda (derivation-input-details)
                    (let ((builds (datastore-list-builds-for-output
                                   datastore
                                   (assq-ref derivation-input-details
                                             'output))))
                      `(,@derivation-input-details
                        (builds . ,(list->vector builds)))))
                  (datastore-find-derivation-inputs
                   datastore
                   (assq-ref build-details 'derivation-name))))
                (setup-failures
                 (map
                  (lambda (setup-failure)
                    `(,@setup-failure
                      ,@(if (string=? (assq-ref setup-failure 'failure-reason)
                                      "missing_inputs")
                            `((missing-inputs
                               . ,(list->vector
                                   (map
                                    (lambda (missing-input)
                                      (let ((builds-for-missing-input
                                             (datastore-list-builds-for-output
                                              datastore
                                              missing-input)))
                                        `((missing-input . ,missing-input)
                                          (builds . ,(list->vector
                                                      builds-for-missing-input)))))
                                    (datastore-list-setup-failure-missing-inputs
                                     datastore
                                     (assq-ref setup-failure 'id))))))
                            '())))
                  (datastore-list-setup-failures-for-build
                   datastore
                   (assq-ref build-details 'uuid)))))
            (render-json
             `(,@build-details
               (derivation-inputs . ,(list->vector derivation-inputs))
               (setup-failures    . ,(list->vector setup-failures))))))))
      (('GET "builds" "blocking")
       (render-json
        `((builds
           . ,(list->vector
               (datastore-list-failed-builds-with-blocking-count datastore))))))
      (('GET "output" output-components ...)
       (let* ((output (string-append
                       "/" (string-join output-components "/")))
              (builds (datastore-list-builds-for-output datastore
                                                        output)))
         (render-json
          `((builds . ,(list->vector builds))))))
      (('GET "agents")
       (render-json
        `((agents . ,(list->vector (datastore-list-agents datastore))))))
      (('POST "agents")
       (let ((uuid (new-agent
                    datastore
                    #:requested-uuid (assoc-ref body "requested-uuid")
                    #:description (assoc-ref body "description"))))
         (render-json
          `((agent-id . ,uuid)))))
      (('POST "agent" agent-id "passwords")
       (let ((password (new-agent-password
                        datastore
                        #:agent agent-id)))
         (render-json
          `((new-password . ,password)))))
      (('POST "builds")
       (let ((derivation-file (assoc-ref body "derivation")))
         (let ((derivation-database-entry
                (datastore-find-derivation datastore derivation-file)))
           (unless derivation-database-entry
             (unless (with-store store
                       (valid-path? store derivation-file))
               (call-with-worker-thread
                substitutes-channel
                (lambda ()
                  (let ((raw-substitute-urls
                         (assoc-ref body "substitute-urls")))
                    (substitute-derivation derivation-file
                                           #:substitute-urls
                                           (and=> raw-substitute-urls
                                                  vector->list))))))
             (datastore-store-derivation
              datastore
              (read-derivation-from-file derivation-file))))

         (let ((submit-build-result
                (apply
                 submit-build
                 `(,build-coordinator
                   ,derivation-file
                   ,@(let ((priority (assoc-ref body "priority")))
                       (if priority
                           `(#:priority ,priority)
                           '()))
                   ,@(if (assoc-ref body "ignore-if-build-for-derivation-exists")
                         '(#:ignore-if-build-for-derivation-exists? #t)
                         '())
                   ,@(if (assoc-ref body "ignore-if-build-for-outputs-exists")
                         '(#:ignore-if-build-for-outputs-exists? #t)
                         '())
                   ,@(if (assoc-ref
                          body "ensure-all-related-derivation-outputs-have-builds")
                         '(#:ensure-all-related-derivation-outputs-have-builds? #t)
                         '())
                   ,@(if (assoc-ref body "tags")
                         `(#:tags
                           ,(map
                             (lambda (tag)
                               (cons (assoc-ref tag "key")
                                     (assoc-ref tag "value")))
                             (vector->list (assoc-ref body "tags"))))
                         '())))))
           (render-json submit-build-result))))
      (_
       (render-json
        "not-found"
        #:code 404))))

  (call-with-error-handling
   controller-thunk
   #:on-error 'backtrace
   #:post-error (lambda args
                  (match method-and-path-components
                    ((method path-components ...)
                     (simple-format
                      (current-error-port)
                      "error: when processing: /~A ~A\n"
                      method (string-join path-components "/"))))
                  (render-json
                   `((error . ,(simple-format #f "~A" args)))
                   #:code 500))))

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

(define* (send-request coordinator-uri
                       method
                       path
                       #:optional
                       request-body)
  (let-values (((response body)
                (http-request (string->uri
                               (string-append coordinator-uri path))
                              #:method method
                              #:body (and=> request-body scm->json-string)
                              #:decode-body? #f)))
    (if (>= (response-code response) 400)
        (begin
          (simple-format
           (current-error-port)
           "error: coordinator-http-request: ~A ~A: ~A\n"
           method path (response-code response))
          (let ((body
                 (catch #t
                   (lambda ()
                     (if (equal? '(application/json (charset . "utf-8"))
                                 (response-content-type response))
                         (json-string->scm (utf8->string body))
                         (utf8->string body)))
                   (lambda (key . args)
                     (simple-format
                      (current-error-port)
                      "error decoding body ~A ~A\n"
                      key args)
                     #f))))
            (raise-exception
             (make-exception-with-message
              body))))
        (values
         (json-string->scm (utf8->string body))
         response))))

(define (send-submit-build-request
         coordinator-uri
         derivation-file-name
         substitute-urls
         requested-uuid
         priority
         ignore-if-build-for-derivation-exists?
         ignore-if-build-for-outputs-exists?
         ensure-all-related-derivation-outputs-have-builds?
         tags)
  (send-request coordinator-uri
                'POST
                "/builds"
                `((derivation      . ,derivation-file-name)
                  (priority        . ,priority)
                  ,@(if substitute-urls
                        `((substitute-urls . ,(list->vector substitute-urls)))
                        '())
                  ,@(if ignore-if-build-for-derivation-exists?
                        '((ignore-if-build-for-derivation-exists . #t))
                        '())
                  ,@(if ignore-if-build-for-outputs-exists?
                        '((ignore-if-build-for-outputs-exists . #t))
                        '())
                  ,@(if ensure-all-related-derivation-outputs-have-builds?
                        '((ensure-all-related-derivation-outputs-have-builds . #t))
                        '())
                  ,@(if (null? tags)
                        '()
                        `((tags . ,(list->vector
                                    (map (match-lambda
                                           ((key . value)
                                            `((key   . ,key)
                                              (value . ,value))))
                                         tags))))))))

(define (request-build-details coordinator-uri
                               uuid)
  (send-request coordinator-uri
                'GET
                (string-append "/build/" uuid)))

(define (request-output-details coordinator-uri
                                output)
  (send-request coordinator-uri
                'GET
                (string-append "/output" output)))

(define (request-agents-list coordinator-uri)
  (send-request coordinator-uri
                'GET
                (string-append "/agents")))

(define (request-failed-builds-with-blocking-count-list coordinator-uri)
  (send-request coordinator-uri
                'GET
                (string-append "/builds/blocking")))

(define* (send-create-agent-request coordinator-uri
                                    #:key
                                    requested-uuid
                                    description)
  (send-request coordinator-uri
                'POST
                "/agents"
                `(,@(if requested-uuid
                        `((requested-uuid . ,requested-uuid))
                        '())
                  ,@(if description
                        `((description . ,description))
                        '()))))

(define (send-create-agent-password-request coordinator-uri
                                            agent-id)
  (send-request coordinator-uri
                'POST
                (string-append "/agent/" agent-id "/passwords")))