From: "Ludovic Courtès" <ludo@gnu.org>
To: 38478@debbugs.gnu.org
Cc: "Ludovic Courtès" <ludo@gnu.org>
Subject: [bug#38478] [PATCH 1/4] ssh: Add 'authenticate-server*' and use it for offloading.
Date: Tue, 3 Dec 2019 22:15:54 +0100 [thread overview]
Message-ID: <20191203211557.21145-1-ludo@gnu.org> (raw)
In-Reply-To: <20191203210958.20936-1-ludo@gnu.org>
* 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 18473684eb..e81b6c25f2 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 5fd3c280e8..f34e71392b 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
"zlib@openssh.com,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… root@example.org\". 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))
--
2.24.0
next prev parent reply other threads:[~2019-12-03 21:17 UTC|newest]
Thread overview: 10+ messages / expand[flat|nested] mbox.gz Atom feed top
2019-12-03 21:09 [bug#38478] [PATCH 0/4] "guix deploy" authenticates SSH servers [security] Ludovic Courtès
2019-12-03 21:15 ` Ludovic Courtès [this message]
2019-12-03 21:15 ` [bug#38478] [PATCH 2/4] ssh: Always authenticate the server [security fix] Ludovic Courtès
2019-12-03 21:15 ` [bug#38478] [PATCH 3/4] ssh: 'open-ssh-session' can be passed the expected host key Ludovic Courtès
2019-12-03 21:15 ` [bug#38478] [PATCH 4/4] machine: ssh: <machine-ssh-configuration> can include the " Ludovic Courtès
2019-12-04 13:19 ` Jakob L. Kreuze
2019-12-04 17:33 ` Ludovic Courtès
2019-12-06 0:50 ` Jakob L. Kreuze
2019-12-06 12:16 ` Ludovic Courtès
2019-12-07 0:04 ` Ludovic Courtès
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://guix.gnu.org/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20191203211557.21145-1-ludo@gnu.org \
--to=ludo@gnu.org \
--cc=38478@debbugs.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/guix.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).