aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2022-01-09 21:55:43 +0100
committerLudovic Courtès <ludo@gnu.org>2022-01-09 23:17:17 +0100
commit7f20e59a13a6acc3331e04185b8f1ed2538dcd0a (patch)
treedd7b670044397d56445e5d880a9eae7be8ebb979
parent1684ed6537fbd91ae5c14fb0314564e71799d390 (diff)
downloadguix-7f20e59a13a6acc3331e04185b8f1ed2538dcd0a.tar
guix-7f20e59a13a6acc3331e04185b8f1ed2538dcd0a.tar.gz
machine: ssh: Open a single SSH session per machine.
Previously, any call to 'managed-host-remote-eval' and similar would open a new SSH session to the host. With this change, an SSH session is opened once, cached, and then reused by all subsequent calls to 'machine-ssh-session'. * gnu/machine/ssh.scm (<machine-ssh-configuration>): Add 'this-machine-ssh-configuration'. [session]: Mark as thunked and change default value to an 'open-machine-ssh-session*' call. (open-machine-ssh-session, open-machine-ssh-session*): New procedures. (machine-ssh-session): Replace inline code by call to 'open-machine-ssh-session'.
-rw-r--r--gnu/machine/ssh.scm44
1 files changed, 29 insertions, 15 deletions
diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm
index ecd02e336c..22688f46f4 100644
--- a/gnu/machine/ssh.scm
+++ b/gnu/machine/ssh.scm
@@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.org>
-;;; Copyright © 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2020-2022 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -26,6 +26,7 @@
#:use-module (gnu system uuid)
#:use-module ((gnu services) #:select (sexp->system-provenance))
#:use-module (guix diagnostics)
+ #:use-module (guix memoization)
#:use-module (guix gexp)
#:use-module (guix i18n)
#:use-module (guix modules)
@@ -83,6 +84,7 @@
(define-record-type* <machine-ssh-configuration> machine-ssh-configuration
make-machine-ssh-configuration
machine-ssh-configuration?
+ this-machine-ssh-configuration
(host-name machine-ssh-configuration-host-name) ; string
(system machine-ssh-configuration-system) ; string
(build-locally? machine-ssh-configuration-build-locally? ; boolean
@@ -98,29 +100,41 @@
(identity machine-ssh-configuration-identity ; path to a private key
(default #f))
(session machine-ssh-configuration-session ; session
- (default #f))
+ (thunked)
+ (default
+ ;; By default, open the session once and cache it.
+ (open-machine-ssh-session* this-machine-ssh-configuration)))
(host-key machine-ssh-configuration-host-key ; #f | string
(default #f)))
+(define (open-machine-ssh-session config)
+ "Open an SSH session for CONFIG, a <machine-ssh-configuration> record."
+ (let ((host-name (machine-ssh-configuration-host-name config))
+ (user (machine-ssh-configuration-user config))
+ (port (machine-ssh-configuration-port config))
+ (identity (machine-ssh-configuration-identity config))
+ (host-key (machine-ssh-configuration-host-key config)))
+ (unless host-key
+ (warning (G_ "<machine-ssh-configuration> without a 'host-key' \
+is deprecated~%")))
+ (open-ssh-session host-name
+ #:user user
+ #:port port
+ #:identity identity
+ #:host-key host-key)))
+
+(define open-machine-ssh-session*
+ (mlambdaq (config)
+ "Memoizing variant of 'open-machine-ssh-session'."
+ (open-machine-ssh-session config)))
+
(define (machine-ssh-session machine)
"Return the SSH session that was given in MACHINE's configuration, or create
one from the configuration's parameters if one was not provided."
(maybe-raise-unsupported-configuration-error machine)
(let ((config (machine-configuration machine)))
(or (machine-ssh-configuration-session config)
- (let ((host-name (machine-ssh-configuration-host-name config))
- (user (machine-ssh-configuration-user config))
- (port (machine-ssh-configuration-port config))
- (identity (machine-ssh-configuration-identity config))
- (host-key (machine-ssh-configuration-host-key config)))
- (unless host-key
- (warning (G_ "<machine-ssh-configuration> without a 'host-key' \
-is deprecated~%")))
- (open-ssh-session host-name
- #:user user
- #:port port
- #:identity identity
- #:host-key host-key)))))
+ (open-machine-ssh-session config))))
;;;