04/07: ssh: Add 'authenticate-server*' and use it for offloading.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 114dcb429a812911633a9fe5a9ee7d70dd28b353
Author: Ludovic Courtès <address@hidden>
Date:   Tue Dec 3 21:28:23 2019 +0100

    ssh: Add 'authenticate-server*' and use it for offloading.
    
    * guix/scripts/offload.scm (host-key->type+key): Remove.
    (open-ssh-session): Replace server authentication code with a call to
    'authenticate-server*'.
    * guix/ssh.scm (host-key->type+key, authenticate-server*): New
    procedures.
---
 guix/scripts/offload.scm | 30 ++----------------------------
 guix/ssh.scm             | 37 +++++++++++++++++++++++++++++++++++++
 2 files changed, 39 insertions(+), 28 deletions(-)

diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm
index 1847368..e81b6c2 100644
--- a/guix/scripts/offload.scm
+++ b/guix/scripts/offload.scm
@@ -149,19 +149,6 @@ ignoring it~%")
          (leave (G_ "failed to load machine file '~a': ~s~%")
                 file args))))))
 
-(define (host-key->type+key host-key)
-  "Destructure HOST-KEY, an OpenSSH host key string, and return two values:
-its key type as a symbol, and the actual base64-encoded string."
-  (define (type->symbol type)
-    (and (string-prefix? "ssh-" type)
-         (string->symbol (string-drop type 4))))
-
-  (match (string-tokenize host-key)
-    ((type key x)
-     (values (type->symbol type) key))
-    ((type key)
-     (values (type->symbol type) key))))
-
 (define (private-key-from-file* file)
   "Like 'private-key-from-file', but raise an error that 'with-error-handling'
 can interpret meaningfully."
@@ -203,21 +190,8 @@ private key from '~a': ~a")
                                (build-machine-compression-level machine))))
     (match (connect! session)
       ('ok
-       ;; Authenticate the server.  XXX: Guile-SSH 0.10.1 doesn't know about
-       ;; ed25519 keys and 'get-key-type' returns #f in that case.
-       (let-values (((server)   (get-server-public-key session))
-                    ((type key) (host-key->type+key
-                                 (build-machine-host-key machine))))
-         (unless (and (or (not (get-key-type server))
-                          (eq? (get-key-type server) type))
-                      (string=? (public-key->string server) key))
-           ;; Key mismatch: something's wrong.  XXX: It could be that the 
server
-           ;; provided its Ed25519 key when we where expecting its RSA key.
-           (leave (G_ "server at '~a' returned host key '~a' of type '~a' \
-instead of '~a' of type '~a'~%")
-                  (build-machine-name machine)
-                  (public-key->string server) (get-key-type server)
-                  key type)))
+       ;; Make sure the server's key is what we expect.
+       (authenticate-server* session (build-machine-host-key machine))
 
        (let ((auth (userauth-public-key! session private)))
          (unless (eq? 'success auth)
diff --git a/guix/ssh.scm b/guix/ssh.scm
index 5fd3c28..f34e713 100644
--- a/guix/ssh.scm
+++ b/guix/ssh.scm
@@ -37,6 +37,8 @@
   #:use-module (ice-9 format)
   #:use-module (ice-9 binary-ports)
   #:export (open-ssh-session
+            authenticate-server*
+
             remote-inferior
             remote-daemon-channel
             connect-to-remote-daemon
@@ -60,6 +62,41 @@
 (define %compression
   "address@hidden,zlib")
 
+(define (host-key->type+key host-key)
+  "Destructure HOST-KEY, an OpenSSH host key string, and return two values:
+its key type as a symbol, and the actual base64-encoded string."
+  (define (type->symbol type)
+    (and (string-prefix? "ssh-" type)
+         (string->symbol (string-drop type 4))))
+
+  (match (string-tokenize host-key)
+    ((type key x)
+     (values (type->symbol type) key))
+    ((type key)
+     (values (type->symbol type) key))))
+
+(define (authenticate-server* session key)
+  "Make sure the server for SESSION has the given KEY, where KEY is a string
+such as \"ssh-ed25519 AAAAC3Nz… address@hidden\".  Raise an exception if the
+actual key does not match."
+  (let-values (((server)   (get-server-public-key session))
+               ((type key) (host-key->type+key key)))
+    (unless (and (or (not (get-key-type server))
+                     (eq? (get-key-type server) type))
+                 (string=? (public-key->string server) key))
+      ;; Key mismatch: something's wrong.  XXX: It could be that the server
+      ;; provided its Ed25519 key when we where expecting its RSA key.  XXX:
+      ;; Guile-SSH 0.10.1 doesn't know about ed25519 keys and 'get-key-type'
+      ;; returns #f in that case.
+      (raise (condition
+              (&message
+               (message (format #f (G_ "server at '~a' returned host key \
+'~a' of type '~a' instead of '~a' of type '~a'~%")
+                                (session-get session 'host)
+                                (public-key->string server)
+                                (get-key-type server)
+                                key type))))))))
+
 (define* (open-ssh-session host #:key user port identity
                            (compression %compression)
                            (timeout 3600))