;;; remote.scm -- Build on remote machines. ;;; Copyright © 2020 Mathieu Othacehe ;;; ;;; This file is part of Cuirass. ;;; ;;; GNU Guix 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. ;;; ;;; GNU Guix 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 GNU Guix. If not, see . (define-module (cuirass remote) #:use-module (guix config) #:use-module (guix derivations) #:use-module (guix records) #:use-module (guix store) #:use-module (guix ui) #:use-module (guix build download) #:use-module ((guix build utils) #:select (mkdir-p)) #:use-module (guix scripts publish) #:use-module (simple-zmq) #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (ice-9 match) #:use-module (ice-9 rdelim) #:export (worker worker? worker-name worker-systems worker->sexp sexp->worker generate-worker-name publish-server add-substitute-url zmq-frontend-socket-name zmq-frontend-endpoint zmq-poll* zmq-socket-ready? zmq-empty-delimiter zmq-build-request-message zmq-no-build-message zmq-build-started-message zmq-build-failed-message zmq-build-succeeded-message zmq-worker-ready-message zmq-worker-request-work-message zmq-read-message remote-server-service-type remote-build-socket remote-build remote-build-poll)) ;;; ;;; Workers. ;;; (define-record-type* worker make-worker worker? (name worker-name) (systems worker-systems)) (define (worker->sexp worker) "Return an sexp describing WORKER." (let ((name (worker-name worker)) (systems (worker-systems worker))) `(worker (name ,name) (systems ,systems)))) (define (sexp->worker sexp) "Turn SEXP, an sexp as returned by 'worker->sexp', into a record." (match sexp (('worker ('name name) ('systems systems)) (worker (name name) (systems systems))))) (define %seed (seed->random-state (logxor (getpid) (car (gettimeofday))))) (define (integer->alphanumeric-char n) "Map N, an integer in the [0..62] range, to an alphanumeric character." (cond ((< n 10) (integer->char (+ (char->integer #\0) n))) ((< n 36) (integer->char (+ (char->integer #\A) (- n 10)))) ((< n 62) (integer->char (+ (char->integer #\a) (- n 36)))) (else (error "integer out of bounds" n)))) (define (random-string len) "Compute a random string of size LEN where each character is alphanumeric." (let loop ((chars '()) (len len)) (if (zero? len) (list->string chars) (let ((n (random 62 %seed))) (loop (cons (integer->alphanumeric-char n) chars) (- len 1)))))) (define (generate-worker-name) "Return the service name of the server." (string-append (gethostname) "-" (random-string 4))) ;;; ;;; Store publishing. ;;; (define (add-substitute-url store url) "Add URL to the list of STORE substitutes-urls." (set-build-options store #:use-substitutes? #t #:fallback? #f #:keep-going? #t #:print-build-trace #t #:build-verbosity 1 #:substitute-urls (cons url %default-substitute-urls))) (define* (publish-server port #:key public-key private-key) "This procedure starts a publishing server listening on PORT in a new process and returns the pid of the forked process. Use PUBLIC-KEY and PRIVATE-KEY to sign narinfos." (match (primitive-fork) (0 (parameterize ((%public-key public-key) (%private-key private-key)) (with-store store (let* ((address (make-socket-address AF_INET INADDR_ANY 0)) (socket-address (make-socket-address (sockaddr:fam address) (sockaddr:addr address) port)) (socket (open-server-socket socket-address))) (run-publish-server socket store #:compressions (list %default-gzip-compression)))))) (pid pid))) ;;; ;;; ZMQ. ;;; (define %zmq-context (zmq-create-context)) (define (zmq-frontend-socket-name) "Return the name of the ZMQ frontend socket." (string-append %state-directory "/remote-build-socket")) (define (zmq-frontend-endpoint) "Return a ZMQ endpoint allowing client connections using the IPC transport." (string-append "ipc://" (zmq-frontend-socket-name))) (define (EINTR-safe proc) "Return a variant of PROC that catches EINTR 'zmq-error' exceptions and retries a call to PROC." (define (safe . args) (catch 'zmq-error (lambda () (apply proc args)) (lambda (key errno . rest) (if (= errno EINTR) (apply safe args) (apply throw key errno rest))))) safe) (define zmq-poll* ;; Return a variant of ZMQ-POLL that catches EINTR errors. (EINTR-safe zmq-poll)) (define (zmq-socket-ready? items socket) "Return #t if the given SOCKET is part of ITEMS, a list returned by a 'zmq-poll' call, return #f otherwise." (find (lambda (item) (eq? (poll-item-socket item) socket)) items)) (define (zmq-read-message msg) (call-with-input-string msg read)) (define (zmq-empty-delimiter) "Return an empty ZMQ delimiter used to format message envelopes." (make-bytevector 0)) ;; ZMQ Messages. (define* (zmq-build-request-message drv #:optional system) "Return a message requesting the build of DRV for SYSTEM." (format #f "~s" `(build (drv ,drv) (system ,system)))) (define (zmq-no-build-message) "Return a message that indicates that no builds are available." (format #f "~s" `(no-build))) (define (zmq-build-started-message drv) "Return a message that indicates that the build of DRV has started." (format #f "~s" `(build-started (drv ,drv)))) (define (zmq-build-failed-message drv) "Return a message that indicates that the build of DRV has failed." (format #f "~s" `(build-failed (drv ,drv)))) (define (zmq-build-succeeded-message drv url) "Return a message that indicates that the build of DRV is done." (format #f "~s" `(build-succeeded (drv ,drv) (url ,url)))) (define (zmq-worker-ready-message worker) "Return a message that indicates that WORKER is ready." (format #f "~s" `(worker-ready ,worker))) (define (zmq-worker-request-work-message name) "Return a message that indicates that WORKER is requesting work." (format #f "~s" `(worker-request-work ,name))) ;;; ;;; Remote builds. ;;; (define remote-server-service-type "_remote-server._tcp") (define (remote-build-socket) "Return a socket used to communicate with the remote build server." (let ((socket (zmq-create-socket %zmq-context ZMQ_DEALER)) (endpoint (zmq-frontend-endpoint))) (zmq-connect socket endpoint) socket)) (define* (remote-build socket drvs systems) "Builds DRVS using the remote build mechanism. A build command is sent on SOCKET to the build server for each derivation. SYSTEMS is a list describing the systems of each derivations in the DRVS list. It is used for performance reasons, so that the remote server doesn't need to call 'read-derivation-from-file' for each derivation, which can be an expensive operation." (for-each (lambda (drv system) ;; We need to prefix the command with an empty delimiter ;; because the DEALER socket is connected to a ROUTER ;; socket. See "zmq-start-proxy" procedure. (zmq-send-msg-parts-bytevector socket (list (make-bytevector 0) (string->bv (zmq-build-request-message drv system))))) drvs systems)) (define* (remote-build-poll socket event-proc #:key (timeout 1000)) "Poll SOCKET for messages and call EVENT-PROC each time a build event is received, return if no event occured for TIMEOUT milliseconds." (define (parse-result result) (match (zmq-read-message result) (('build-started ('drv drv)) (event-proc (list 'build-started drv))) (('build-succeeded ('drv drv) ('url url)) (event-proc (list 'build-succeeded drv))) (('build-failed ('drv drv)) (event-proc (list 'build-failed drv))))) (let* ((poll-items (list (poll-item socket ZMQ_POLLIN))) (items (zmq-poll* poll-items timeout))) (when (zmq-socket-ready? items socket) (match (zmq-get-msg-parts-bytevector socket '()) ((empty result) (parse-result (bv->string result)))))))