;;; remote.scm -- Build on remote machines.
;;; Copyright © 2020 Mathieu Othacehe <othacehe@gnu.org>
;;;
;;; 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 <http://www.gnu.org/licenses/>.

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

\f
;;;
;;; Workers.
;;;

(define-record-type* <worker>
  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 <worker> 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)))

\f
;;;
;;; 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)))

\f
;;;
;;; 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)))

\f
;;;
;;; 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)))))))