path: root/guix-build-coordinator/agent-messaging/http.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 agent-messaging http)
  #:use-module (srfi srfi-11)
  #:use-module (ice-9 match)
  #:use-module (ice-9 format)
  #:use-module (ice-9 textual-ports)
  #:use-module (ice-9 binary-ports)
  #:use-module (system repl error-handling)
  #:use-module (web server)
  #:use-module (rnrs bytevectors)
  #: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 (fibers channels)
  #:use-module (guix lzlib)
  #:use-module (guix base64)
  #:use-module (guix serialization)
  #:use-module (guix build utils)
  #:use-module (guix-build-coordinator utils)
  #:use-module (guix-build-coordinator datastore)
  #:use-module (guix-build-coordinator metrics)
  #:use-module (guix-build-coordinator coordinator)
  #:export (http-agent-messaging-start-server

            submit-status
            submit-log-file
            submit-build-result
            report-setup-failure
            submit-output
            fetch-builds-for-agent))

(define (fixed/read-request-body r)
  "Reads the request body from R, as a bytevector.  Return ‘#f’
if there was no request body."
  (cond
   ((member '(chunked) (request-transfer-encoding r))
    (make-chunked-input-port (request-port r)
                             ;; closing the port is handled elsewhere
                             #:keep-alive? #t))
   (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
             fixed/read-request-body)

(define (http-agent-messaging-start-server port host secret-key-base
                                           datastore hooks)
  (define trigger-build-allocation
    (make-build-allocator-thread datastore))

  (define hook-channel
    (make-hook-channel datastore hooks))

  (trigger-build-allocation)
  (call-with-error-handling
   (lambda ()
     (run-server
      (lambda (request body)
        (display
         (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
                           datastore
                           trigger-build-allocation
                           hook-channel)))
      'fibers
      (list #:host host
            #:port port)))
   #:on-error 'backtrace
   #:post-error (lambda (key . args)
                  (when (eq? key 'system-error)
                    (match args
                      (("bind" "~A" ("Address already in use") _)
                       (simple-format
                        (current-error-port)
                        "\n
error: guix-build-coordinator could not start, as it could not bind to port ~A

Check if it's already running, or whether another process is using that
port. Also, the port used can be changed by passing the --port option.\n"
                        port)))))))

(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* (render-text text #:key (extra-headers '())
                      (code 200))
  (list (build-response
         #:code code
         #:headers (append extra-headers
                           '((content-type . (text/plain))
                             (vary . (accept)))))
        (lambda (port)
          (display text port))))

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

(define (controller request
                    method-and-path-components
                    body
                    secret-key-base
                    datastore
                    trigger-build-allocation
                    hook-channel)
  (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=? auth-uuid uuid)
          (datastore-agent-password-exists? datastore
                                            uuid
                                            auth-password)))
        (_ #f))))

  (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
             ;; TODO Update status
             (render-json
              (agent-details datastore uuid)))
           (render-json
            "access denied"
            #:code 403)))
      (('POST "agent" uuid "fetch-builds")
       (if (authenticated? uuid request)
           (let ((builds (fetch-builds datastore uuid)))
             (render-json
              `((builds . ,(list->vector builds)))))
           (render-json
            "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 datastore hook-channel
                                    agent-id-for-build uuid
                                    (json-string->scm (utf8->string body)))
               ;; Trigger build allocation, as the result of this build could
               ;; change the allocation
               (trigger-build-allocation)
               (render-json
                "message received"))
             (render-json
              "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
                datastore hook-channel
                agent-id-for-build uuid
                (json-string->scm (utf8->string body)))
               ;; Trigger build allocation, so that the allocator can handle
               ;; this setup failure
               (trigger-build-allocation)
               (render-json
                "message received"))
             (render-json
              "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-location datastore uuid format)))
               (mkdir-p (dirname output-file-name))
               (call-with-output-file output-file-name
                 (lambda (output-port)
                   (let loop ((line (get-line body)))
                     (unless (eof-object? line)
                       (base64-decode line
                                      base64-alphabet
                                      output-port)
                       (loop (get-line body))))))
               (no-content))
             (render-json
              "access denied"
              #:code 403))))
      (('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)))
               (mkdir-p (dirname output-file-name))
               (call-with-output-file output-file-name
                 (lambda (output-port)
                   (let loop ((line (get-line body)))
                     (unless (eof-object? line)
                       (base64-decode line
                                      base64-alphabet
                                      output-port)
                       (loop (get-line body))))))
               (no-content))
             (render-json
              "access denied"
              #:code 403))))
      (('GET "metrics")
       (render-text
        (metrics datastore)))
      (_
       (render-json
        "not-found"
        #:code 404))))

  (call-with-error-handling
   controller-thunk
   #:on-error 'backtrace
   #:post-error (lambda args
                  (render-json
                   `((error . ,(simple-format #f "~A" args)))
                   #:code 500))))

(define (coordinator-uri-for-path base-uri-string agent-path)
  (let* ((base-uri (string->uri base-uri-string))
         (scheme (uri-scheme base-uri))
         (host   (uri-host base-uri))
         (port   (uri-port base-uri))
         (path   (uri-path base-uri)))
    (build-uri scheme
               #:host host
               #:port port
               #:path
               (string-append
                path
                (if (string-suffix? path "/")
                    agent-path
                    (string-drop agent-path 1))))))

(define (submit-status coordinator-uri agent-uuid password
                       status)
  (define auth-value
    (string-append
     "Basic "
     (base64-encode
      (string->utf8
       (string-append agent-uuid ":" password)))))

  (define uri
    (coordinator-uri-for-path
     coordinator-uri
     (string-append "/agent/" agent-uuid)))

  (let-values (((response body)
                (http-request
                 uri
                 #:method 'PUT                        ; TODO Should be PATCH
                 #:body (scm->json-string
                         `((status . ,status)))
                 #:headers
                 `((Authorization . ,auth-value)))))
    (json-string->scm (utf8->string body))))

(define (submit-output coordinator-uri agent-uuid password
                       build-id output-name file)
  (define auth-value
    (string-append
     "Basic "
     (base64-encode
      (string->utf8
       (string-append agent-uuid ":" password)))))

  (define uri
    (coordinator-uri-for-path
     coordinator-uri
     (string-append "/build/" build-id "/output/" output-name)))

  (call-with-streaming-http-request
   uri
   (lambda (port)
     (call-with-lzip-output-port port
       (lambda (port)
         (write-file file port))
       #:level 9))
   #:headers `((Authorization . ,auth-value))))

(define (submit-log-file coordinator-uri agent-uuid password
                         build-id file)
  (define auth-value
    (string-append
     "Basic "
     (base64-encode
      (string->utf8
       (string-append agent-uuid ":" password)))))

  (define format
    (cond
     ((string-suffix? ".bz2" file) "bzip2")
     ((string-suffix? ".gz" file)  "gzip")
     (else
      (error "unsupported log format for" file))))

  (define uri
    (coordinator-uri-for-path
     coordinator-uri
     (string-append "/build/" build-id "/log/" format)))

  (call-with-streaming-http-request
   uri
   (lambda (request-port)
     (call-with-input-file file
       (lambda (file-port)
         (dump-port file-port request-port))
       #:binary #t))
   #:headers `((Authorization . ,auth-value))))

(define (submit-build-result coordinator-uri agent-uuid password
                             build-id result)
  (define auth-value
    (string-append
     "Basic "
     (base64-encode
      (string->utf8
       (string-append agent-uuid ":" password)))))

  (define uri
    (coordinator-uri-for-path
     coordinator-uri
     (string-append "/build/" build-id)))

  (let-values (((response body)
                (http-request
                 uri
                 #:method 'PUT                        ; TODO Should be PATCH
                 #:body (scm->json-string result)
                 #:headers
                 `((Authorization . ,auth-value)))))
    (json-string->scm (utf8->string body))))

(define (report-setup-failure coordinator-uri agent-uuid password
                              build-id report)
  (define auth-value
    (string-append
     "Basic "
     (base64-encode
      (string->utf8
       (string-append agent-uuid ":" password)))))

  (define uri
    (coordinator-uri-for-path
     coordinator-uri
     (string-append "/build/" build-id "/report-setup-failure")))

  (let-values (((response body)
                (http-request
                 uri
                 #:method 'POST
                 #:body (scm->json-string report)
                 #:headers
                 `((Authorization . ,auth-value)))))
    (json-string->scm (utf8->string body))))

(define (fetch-builds-for-agent coordinator-uri agent-uuid password)
  (define auth-value
    (string-append
     "Basic "
     (base64-encode
      (string->utf8
       (string-append agent-uuid ":" password)))))

  (define uri
    (coordinator-uri-for-path
     coordinator-uri
     (string-append "/agent/" agent-uuid "/fetch-builds")))

  (let-values (((response body)
                (http-request
                 uri
                 #:method 'POST
                 #:headers
                 `((Authorization . ,auth-value)))))
    (vector->list
     (assoc-ref (json-string->scm (utf8->string body))
                "builds"))))