1 files changed, 88 insertions, 0 deletions
diff --git a/src/property/crypttab.lisp b/src/property/crypttab.lisp
new file mode 100644
index 0000000..a24ac26
--- /dev/null
+++ b/src/property/crypttab.lisp
@@ -0,0 +1,88 @@
+;;; Consfigurator -- Lisp declarative configuration management system
+
+;;; Copyright (C) 2021  Sean Whitton <spwhitton@spwhitton.name>
+
+;;; This file is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3, or (at your option)
+;;; any later version.
+
+;;; This file is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+(in-package :consfigurator.property.crypttab)
+(named-readtables:in-readtable :consfigurator)
+
+;;;; Methods on volumes to get strings for crypttab
+
+(defun get-lsblk-field (device field)
+  (let ((val (stripln (run "lsblk" "-ndo" field device))))
+    (if (string= val "") nil val)))
+
+(defun get-device-parent (device)
+  (multiple-value-bind (match groups)
+      (re:scan-to-strings #?/^1\s+dependencies\s*:\s*\((\S+)\)$/
+                          (run "dmsetup" "deps" "-o" "blkdevname" device))
+    (and match (merge-pathnames (elt groups 0) #P"/dev/"))))
+
+(defmethod ct-target ((volume opened-luks-container))
+  (volume-label volume))
+
+(defmethod ct-source ((volume opened-luks-container))
+  (with-slots (device-file) volume
+    (let ((parent
+            (or (get-device-parent device-file)
+                (failed-change
+                 "Could not determine parent device of ~A" device-file))))
+      (if-let ((partuuid (get-lsblk-field parent "PARTUUID")))
+        (strcat "PARTUUID=" partuuid)
+        (if-let ((uuid (get-lsblk-field parent "UUID")))
+          (strcat "UUID=" uuid)
+          (failed-change
+           "Could not determine crypttab source field for ~A" device-file))))))
+
+(defmethod ct-keyfile ((volume opened-luks-container))
+  (if (slot-boundp volume 'crypttab-keyfile)
+      (crypttab-keyfile volume)
+      "none"))
+
+(defmethod ct-options ((volume opened-luks-container))
+  (or (crypttab-options volume) '("none")))
+
+(defmethod volume->entry ((volume opened-luks-container))
+  (format nil "~A ~A ~A ~{~A~^,~}"
+          (ct-target volume) (ct-source volume)
+          (ct-keyfile volume) (ct-options volume)))
+
+
+;;;; Properties
+
+(defprop entries :posix (&rest entries)
+  "Ensure that /etc/crypttab contains each of ENTRIES, using a simple merge
+procedure: existing lines of the crypttab with the same mapped device name as
+any of ENTRIES are updated to match the corresponding members of ENTRIES,
+except that if the second field of the existing entry is not \"none\" and the
+corresponding member of ENTRIES is \"none\" or \"PLACEHOLDER\", use the
+existing field value."
+  (:desc
+   (let ((devices
+           (loop for entry in entries collect (car (split-string entry)))))
+     (format nil "crypttab entr~@P for ~{~A~^, ~}" (length devices) devices)))
+  (:apply (file:update-unix-table #P"/etc/crypttab" 1 0 entries)))
+
+(defprop entries-for-opened-volumes :posix ()
+  "Add or update entries in /etc/crypttab for currently open volumes.
+
+This is used when building disk images and installing operating systems."
+  (:desc "crypttab entries for opened volumes")
+  (:hostattrs (os:required 'os:linux))
+  (:apply
+   (apply #'entries
+          (mapcar #'volume->entry
+                  (mapcan (curry #'subvolumes-of-type 'opened-luks-container)
+                          (get-connattr :opened-volumes))))))