01/01: hydra: Add script to remotely configure berlin build nodes.

[Ricardo Wurmus]

rekado pushed a commit to branch master
in repository maintenance.

commit 2c4acf60667267a10054f2c5861301d4d1676ad9
Author: Ricardo Wurmus <address@hidden>
Date:   Tue Jan 1 10:33:32 2019 +0100

    hydra: Add script to remotely configure berlin build nodes.
    
    * hydra/install-berlin.scm: New file.
---
 hydra/install-berlin.scm | 181 +++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 181 insertions(+)

diff --git a/hydra/install-berlin.scm b/hydra/install-berlin.scm
new file mode 100644
index 0000000..8e3a9f6
--- /dev/null
+++ b/hydra/install-berlin.scm
@@ -0,0 +1,181 @@
+;; Run this script as:
+;; GUILE_LOAD_COMPILED_PATH= guile --no-auto-compile install-berlin.scm 1 2 3
+
+(define %hydra-modules "/root/maintenance/hydra/modules")
+(set! %load-path
+      (cons* "/root/.config/guix/current/share/guile/site/2.2"
+             %hydra-modules %load-path))
+;; Without this the info-dir.drv will be miscompiled!
+(set! %load-compiled-path
+      (cons* "/root/.config/guix/current/lib/guile/2.2/site-ccache"
+             %load-compiled-path))
+
+(use-modules (sysadmin build-machines)
+             (sysadmin people)
+             (ssh auth)
+             (ssh session)
+             (ssh popen)                ; remote pipes
+             (ssh channel)              ; channel-set-pty-size!
+             (guix derivations)
+             (guix inferior)
+             (guix ssh)
+             (guix gexp)
+             (guix grafts)
+             (guix store)
+             (guix packages)
+             (gnu system)
+             ((gnu packages package-management) #:select (guix))
+             (srfi srfi-1)
+             (srfi srfi-11)             ; let-values
+             (srfi srfi-41)             ; streams
+             (ice-9 match))
+
+
+(define (open-remote-input-pipe/pty session command . args)
+  "Open remote input pipe with PTY, run a COMMAND with ARGS."
+  (define OPEN_PTY_READ (string-append OPEN_PTY OPEN_BOTH))
+  (let ((p (open-remote-pipe session command OPEN_PTY_READ)))
+    (channel-set-pty-size! p 80 40)
+    p))
+
+(define (pipe->stream p)
+  "Convert a pipe P to a SRFI-41 stream."
+  (stream-let loop ((c (read-char p)))
+              (if (eof-object? c)
+                  (begin
+                    (close-input-port p)
+                    stream-null)
+                  (stream-cons c (loop (read-char p))))))
+
+(define (remote-inferior* session guix-directory)
+  "Return a remote inferior for the given SESSION."
+  (let ((pipe (open-remote-pipe* session OPEN_BOTH
+                                 (string-append guix-directory "/bin/guix")
+                                 "repl" "-t" "machine")))
+    (port->inferior pipe)))
+
+(define (inferior-remote-eval* exp session guix-directory)
+  "Evaluate EXP in a new inferior running in SESSION, and close the inferior
+right away."
+  (let ((inferior (remote-inferior* session guix-directory)))
+    (dynamic-wind
+      (const #t)
+      (lambda ()
+        (inferior-eval exp inferior))
+      (lambda ()
+        ;; Close INFERIOR right away to prevent finalization from happening in
+        ;; another thread at the wrong time (see
+        ;; <https://bugs.gnu.org/26976>.)
+        (close-inferior inferior)))))
+
+(define (host-for-id id)
+  "Return a host IP address for the given ID."
+  (format #f "141.80.167.~d" (+ id 131)))
+
+
+(define (build-os id)
+  "Build Guix and then use it to build the operating system
+configuration for the target host with the given ID.  Return the
+derivations and store file names as the first value and the directory
+of Guix as the second value."
+  (let ((host (host-for-id id)))
+    (format #t "building operating system for ~a...~%" host)
+    (with-store local
+      (let* ((guixdrv (run-with-store local (package->derivation guix)))
+             (guixdir (and (build-derivations local (list guixdrv))
+                           (derivation->output-path guixdrv)))
+             (inferior-local (open-inferior guixdir))
+             (osdrv (and=> (inferior-eval-with-store
+                            inferior-local local
+                            `(lambda (store)
+                               (add-to-load-path ,%hydra-modules)
+                               (use-modules (sysadmin build-machines) (guix 
grafts))
+                               (parameterize ((%graft? #f))
+                                 (let* ((host ,host)
+                                        (os (berlin-build-machine-os ,id))
+                                        (osdrv (run-with-store store 
(operating-system-derivation os))))
+                                   (and (build-derivations store (list osdrv))
+                                        (derivation-file-name osdrv))))))
+                           read-derivation-from-file)))
+        (close-inferior inferior-local)
+        (values
+         (append (map derivation->output-path (list osdrv guixdrv))
+                 (map derivation-file-name (list osdrv guixdrv)))
+         guixdir)))))
+
+(define (push-os drvs id)
+  "Copy the derivations DRVS to the target with ID."
+  (let* ((host (host-for-id id))
+         (session (open-ssh-session host #:user "hydra" #:port 22)))
+    (format #t "pushing store items to ~a...~%" host)
+    (with-store local (send-files local drvs
+                                  (connect-to-remote-daemon session)
+                                  #:recursive? #t))
+    #t))
+
+;; XXX: This seems to work, but it's dreadfully silent.
+(define (reconfigure-remote id guix-directory)
+  "Reconfigure the remote system with the given ID using Guix from
+GUIX-DIRECTORY."
+  (let* ((host    (host-for-id id))
+         (session (open-ssh-session host #:user "root" #:port 22)))
+    (and=> (or (connected? session)
+               (match (connect! session)
+                 ('error (pk (get-error session) #f))
+                 (_ (userauth-agent! session))))
+           (lambda _
+             (format #t "reconfiguring ~a...~%" host)
+             (inferior-remote-eval*
+              `(begin
+                 (add-to-load-path ,%hydra-modules)
+                 (use-modules (sysadmin build-machines)
+                              (guix grafts)
+                              (guix scripts system))
+                 ;; XXX: The reconfigure output confuses the inferior 
mechanism :(
+                 (parameterize ((current-error-port (%make-void-port "rw+"))
+                                (current-output-port (%make-void-port "rw+"))
+                                (%graft? #f))
+                   (guix-system "reconfigure" "--no-grafts"
+                                "-e"
+                                (format #f "~s" `(begin
+                                                   (add-to-load-path 
,,%hydra-modules)
+                                                   (use-modules (sysadmin 
build-machines))
+                                                   (berlin-build-machine-os 
,,id)))))
+                 #t)
+              session guix-directory)
+             (format #t "DONE!~%")
+             #t))))
+
+(define (reconfigure-remote* id guix-directory)
+  "Reconfigure the remote system with the given ID using Guix from
+GUIX-DIRECTORY."
+  (let* ((host    (host-for-id id))
+         (session (open-ssh-session host #:user "root" #:port 22)))
+    (and=> (or (connected? session)
+               (match (connect! session)
+                 ('error (pk (get-error session) #f))
+                 (_ (userauth-agent! session))))
+           (lambda _
+             (let* ((command (string-append
+                              guix-directory "/bin/guix system reconfigure "
+                              "--no-grafts "
+                              "-e "
+                              (format #f "'~s'"
+                                      `(begin
+                                         (add-to-load-path ,%hydra-modules)
+                                         (use-modules (sysadmin 
build-machines))
+                                         (berlin-build-machine-os ,id)))))
+                    (rs (pipe->stream (open-remote-input-pipe/pty session 
command))))
+               (stream-for-each (lambda (c)
+                                  (match c
+                                    (#\newline (format #t "\n~a: " host))
+                                    (c (display c))))
+                                rs))))))
+
+
+(for-each (lambda (id)
+            (parameterize ((%graft? #f))
+              (let-values (((drvs guix-directory) (build-os id)))
+                (push-os drvs id)
+                (reconfigure-remote* id guix-directory))))
+          (map string->number (cdr (command-line))))