[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
01/01: hydra: Add script to remotely configure berlin build nodes.
From: |
Ricardo Wurmus |
Subject: |
01/01: hydra: Add script to remotely configure berlin build nodes. |
Date: |
Tue, 1 Jan 2019 04:34:16 -0500 (EST) |
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))))