rekado pushed a commit to branch master in repository maintenance. commit 2c4acf60667267a10054f2c5861301d4d1676ad9 Author: Ricardo Wurmus <rek...@elephly.net> 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))))