[bug#38478] [PATCH 3/4] ssh: 'open-ssh-session' can be passed the expected host key.

["Ludovic Courtès" <ludo@gnu.org>]

* guix/ssh.scm (open-ssh-session): Add #:host-key parameter.
Pass #:knownhosts to 'make-session'.  When HOST-KEY is true, call
'authenticate-server*' instead of 'authenticate-server'.
---
 guix/ssh.scm | 39 +++++++++++++++++++++++++++------------
 1 file changed, 27 insertions(+), 12 deletions(-)

diff --git a/guix/ssh.scm b/guix/ssh.scm
index 519c723155..291ce20b61 100644
--- a/guix/ssh.scm
+++ b/guix/ssh.scm
@@ -98,14 +98,20 @@ actual key does not match."
                                 key type))))))))
 
 (define* (open-ssh-session host #:key user port identity
+                           host-key
                            (compression %compression)
                            (timeout 3600))
   "Open an SSH session for HOST and return it.  IDENTITY specifies the file
 name of a private key to use for authenticating with the host.  When USER,
 PORT, or IDENTITY are #f, use default values or whatever '~/.ssh/config'
-specifies; otherwise use them.  Install TIMEOUT as the maximum time in seconds
-after which a read or write operation on a channel of the returned session is
-considered as failing.
+specifies; otherwise use them.
+
+When HOST-KEY is true, it must be a string like \"ssh-ed25519 AAAAC3Nz…
+root@example.org\"; the server is authenticated and an error is raised if its
+host key is different from HOST-KEY.
+
+Install TIMEOUT as the maximum time in seconds after which a read or write
+operation on a channel of the returned session is considered as failing.
 
 Throw an error on failure."
   (let ((session (make-session #:user user
@@ -115,6 +121,11 @@ Throw an error on failure."
                                #:timeout 10       ;seconds
                                ;; #:log-verbosity 'protocol
 
+                               ;; Prevent libssh from reading
+                               ;; ~/.ssh/known_hosts when the caller provides
+                               ;; a HOST-KEY to match against.
+                               #:knownhosts (and host-key "/dev/null")
+
                                ;; We need lightweight compression when
                                ;; exchanging full archives.
                                #:compression compression
@@ -125,16 +136,20 @@ Throw an error on failure."
 
     (match (connect! session)
       ('ok
-       ;; Authenticate against ~/.ssh/known_hosts.
-       (match (authenticate-server session)
-         ('ok #f)
-         (reason
-          (raise (condition
-                  (&message
-                   (message (format #f (G_ "failed to authenticate \
+       (if host-key
+           ;; Make sure the server's key is what we expect.
+           (authenticate-server* session host-key)
+
+           ;; Authenticate against ~/.ssh/known_hosts.
+           (match (authenticate-server session)
+             ('ok #f)
+             (reason
+              (raise (condition
+                      (&message
+                       (message (format #f (G_ "failed to authenticate \
 server at '~a': ~a")
-                                    (session-get session 'host)
-                                    reason)))))))
+                                        (session-get session 'host)
+                                        reason))))))))
 
        ;; Use public key authentication, via the SSH agent if it's available.
        (match (userauth-public-key/auto! session)
-- 
2.24.0