add SSH:{GLOBALLY-,}KNOWN-HOST and SSHD:HAS-{HOST-,}PUBLIC-KEY

Signed-off-by: Sean Whitton <spwhitton@spwhitton.name>

3 files changed, 86 insertions, 6 deletions

diff --git a/src/package.lisp b/src/package.lisp
index 3da19e5..f9a5afa 100644
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -485,11 +485,6 @@
   (:local-nicknames (#:file      #:consfigurator.property.file))
   (:export #:snapshot-extracted))
 
-(defpackage :consfigurator.property.ssh
-  (:use #:cl #:consfigurator)
-  (:local-nicknames (#:file      #:consfigurator.property.file))
-  (:export #:authorized-keys))
-
 (defpackage :consfigurator.property.sshd
   (:use #:cl #:consfigurator)
   (:local-nicknames (#:re        #:cl-ppcre)
@@ -498,7 +493,18 @@
                     (#:apt       #:consfigurator.property.apt))
   (:export #:installed
            #:configured
-           #:no-passwords))
+           #:no-passwords
+           #:get-host-public-keys
+           #:has-host-public-key
+           #:has-host-key))
+
+(defpackage :consfigurator.property.ssh
+  (:use #:cl #:alexandria #:consfigurator)
+  (:local-nicknames (#:file      #:consfigurator.property.file)
+                    (#:sshd      #:consfigurator.property.sshd))
+  (:export #:authorized-keys
+           #:known-host
+           #:globally-known-host))
 
 (defpackage :consfigurator.property.locale
   (:use #:cl #:consfigurator)
diff --git a/src/property/ssh.lisp b/src/property/ssh.lisp
index 15169cd..76935d0 100644
--- a/src/property/ssh.lisp
+++ b/src/property/ssh.lisp
@@ -27,3 +27,48 @@
    (apply #'file:contains-lines ".ssh/authorized_keys" keys))
   (:unapply
    (apply #'file:lacks-lines ".ssh/authorized_keys" keys)))
+
+(defprop %update-known-hosts :posix (file host &key short-hostname)
+  (:apply
+   (file:map-file-lines
+    file
+    (lambda (lines)
+      (loop with (identifier . keys)
+              = (sshd:get-host-public-keys host :short-hostname short-hostname)
+            for line in lines
+            for index = (position #\Space line)
+            for line-identifier = (subseq line 0 index)
+            and line-key = (subseq line (1+ index))
+            when (or (not (string= line-identifier identifier))
+                     (member line-key keys :test #'string=))
+              collect line into accum
+              and do (deletef keys line-key :test #'string=)
+            finally
+               (return
+                 (nconc accum
+                        (loop for key in keys
+                              collect (format nil "~A ~A" identifier key))))))))
+  (:unapply
+   (destructuring-bind (identifier . keys)
+       (sshd:get-host-public-keys host :short-hostname short-hostname)
+     (file:lacks-lines file
+                       (loop for key in keys
+                             collect (format nil "~A ~A" identifier key))))))
+
+(defproplist known-host :posix (host &key short-hostname)
+  "Ensures that the SSH host keys of HOST are stored in ~/.ssh/known_hosts.
+If SHORT-HOSTNAME, include the part of HOST's hostname before the first dot as
+one of the hostnames identifying HOST.  Removes any other host keys
+identifying HOST, to simplify refreshing keys."
+  (:desc #?"${(get-hostname host)} is known host to ssh client")
+  (file:directory-exists ".ssh")
+  (%update-known-hosts ".ssh/known_hosts" host :short-hostname short-hostname))
+
+(defproplist globally-known-host :posix (host &key short-hostname)
+  "Ensures that SSH host keys of HOST are stored in /etc/ssh/ssh_known_hosts.
+If SHORT-HOSTNAME, include the part of HOST's hostname before the first dot as
+one of the hostnames identifying HOST.  Removes any other host keys
+identifying HOST, to simplify refreshing keys."
+  (:desc #?"${(get-hostname host)} is globally known host to ssh client")
+  (%update-known-hosts
+   "/etc/ssh/ssh_known_hosts" host :short-hostname short-hostname))
diff --git a/src/property/sshd.lisp b/src/property/sshd.lisp
index 6e8cca2..b55dd0f 100644
--- a/src/property/sshd.lisp
+++ b/src/property/sshd.lisp
@@ -18,6 +18,8 @@
 (in-package :consfigurator.property.sshd)
 (named-readtables:in-readtable :consfigurator)
 
+;;;; Basic configuration
+
 (defproplist installed :posix ()
   "Install an OpenSSH server."
   (:desc "OpenSSH server installed")
@@ -42,3 +44,30 @@ refuses to proceed if root has no authorized_keys."
      (failed-change "root has no authorized_keys"))
    (configured "PermitRootLogin" "without-password"
                "PasswordAuthentication" "no")))
+
+
+;;;; Host keys
+
+(defprop has-host-public-key :posix (type public-key)
+  "Records an SSH public key of type TYPE as identifying this host."
+  (:desc #?"Has SSH host key of type ${type}")
+  (:hostattrs (push-hostattrs 'host-public-key (cons type public-key))))
+
+(defproplist has-host-key :posix (type public-key)
+  "Installs the host key whose public part is PUBLIC-KEY and is of type TYPE.
+The private key is obtained as an item of prerequisite data."
+  (:desc #?"SSH host key of type ${type} installed")
+  (has-host-public-key type public-key)
+  (file:has-content (merge-pathnames (strcat "ssh_host_" type "_key.pub")
+                                     #P"/etc/ssh/")
+    public-key)
+  (file:host-secret-uploaded (merge-pathnames (strcat "ssh_host_" type "_key")
+                                              #P"/etc/ssh/")))
+
+(defun get-host-public-keys (host &key short-hostname)
+  (let* ((host (preprocess-host host))
+         (hostname (get-hostname host)))
+    (cons (format nil "~A~:[~;,~A~]"
+                  hostname (and short-hostname (find #\. hostname))
+                  (car (split-string hostname :separator ".")))
+          (mapcar #'cdr (get-hostattrs 'host-public-key host)))))