;;; Guix Build Coordinator ;;; ;;; Copyright © 2020 Christopher Baines ;;; ;;; 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 ;;; . (define-module (guix-build-coordinator client-communication) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-19) #:use-module (srfi srfi-43) #: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 (gcrypt random) #: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 send-cancel-build-request request-build-details request-builds-list request-output-details request-agent-details request-agents-list request-failed-builds-with-blocking-count-list send-create-agent-request send-create-agent-password-request send-create-dynamic-auth-token-request send-replace-agent-tags-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)))) (tags (datastore-fetch-build-tags datastore uuid))) (render-json `(,@(alist-delete 'created-at (alist-delete 'end-time build-details)) (created-at . ,(or (and=> (assq-ref build-details 'created-at) (lambda (time) (strftime "%F %T" time))) 'null)) (end-time . ,(or (and=> (assq-ref build-details 'end-time) (lambda (time) (strftime "%F %T" time))) 'null)) (tags . ,(vector-map (lambda (_ tag) (match tag ((key . value) `((key . ,key) (value . ,value))))) tags)) (derivation-inputs . ,(list->vector derivation-inputs)) (setup-failures . ,(list->vector setup-failures)))))))) (('POST "build" uuid "cancel") (cancel-build build-coordinator uuid) (render-json `((result . "build-canceled")))) (('GET "builds" "blocking") (let ((query-parameters (request-query-parameters request))) (render-json `((builds . ,(list->vector (datastore-list-failed-builds-with-blocking-count datastore (assq-ref query-parameters 'system) #:include-cancelled? (assq-ref query-parameters 'include_cancelled?)))))))) (('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 (map (lambda (agent) `(,@agent (allocated_builds . ,(list->vector (datastore-select-allocated-builds datastore (assq-ref agent 'uuid)))) (tags . ,(vector-map (match-lambda* ((index (key . value)) `((key . ,key) (value . ,value)))) (datastore-fetch-agent-tags datastore (assq-ref agent 'uuid)))) (requested_systems . ,(list->vector (datastore-agent-requested-systems datastore (assq-ref agent 'uuid)))))) (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 "dynamic-auth-tokens") (let ((token (random-token))) (datastore-insert-dynamic-auth-token datastore token) (render-json `((token . ,token))))) (('GET "agent" agent-id) (let ((agent-details (datastore-find-agent datastore agent-id))) (render-json `((id . ,agent-id) ,@agent-details (tags . ,(vector-map (lambda (_ tag) (match tag ((key . value) `((key . ,key) (value . ,value))))) (datastore-fetch-agent-tags datastore agent-id))) (allocated_builds . ,(list->vector (datastore-list-agent-builds datastore agent-id))) (build_allocation_plan . ,(list->vector (datastore-list-allocation-plan-builds datastore agent-id 2048))))))) ; TODO Do something with this (('POST "agent" agent-id "passwords") (let ((password (new-agent-password datastore #:agent agent-id))) (render-json `((new-password . ,password))))) (('POST "agent" agent-id "tags") (let ((agent-details (datastore-find-agent datastore agent-id))) (if agent-details (begin (datastore-replace-agent-tags datastore agent-id (vector-map (lambda (_ tag) `((key . ,(assoc-ref tag "key")) (value . ,(assoc-ref tag "value")))) (assoc-ref body "tags"))) (render-json `((result . success)))) (render-json `((error . 404)) #:code 404)))) (('GET "builds") (let ((query-parameters (request-query-parameters request))) (render-json `((builds . ,(list->vector (map (lambda (build-details) `(,@(alist-delete 'created-at (alist-delete 'end-time build-details)) (created-at . ,(or (and=> (assq-ref build-details 'created-at) (lambda (time) (strftime "%F %T" time))) 'null)) (end-time . ,(or (and=> (assq-ref build-details 'end-time) (lambda (time) (strftime "%F %T" time))) 'null)) (tags . ,(vector-map (lambda (_ tag) (match tag ((key . value) `((key . ,key) (value . ,value))))) (datastore-fetch-build-tags datastore (assq-ref build-details 'uuid)))))) (datastore-list-builds datastore #:tags (filter-map (match-lambda ((key . value) (if (eq? key 'tag) (match (string-split value #\:) ((tag-key tag-value) (cons tag-key tag-value)) ((tag-key) tag-key)) #f))) query-parameters) #:not-tags (filter-map (match-lambda ((key . value) (if (eq? key 'not_tag) (match (string-split value #\:) ((tag-key tag-value) (cons tag-key tag-value)) ((tag_key) tag_key)) #f))) query-parameters) #:systems (filter-map (match-lambda ((key . value) (if (eq? key 'system) value #f))) query-parameters) #:not-systems (filter-map (match-lambda ((key . value) (if (eq? key 'not-system) value #f))) query-parameters) #:processed (match (assq 'processed query-parameters) ((_ . val) (string=? val "true")) (#f 'unset)) #:canceled (match (assq 'canceled query-parameters) ((_ . val) (string=? val "true")) (#f 'unset)) #:after-id (assq-ref query-parameters 'after_id) #:limit (or (and=> (assq-ref query-parameters 'limit) (lambda (val) (string->number val))) 1000))))))))) (('POST "builds") (let ((derivation-file (assoc-ref body "derivation"))) (unless (string? derivation-file) (raise-exception (make-exception-with-message (simple-format #f "derivation must be a string: ~A\n" 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)))))))) (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")))) '()) ,@(or (and=> (assoc-ref body "defer-until") (lambda (date) `(#:defer-until ,(string->date date "~Y-~m-~d ~H:~M:~S")))) '()))))) (render-json submit-build-result)))) (_ (render-json "not-found" #:code 404)))) (with-exception-handler (lambda (exn) (render-json `((error . 500)) #:code 500)) (lambda () (with-throw-handler #t controller-thunk (lambda (key . args) (match method-and-path-components ((method path-components ...) (simple-format (current-error-port) "error: when processing client request: /~A ~A\n ~A ~A\n" method (string-join path-components "/") key args))) (backtrace)))) #: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))))) (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 #:key defer-until) (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 tags)))) ,@(if defer-until `((defer-until . ,(date->string defer-until "~1 ~3"))) '())))) (define (send-cancel-build-request coordinator-uri build-id) (send-request coordinator-uri 'POST (string-append "/build/" build-id "/cancel"))) (define (request-build-details coordinator-uri uuid) (send-request coordinator-uri 'GET (string-append "/build/" uuid))) (define* (request-builds-list coordinator-uri #:key (tags '()) (not-tags '()) (systems '()) (not-systems '()) (processed 'unset) (canceled 'unset) (after-id #f) (limit 1000)) (let ((query-parameters `(,@(if (null? tags) '() (map (match-lambda ((('key . key) ('value . value)) (simple-format #f "tag=~A:~A" key value)) (key (simple-format #f "tag=~A" key))) tags)) ,@(if (null? not-tags) '() (map (match-lambda ((('key . key) ('value . value)) (simple-format #f "not_tag=~A:~A" key value)) (key (simple-format #f "not_tag=~A" key))) not-tags)) ,@(if (null? systems) '() (map (lambda (system) (simple-format #f "system=~A" system)) systems)) ,@(if (null? not-systems) '() (map (lambda (system) (simple-format #f "not-system=~A" system)) not-systems)) ,@(if (boolean? processed) (if processed '("processed=true") '("processed=false")) '()) ,@(if (boolean? canceled) (if canceled '("canceled=true") '("canceled=false")) '()) ,@(if after-id (list (string-append "after_id=" after-id)) '()) ,@(if limit (list (simple-format #f "limit=~A" limit)) '())))) (send-request coordinator-uri 'GET (string-append "/builds" (if (null? query-parameters) "" (string-append "?" (string-join query-parameters "&"))))))) (define (request-output-details coordinator-uri output) (send-request coordinator-uri 'GET (string-append "/output" output))) (define (request-agent-details coordinator-uri agent-id) (send-request coordinator-uri 'GET (string-append "/agent/" agent-id))) (define (request-agents-list coordinator-uri) (send-request coordinator-uri 'GET (string-append "/agents"))) (define* (request-failed-builds-with-blocking-count-list coordinator-uri system #:key include-cancelled?) (send-request coordinator-uri 'GET (string-append "/builds/blocking" (if system (simple-format #f "?system=~A" system) "") (if include-cancelled? (string-append (if system "&" "?") "include_cancelled=" (if include-cancelled? "true" "false")) "")))) (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"))) (define (send-create-dynamic-auth-token-request coordinator-uri) (send-request coordinator-uri 'POST "/dynamic-auth-tokens")) (define (send-replace-agent-tags-request coordinator-uri agent-id tags) (send-request coordinator-uri 'POST (string-append "/agent/" agent-id "/tags") `((tags . ,tags))))