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 (srfi srfi-19)
  #:use-module (ice-9 match)
  #:use-module (ice-9 format)
  #:use-module (ice-9 threads)
  #: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 (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 (prometheus)
  #:use-module (guix store)
  #: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 coordinator)
  #:export (submit-status
            submit-log-file
            submit-build-result
            report-build-start
            report-setup-failure
            submit-output
            fetch-builds-for-agent))

(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 (with-request-mutex thunk)
  (monitor (thunk)))

(define* (coordinator-handle-failed-request method path response body
                                            #:key first-request-failed?)
  (simple-format
   (current-error-port)
   "error: coordinator-http-request: ~A ~A: ~A\n"
   method path (response-code response))

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

(define* (coordinator-http-request coordinator-uri agent-uuid password
                                   path
                                   #:key method body (headers '())
                                   succeed-on-access-denied-retry?)
  (define auth-value
    (string-append
     "Basic "
     (base64-encode
      (string->utf8
       (string-append agent-uuid ":" password)))))

  (define uri
    (coordinator-uri-for-path coordinator-uri
                              path))

  (define first-request-failed? #f)

  (define (make-request)
    (let-values (((response body)
                  (with-request-mutex
                   (lambda ()
                     (http-request uri
                                   #:method method
                                   #:body (scm->json-string body)
                                   #:decode-body? #f
                                   #:headers
                                   `((Authorization . ,auth-value)
                                     ,@headers))))))
      (if (>= (response-code response) 400)
          (let ((body
                 (coordinator-handle-failed-request method
                                                    path
                                                    response
                                                    body)))
            (if (and first-request-failed?
                     succeed-on-access-denied-retry?
                     (equal? body
                             '(("error" . "access denied"))))
                (begin
                  (simple-format
                   (current-error-port)
                   "warning: treating access denied response as success\n")
                  (values body response))
                (begin
                  (set! first-request-failed? #t)
                  (raise-exception
                   (make-exception-with-message
                    body)))))
          (values
           (json-string->scm (utf8->string body))
           response))))

  (retry-on-error make-request
                  #:times 9
                  #:delay 10))

(define (submit-status coordinator-uri agent-uuid password
                       status)
  (coordinator-http-request
   coordinator-uri agent-uuid password
   (string-append "/agent/" agent-uuid)
   #:method 'PUT                        ; TODO Should be PATCH
   #:body `((status . ,status))))

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

  (define path-info
    (with-store store
      (query-path-info store file)))

  ;; For small outputs, compress while sending the data, but for bigger store
  ;; items, do all the compression up front to hopefully reduce the time to
  ;; send them.
  (if (< (path-info-nar-size path-info)
         5000000)                       ; 5MB
      (retry-on-error
       (lambda ()
         (with-request-mutex
          (lambda ()
            (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))))))
       #:times 3
       #:delay 30)
      (let* ((directory (or (getenv "TMPDIR") "/tmp"))
             (template  (string-append directory
                                       "/guix-build-coordinator-file.XXXXXX"))
             (out       (mkstemp! template)))
        (simple-format #t "compressing ~A -> ~A prior to sending\n"
                       file template)
        (call-with-lzip-output-port out
          (lambda (port)
            (write-file file port))
          #:level 9)
        (close-port out)

        (simple-format #t "finished compressing ~A, now sending\n" file)
        (retry-on-error
         (lambda ()
           (with-request-mutex
            (lambda ()
              (call-with-input-file template
                (lambda (file-port)
                  (let-values (((response body)
                                (call-with-streaming-http-request
                                 uri
                                 (lambda (port)
                                   (with-time-logging
                                    (simple-format #f "sending ~A" file)
                                    (dump-port file-port port
                                               #:buffer-size (expt 2 20))))
                                 #:headers `((Authorization . ,auth-value)))))
                    (when (>= (response-code response) 400)
                      (raise-exception
                       (make-exception-with-message
                        (coordinator-handle-failed-request 'PUT
                                                           (uri-path uri)
                                                           response
                                                           body))))))))))
         #:times 9
         #:delay (+ 60 (random 120)))

        (delete-file template))))

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

  (retry-on-error
   (lambda ()
     (with-request-mutex
      (lambda ()
        (let-values (((response body)
                      (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)))))
          (if (>= (response-code response) 400)
              (raise-exception
               (make-exception-with-message
                (coordinator-handle-failed-request 'PUT
                                                   (uri-path uri)
                                                   response
                                                   body)))
              (begin
                (simple-format #t "~A: successfully uploaded log file (~A)\n"
                               build-id
                               (response-code response))
                #t))))))
   #:times 9
   #:delay (+ 30 (random 60))))

(define (submit-build-result coordinator-uri agent-uuid password
                             build-id result)
  (coordinator-http-request
   coordinator-uri agent-uuid password
   (string-append "/build/" build-id)
   #:method 'PUT                        ; TODO Should be PATCH
   #:body result))

(define (report-build-start coordinator-uri agent-uuid password
                            build-id)
  (coordinator-http-request
   coordinator-uri agent-uuid password
   (string-append "/build/" build-id "/report-build-start")
   #:method 'POST))

(define (report-setup-failure coordinator-uri agent-uuid password
                              build-id report)
  (coordinator-http-request
   coordinator-uri agent-uuid password
   (string-append "/build/" build-id "/report-setup-failure")
   #:method 'POST
   #:body report
   #:succeed-on-access-denied-retry? #t))

(define* (fetch-builds-for-agent coordinator-uri agent-uuid password
                                 systems
                                 #:key (count 1))
  (vector->list
   (assoc-ref (coordinator-http-request
               coordinator-uri agent-uuid password
               (string-append "/agent/" agent-uuid "/fetch-builds")
               #:body `((count               . ,count)
                        (systems . ,(list->vector systems)))
               #:method 'POST)
              "builds")))