diff options
72 files changed, 4082 insertions, 1422 deletions
diff --git a/consfigurator.asd b/consfigurator.asd index e518632..24e0812 100644 --- a/consfigurator.asd +++ b/consfigurator.asd @@ -1,6 +1,6 @@ (defsystem "consfigurator" :description "Lisp declarative configuration management system" - :version "0.8.0" + :version "0.9.0" :author "Sean Whitton <spwhitton@spwhitton.name>" :licence "GPL-3+" :serial t @@ -14,8 +14,8 @@ #:cffi (:feature :sbcl (:require #:sb-posix)) #:closer-mop - #:trivial-backtrace - #:trivial-macroexpand-all) + #:agnostic-lizard + #:trivial-backtrace) :components ((:file "src/package") (:file "src/reader") (:file "src/util") @@ -27,16 +27,17 @@ (:file "src/deployment") (:file "src/connection/local") (:file "src/data") + (:file "src/image") (:file "src/property/cmd") (:file "src/property/file") (:file "src/property/etc-default") (:file "src/property/os") (:file "src/property/container") + (:file "src/property/periodic") (:file "src/property/mount") (:file "src/property/service") (:file "src/property/apt") (:file "src/property/chroot") - (:file "src/property/live-build") (:file "src/property/disk") (:file "src/property/fstab") (:file "src/property/crypttab") @@ -46,12 +47,24 @@ (:file "src/property/ssh") (:file "src/property/sshd") (:file "src/property/locale") + (:file "src/property/reboot") (:file "src/property/installer") (:file "src/property/grub") (:file "src/property/u-boot") (:file "src/property/hostname") (:file "src/property/network") (:file "src/property/libvirt") + (:file "src/property/ccache") + (:file "src/property/schroot") + (:file "src/property/sbuild") + (:file "src/property/postfix") + (:file "src/property/cron") + (:file "src/property/lets-encrypt") + (:file "src/property/apache") + (:file "src/property/systemd") + (:file "src/property/firewalld") + (:file "src/property/timezone") + (:file "src/property/swap") (:file "src/connection/shell-wrap") (:file "src/connection/fork") (:file "src/connection/rehome") @@ -66,13 +79,14 @@ (:file "src/data/pgp") (:file "src/data/git-snapshot") (:file "src/data/gpgpubkeys") - (:file "src/data/ssh-askpass")) + (:file "src/data/ssh-askpass") + (:file "src/data/local-file")) :in-order-to ((test-op (test-op "consfigurator/tests")))) (defsystem "consfigurator/tests" :description "Tests for Consfigurator, Lisp declarative configuration management system" - :version "0.8.0" + :version "0.9.0" :author "Sean Whitton <spwhitton@spwhitton.name>" :licence "GPL-3+" :serial t diff --git a/debian/changelog b/debian/changelog index 0b85057..906a81a 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,12 @@ +consfigurator (0.9.0-1) UNRELEASED; urgency=medium + + * New upstream release. + * Replace dep and build-dep cl-trivial-macroexpand-all -> cl-agnostic-lizard. + * Add build-dep on python3-sphinx-rtd-theme. + * Update copyright years. + + -- Sean Whitton <spwhitton@spwhitton.name> Sat, 24 Jul 2021 15:35:13 -0700 + consfigurator (0.8.0-2) unstable; urgency=high * Backport some security & FFI fixes to :SETUID and :SUDO connections. diff --git a/debian/control b/debian/control index e5fae5d..60cb533 100644 --- a/debian/control +++ b/debian/control @@ -12,12 +12,13 @@ Build-Depends: cl-ppcre, cl-closer-mop, cl-trivial-backtrace, - cl-trivial-macroexpand-all, + cl-agnostic-lizard, debhelper-compat (= 13), dh-elpa, python3-sphinx, sbcl, sphinx-common, + python3-sphinx-rtd-theme, texinfo, Standards-Version: 4.5.1 Homepage: https://spwhitton.name/tech/code/consfigurator/ @@ -37,7 +38,7 @@ Depends: cl-ppcre, cl-closer-mop, cl-trivial-backtrace, - cl-trivial-macroexpand-all, + cl-agnostic-lizard, emacsen-common, ${misc:Depends}, Recommends: diff --git a/debian/copyright b/debian/copyright index e5ee99f..ce8b60a 100644 --- a/debian/copyright +++ b/debian/copyright @@ -1,8 +1,8 @@ Consfigurator Lisp declarative configuration management system -Copyright (C)2015, 2018, 2020-2021 Sean Whitton -Copyright (C)2021 David Bremner +Copyright (C)2015-2018, 2020-2021 Sean Whitton +Copyright (C)2021 David Bremner This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as diff --git a/debian/patches/add-posix-login-environment-and-use-in-s.patch b/debian/patches/add-posix-login-environment-and-use-in-s.patch deleted file mode 100644 index 54e100e..0000000 --- a/debian/patches/add-posix-login-environment-and-use-in-s.patch +++ /dev/null @@ -1,90 +0,0 @@ -From: Sean Whitton <spwhitton@spwhitton.name> -Date: Thu, 1 Jul 2021 23:08:58 -0700 -X-Dgit-Generated: 0.8.0-2 eb33733e65326f771822f1f4b767f47382eb4914 -Subject: add POSIX-LOGIN-ENVIRONMENT and use in :SETUID connection - -Signed-off-by: Sean Whitton <spwhitton@spwhitton.name> -(cherry picked from commit 60d2ca122ee7dc29fc66b4364bcf79f5a7041b64) - ---- - ---- consfigurator-0.8.0.orig/src/connection/setuid.lisp -+++ consfigurator-0.8.0/src/connection/setuid.lisp -@@ -53,15 +53,13 @@ - :datadir datadir - :connattrs `(:remote-uid ,uid - :remote-gid ,gid -+ :remote-user ,to - :remote-home ,home)) - remaining)))) - - (defmethod post-fork ((connection setuid-connection)) -- ;; TODO Set up the new environment more systematically. Perhaps look at how -- ;; runuser(1) uses PAM to do this. - (let ((uid (connection-connattr connection :remote-uid)) -- (gid (connection-connattr connection :remote-gid)) -- (home (connection-connattr connection :remote-home))) -+ (gid (connection-connattr connection :remote-gid))) - (run-program (list "chown" "-R" - (format nil "~A:~A" uid gid) - (unix-namestring (slot-value connection 'datadir)))) -@@ -69,5 +67,6 @@ - (error "setgid(2) failed!")) - (unless (zerop (setuid uid)) - (error "setuid(2) failed!")) -- (setf (getenv "HOME") (unix-namestring home)) -- (uiop:chdir home))) -+ (posix-login-environment -+ (connection-connattr connection :remote-user) -+ (connection-connattr connection :remote-home)))) ---- consfigurator-0.8.0.orig/src/package.lisp -+++ consfigurator-0.8.0/src/package.lisp -@@ -1,7 +1,7 @@ - (in-package :cl-user) - - (defpackage :consfigurator -- (:use #:cl #:alexandria) -+ (:use #:cl #:alexandria #:cffi) - (:local-nicknames (#:re #:cl-ppcre)) - (:shadowing-import-from #:uiop - #:strcat -@@ -100,6 +100,7 @@ - - #:unwind-protect-in-parent - #:cancel-unwind-protect-in-parent-cleanup -+ #:posix-login-environment - - ;; connection.lisp - #:establish-connection ---- consfigurator-0.8.0.orig/src/util.lisp -+++ consfigurator-0.8.0/src/util.lisp -@@ -387,6 +387,29 @@ of this macro." - Should be called soon after fork(2) in child processes." - (signal 'in-child-process)) - -+(defun posix-login-environment (logname home) -+ "Reset the environment after switching UID, or similar, in a :LISP connection. -+Does not currently establish a PAM session." -+ (let ((euid (foreign-funcall "geteuid" :int)) -+ (maybe-preserve '("TERM"))) -+ (when (zerop euid) -+ (push "SSH_AUTH_SOCK" maybe-preserve)) -+ (let ((preserved (loop for var in maybe-preserve -+ for val = (getenv var) -+ when val collect var and collect val))) -+ (unless (zerop (foreign-funcall "clearenv" :int)) -+ (failed-change "clearenv(3) failed!")) -+ (loop for (var val) on preserved by #'cddr do (setf (getenv var) val))) -+ (setf (getenv "HOME") (drop-trailing-slash (unix-namestring home)) -+ (getenv "USER") logname -+ (getenv "LOGNAME") logname -+ (getenv "SHELL") "/bin/sh" -+ (getenv "PATH") -+ (if (zerop euid) -+ "/usr/local/sbin:/usr/local/bin:/sbin:/bin:/usr/sbin:/usr/bin" -+ "/usr/local/bin:/bin:/usr/bin")) -+ (uiop:chdir home))) -+ - - ;;;; Lisp data files - diff --git a/debian/patches/return-type-in-foreign-funcall-of-geteui.patch b/debian/patches/return-type-in-foreign-funcall-of-geteui.patch deleted file mode 100644 index 6ea6bcf..0000000 --- a/debian/patches/return-type-in-foreign-funcall-of-geteui.patch +++ /dev/null @@ -1,65 +0,0 @@ -From: Sean Whitton <spwhitton@spwhitton.name> -Date: Fri, 23 Jul 2021 11:37:25 -0700 -X-Dgit-Generated: 0.8.0-2 4719c2966d0ddb4cfa6855aacfc6a4774c18bd70 -Subject: return type in FOREIGN-FUNCALL of geteuid(2) is unsigned - -Signed-off-by: Sean Whitton <spwhitton@spwhitton.name> -(cherry picked from commit 885b9f3f762cdf18ff358509fd8838f8222b43ba) - ---- - ---- consfigurator-0.8.0.orig/src/connection/as.lisp -+++ consfigurator-0.8.0/src/connection/as.lisp -@@ -21,7 +21,7 @@ - ;; currently we only check whether we're root, but, for example, on Linux, we - ;; might have a CAP_* which lets us setuid as non-root - (defun can-setuid () -- (zerop (foreign-funcall "geteuid" :int))) -+ (zerop (foreign-funcall "geteuid" :unsigned-int))) - - (defmethod establish-connection ((type (eql :as)) remaining &key to) - "Establish a :SETUID or :SU connection to another user account, depending on ---- consfigurator-0.8.0.orig/src/connection/chroot.lisp -+++ consfigurator-0.8.0/src/connection/chroot.lisp -@@ -21,7 +21,7 @@ - ;; currently we only check whether we're root, but, for example, on Linux, we - ;; might have a CAP_* which lets us chroot as non-root - (defun can-chroot () -- (zerop (foreign-funcall "geteuid" :int))) -+ (zerop (foreign-funcall "geteuid" :unsigned-int))) - - (defmethod establish-connection ((type (eql :chroot)) remaining &key into) - (establish-connection (if (and (lisp-connection-p) -@@ -113,7 +113,8 @@ should be the mount point, without the c - (rehome-connection chroot-connection fork-connection) ()) - - (defmethod establish-connection ((type (eql :chroot.fork)) remaining &key into) -- (unless (and (lisp-connection-p) (zerop (foreign-funcall "geteuid" :int))) -+ (unless (and (lisp-connection-p) -+ (zerop (foreign-funcall "geteuid" :unsigned-int))) - (error "~&Forking into a chroot requires a Lisp image running as root")) - (informat 1 "~&Forking into chroot at ~A" into) - (let* ((into* (ensure-directory-pathname into)) ---- consfigurator-0.8.0.orig/src/connection/setuid.lisp -+++ consfigurator-0.8.0/src/connection/setuid.lisp -@@ -32,7 +32,8 @@ - (defclass setuid-connection (rehome-connection fork-connection) ()) - - (defmethod establish-connection ((type (eql :setuid)) remaining &key to) -- (unless (and (lisp-connection-p) (zerop (foreign-funcall "geteuid" :int))) -+ (unless (and (lisp-connection-p) -+ (zerop (foreign-funcall "geteuid" :unsigned-int))) - (error "~&SETUIDing requires a Lisp image running as root")) - (informat 1 "~&SETUIDing to ~A" to) - (multiple-value-bind (match groups) ---- consfigurator-0.8.0.orig/src/util.lisp -+++ consfigurator-0.8.0/src/util.lisp -@@ -390,7 +390,7 @@ Should be called soon after fork(2) in c - (defun posix-login-environment (logname home) - "Reset the environment after switching UID, or similar, in a :LISP connection. - Does not currently establish a PAM session." -- (let ((euid (foreign-funcall "geteuid" :int)) -+ (let ((euid (foreign-funcall "geteuid" :unsigned-int)) - (maybe-preserve '("TERM"))) - (when (zerop euid) - (push "SSH_AUTH_SOCK" maybe-preserve)) diff --git a/debian/patches/series b/debian/patches/series deleted file mode 100644 index 9181f11..0000000 --- a/debian/patches/series +++ /dev/null @@ -1,5 +0,0 @@ -add-posix-login-environment-and-use-in-s.patch -setuid-connection-also-call-initgroups3.patch -sudo-ensure-that-stdin-is-a-pipe-never-a.patch -setuid-ensure-we-chdir2-before-we-setuid.patch -return-type-in-foreign-funcall-of-geteui.patch diff --git a/debian/patches/setuid-connection-also-call-initgroups3.patch b/debian/patches/setuid-connection-also-call-initgroups3.patch deleted file mode 100644 index 31d14e8..0000000 --- a/debian/patches/setuid-connection-also-call-initgroups3.patch +++ /dev/null @@ -1,43 +0,0 @@ -From: Sean Whitton <spwhitton@spwhitton.name> -Date: Wed, 21 Jul 2021 13:55:12 -0700 -X-Dgit-Generated: 0.8.0-2 07827bd9141d96ef89d05ba7f2596242ef0b6e27 -Subject: :SETUID connection: also call initgroups(3) - -Signed-off-by: Sean Whitton <spwhitton@spwhitton.name> -(cherry picked from commit 052f5d522473f10fe46fd431b372de54f7a53e62) - ---- - ---- consfigurator-0.8.0.orig/src/connection/setuid.lisp -+++ consfigurator-0.8.0/src/connection/setuid.lisp -@@ -26,6 +26,9 @@ - #+sbcl (sb-posix:setgid gid) - #-(or sbcl) (foreign-funcall "setgid" :unsigned-int uid :int)) - -+(defun initgroups (user gid) -+ (foreign-funcall "initgroups" :string user :unsigned-int gid :int)) -+ - (defclass setuid-connection (rehome-connection fork-connection) ()) - - (defmethod establish-connection ((type (eql :setuid)) remaining &key to) -@@ -59,14 +62,17 @@ - - (defmethod post-fork ((connection setuid-connection)) - (let ((uid (connection-connattr connection :remote-uid)) -- (gid (connection-connattr connection :remote-gid))) -+ (gid (connection-connattr connection :remote-gid)) -+ (user (connection-connattr connection :remote-user))) - (run-program (list "chown" "-R" - (format nil "~A:~A" uid gid) - (unix-namestring (slot-value connection 'datadir)))) -+ ;; We are privileged, so this sets the real, effective and saved IDs. - (unless (zerop (setgid gid)) - (error "setgid(2) failed!")) -+ (unless (zerop (initgroups user gid)) -+ (error "initgroups(3) failed!")) - (unless (zerop (setuid uid)) - (error "setuid(2) failed!")) - (posix-login-environment -- (connection-connattr connection :remote-user) -- (connection-connattr connection :remote-home)))) -+ user (connection-connattr connection :remote-home)))) diff --git a/debian/patches/setuid-ensure-we-chdir2-before-we-setuid.patch b/debian/patches/setuid-ensure-we-chdir2-before-we-setuid.patch deleted file mode 100644 index 00a55d9..0000000 --- a/debian/patches/setuid-ensure-we-chdir2-before-we-setuid.patch +++ /dev/null @@ -1,28 +0,0 @@ -From: Sean Whitton <spwhitton@spwhitton.name> -Date: Fri, 23 Jul 2021 08:43:06 -0700 -X-Dgit-Generated: 0.8.0-2 927cdd896fd1a4d64691d50a90cdd11ce7d675f9 -Subject: :SETUID: ensure we chdir(2) before we setuid(2) - -Signed-off-by: Sean Whitton <spwhitton@spwhitton.name> -(cherry picked from commit ae2f8d30cbcd82126de7daeb4b94dd05d5b46f01) - ---- - ---- consfigurator-0.8.0.orig/src/connection/setuid.lisp -+++ consfigurator-0.8.0/src/connection/setuid.lisp -@@ -67,12 +67,12 @@ - (run-program (list "chown" "-R" - (format nil "~A:~A" uid gid) - (unix-namestring (slot-value connection 'datadir)))) -+ (posix-login-environment -+ user (connection-connattr connection :remote-home)) - ;; We are privileged, so this sets the real, effective and saved IDs. - (unless (zerop (setgid gid)) - (error "setgid(2) failed!")) - (unless (zerop (initgroups user gid)) - (error "initgroups(3) failed!")) - (unless (zerop (setuid uid)) -- (error "setuid(2) failed!")) -- (posix-login-environment -- user (connection-connattr connection :remote-home)))) -+ (error "setuid(2) failed!")))) diff --git a/debian/patches/sudo-ensure-that-stdin-is-a-pipe-never-a.patch b/debian/patches/sudo-ensure-that-stdin-is-a-pipe-never-a.patch deleted file mode 100644 index 3a918dc..0000000 --- a/debian/patches/sudo-ensure-that-stdin-is-a-pipe-never-a.patch +++ /dev/null @@ -1,153 +0,0 @@ -From: Sean Whitton <spwhitton@spwhitton.name> -Date: Thu, 22 Jul 2021 15:20:09 -0700 -X-Dgit-Generated: 0.8.0-2 7b0c6d72899a5946b1fbc4c495de4b1458e72779 -Subject: :SUDO: ensure that stdin is a pipe, never a real file - -Signed-off-by: Sean Whitton <spwhitton@spwhitton.name> -(cherry picked from commit 56dda681a644833f9b7de1775b7d193fd120bb8e) - ---- - ---- consfigurator-0.8.0.orig/doc/connections.rst -+++ consfigurator-0.8.0/doc/connections.rst -@@ -97,7 +97,9 @@ Consfigurator sends your sudo password o - password is required is violated, your sudo password will end up in the stdin - to whatever command is being run using sudo. There is no facility for - directly passing in a passphrase; you must use ``:AS`` to obtain passwords --from sources of prerequisite data. -+from sources of prerequisite data. The passphrase will be written to a -+private temporary file which is deleted when the ``:SUDO`` connection is torn -+down. - - If any connection types which start up remote Lisp images occur before a - ``:SUDO`` entry in your connection chain, ``ESTABLISH-CONNECTION`` will need ---- consfigurator-0.8.0.orig/src/connection/sudo.lisp -+++ consfigurator-0.8.0/src/connection/sudo.lisp -@@ -35,6 +35,22 @@ - (get-data-protected-string - (strcat "--user-passwd--" host) user))))) - -+;; With sudo -S, we must ensure that sudo's stdin is a pipe, not a file, -+;; because otherwise the program sudo invokes may rewind(stdin) and read the -+;; password, intentionally or otherwise. And UIOP:RUN-PROGRAM empties input -+;; streams into temporary files, so there is the potential for this to happen -+;; when using :SUDO to apply properties to localhost. Other connection types -+;; might work similarly. -+;; -+;; The simplest way to handle this would be to just put 'cat |' at the -+;; beginning of the shell command we construct, but that relies on cat(1) not -+;; calling rewind(stdin) either. So we write the password input out to a -+;; temporary file ourselves, and use cat(1) to concatenate that file with the -+;; actual input. -+ -+(defclass sudo-connection (shell-wrap-connection) -+ ((password-file :initarg :password-file))) -+ - (defmethod establish-connection ((type (eql :sudo)) - remaining - &key -@@ -42,56 +58,41 @@ - password) - (declare (ignore remaining)) - (informat 1 "~&Establishing sudo connection to ~A" user) -- (make-instance 'sudo-connection -- :connattrs `(:remote-user ,user) -- ;; we'll send the password followed by ^M, then the real -- ;; stdin. use CODE-CHAR in this way so that we can be sure -- ;; ASCII ^M is what will get emitted. -- :password (and password -- (make-passphrase -- (strcat (passphrase password) -- (string (code-char 13))))))) -- --(defclass sudo-connection (shell-wrap-connection) -- ((password :initarg :password))) -- --(defmethod get-sudo-password ((connection sudo-connection)) -- (let ((value (slot-value connection 'password))) -- (and value (passphrase value)))) -- --(defmethod connection-shell-wrap ((connection sudo-connection) cmd) -- ;; Wrap in sh -c so that it is more likely we are either asked for a -- ;; password for all our commands or not asked for one for any. -- ;; -- ;; Preserve SSH_AUTH_SOCK for root to enable this sort of workflow: deploy -- ;; laptop using (:SUDO :SBCL) and then DEFHOST for laptop contains (DEPLOYS -- ;; ((:SSH :TO "root")) ...) to deploy a VM running on the laptop. -- ;; -- ;; This only works for sudoing to root because only the superuser can access -- ;; the socket (and was always able to, so we're not granting new access -- ;; which may be unwanted). -- (let ((user (connection-connattr connection :remote-user))) -- (format -- nil --"sudo -HkS --prompt=\"\" ~:[~;--preserve-env=SSH_AUTH_SOCK ~]--user=~A sh -c ~A" -- (string= user "root") user (escape-sh-token cmd)))) -- --(defmethod connection-run ((c sudo-connection) cmd (input null)) -- (call-next-method c cmd (get-sudo-password c))) -- --(defmethod connection-run ((c sudo-connection) cmd (input string)) -- (call-next-method c cmd (strcat (get-sudo-password c) input))) -- --(defmethod connection-run ((connection sudo-connection) cmd (input stream)) -- (call-next-method connection -- cmd -- (if-let ((password (get-sudo-password connection))) -- (make-concatenated-stream -- (if (subtypep (stream-element-type input) 'character) -- (make-string-input-stream password) -- (babel-streams:make-in-memory-input-stream -- (babel:string-to-octets -- password :encoding :UTF-8) -- :element-type (stream-element-type input))) -- input) -- input))) -+ (make-instance -+ 'sudo-connection -+ :connattrs `(:remote-user ,user) -+ :password-file (and password -+ (let ((file (mktemp))) -+ ;; We'll send the password followed by ^M, then the -+ ;; real stdin. Use CODE-CHAR in this way so that we -+ ;; can be sure ASCII ^M is what will get emitted. -+ (writefile file (strcat (passphrase password) -+ (string (code-char 13))) -+ :mode #o600) -+ file)))) -+ -+(defmethod connection-teardown :after ((connection sudo-connection)) -+ (when-let ((file (slot-value connection 'password-file))) -+ (delete-remote-trees file))) -+ -+(defmethod connection-run ((connection sudo-connection) cmd input) -+ (let* ((file (slot-value connection 'password-file)) -+ (user (connection-connattr connection :remote-user)) -+ (prefix (if file -+ (format nil "cat ~A - | sudo -HkS --prompt=\"\"" -+ (escape-sh-token file)) -+ "sudo -Hkn"))) -+ ;; Wrap in sh -c so that it is more likely we are either asked for a -+ ;; password for all our commands or not asked for one for any. -+ ;; -+ ;; Preserve SSH_AUTH_SOCK for root to enable this sort of workflow: deploy -+ ;; laptop using (:SUDO :SBCL) and then DEFHOST for laptop contains -+ ;; (DEPLOYS ((:SSH :TO "root")) ...) to deploy a VM running on the laptop. -+ ;; -+ ;; This only works for sudoing to root because only the superuser can -+ ;; access the socket (and was always able to, so we're not granting new -+ ;; access which may be unwanted). -+ (mrun :may-fail :input input -+ (format nil -+ "~A ~:[~;--preserve-env=SSH_AUTH_SOCK ~]--user=~A sh -c ~A" -+ prefix (string= user "root") user (escape-sh-token cmd))))) ---- consfigurator-0.8.0.orig/src/package.lisp -+++ consfigurator-0.8.0/src/package.lisp -@@ -121,6 +121,7 @@ - #:run - #:mrun - #:with-remote-temporary-file -+ #:mktemp - #:with-remote-current-directory - #:run-failed - #:runlines diff --git a/doc/conf.py b/doc/conf.py index 0bf86c6..653cb12 100644 --- a/doc/conf.py +++ b/doc/conf.py @@ -22,7 +22,7 @@ copyright = '2020-2021, Sean Whitton' author = 'Sean Whitton' # The full version, including alpha/beta/rc tags -release = '0.8.0' +release = '0.9.0' # -- General configuration --------------------------------------------------- @@ -49,7 +49,7 @@ highlight_language = 'common-lisp' # The theme to use for HTML and HTML Help pages. See the documentation for # a list of builtin themes. # -html_theme = 'haiku' +html_theme = 'sphinx_rtd_theme' # Add any paths that contain custom static files (such as style sheets) here, # relative to this directory. They are copied after the builtin static files, diff --git a/doc/connections.rst b/doc/connections.rst index be3ed80..6e20500 100644 --- a/doc/connections.rst +++ b/doc/connections.rst @@ -114,22 +114,17 @@ in that saved image. Typically a ``:SUDO`` connection hop is used before hops which start up remote Lisp images, so these issues will not arise for most users. -``:CHROOT.FORK`` -~~~~~~~~~~~~~~~~ - -Since forking is typically only possible when it is not the case that multiple -threads are running, it is better to avoid using this connection type as the -first hop, i.e., directly out of the root Lisp (this is not much of a -restriction, since typically the root Lisp is running under a uid which cannot -use the ``chroot(2)`` system call anyway). More generally, you should avoid -using this connection type within a Lisp image which might try to execute -other deployments in parallel. Typical usage would be something like:: +Connections which fork: ``:CHROOT.FORK``, ``:SETUID`` +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +These connection types cannot be used as the first hop, i.e., directly out of +the root Lisp. This is because they must call fork(2), and Consfigurator only +makes this system call in contexts in which there shouldn't ever be more than +one thread (excluding Lisp implementation finaliser threads and the like). +The root Lisp is not such a context, because it is often multithreaded due to +the use of SLIME. This is, however, not much of a restriction, because +typically the root Lisp is running under a UID which cannot use system calls +like chroot(2) and setuid(2) anyway. Thus, typical usage on localhost would +be something like:: (deploy (:sudo :sbcl (:chroot.fork :into "...")) ...) - -In some situations you might want to have a connection chain which effectively -uses a connection type like ``:SBCL`` twice in a row, so that the first Lisp -image can execute deployments in parallel while the second forks into the -chroot (typically by having a ``DEPLOYS`` property with connection type -``:SBCL`` as one of the properties applied by a deployment whose connection -chain itself ends with ``:SBCL``). diff --git a/doc/data.rst b/doc/data.rst index faba8a3..a32acb1 100644 --- a/doc/data.rst +++ b/doc/data.rst @@ -21,7 +21,14 @@ not use prerequisite data identified by strings matching these conditions for other purposes. - ``(HOSTNAME . PATH)`` means the data that should be uploaded to ``PATH`` on - ``HOSTNAME`` (and nowhere else) + ``HOSTNAME`` (and usually nowhere else, except in the case of, e.g., a + public key). ``PATH`` must be absolute, not relative. + +- ``(_CONTEXT . ITEM)`` is an arbitrary prerequisite data context named + ``CONTEXT``; typically ``CONTEXT`` will be a network or grouping name, + rather than referring to a single host. ``ITEM`` might be a path or some + other identifier. Reserved for consfigs; will not be used by property + definitions included with Consfigurator. - ``("--lisp-system" . SYSTEM)`` means the data is Lisp code which, when loaded, defines the packages and symbols contained in the ASDF system @@ -34,14 +41,17 @@ other purposes. identified by ``NAME``; see ``DATA.GIT-SNAPSHOT`` - ``("--pgp-pubkey" . FINGERPRINT)`` means the/a OpenPGP public key with - fingerprint FINGERPRINT + fingerprint FINGERPRINT, ASCII-armoured + +- ``("--pgp-seckey" . FINGERPRINT)`` means the/a OpenPGP secret key with + fingerprint FINGERPRINT, ASCII-armoured - ``("--luks-passphrase" . VOLUME-LABEL)`` means a LUKS passphrase for volume with label ``VOLUME-LABEL``. -(Proposed convention: Except for the first item above, these reserved names -should start with ``--`` and use ``--`` to separate parameter values within -the string. Hostnames cannot start with a hyphen.) +(Proposed convention: Except for the first two items above, these reserved +names should start with ``--`` and use ``--`` to separate parameter values +within the string. Hostnames cannot start with a hyphen.) Mechanics --------- diff --git a/doc/hosts.rst b/doc/hosts.rst index 1f8a56c..25829aa 100644 --- a/doc/hosts.rst +++ b/doc/hosts.rst @@ -31,6 +31,12 @@ keyword symbols. The semantics of these attributes are documented here: - ``:HOSTNAME``: the host's hostname -- if the host has a domain name, then the FQDN, not just the part before the first dot +- ``:ALIASES``: see ``NETWORK:ALIASES`` + +- ``:IPV4``: the host's public IPv4 addresses + +- ``:IPV6``: the host's public IPv6 addresses + - ``:DATA``: items of prerequisite data required by the host - ``:OS``: the operating system of the host diff --git a/doc/ideas.rst b/doc/ideas.rst index 688d040..a98fa42 100644 --- a/doc/ideas.rst +++ b/doc/ideas.rst @@ -12,14 +12,6 @@ Properties Connections ----------- -- :SBCL could (fork and) SAVE-LISP-AND-DIE. That way, we have something that - a cronjob can call to re-run the deployment to ensure that all properties - remain applied. Need to think about how the property which sets up the - cronjob will be specified in consfigs -- does it make sense to allow passing - in arbitrary deployments, or do we only allow re-running exactly the same - thing? If the former, the saved image will need to take some sort of - command line input telling it what arguments to pass to DEPLOY*. - - Basic infrastructure for connections which work with just input and output streams connected to an interactive POSIX sh somewhere, like TRAMP, and probably using ``base64 -d`` for WRITEFILE. Probably the basic connection @@ -35,13 +27,12 @@ Connections temporary name so that rsync can do an incremental update, and then rename the file to the new version. -Data sources ------------- - -- It might be useful to have a data source which can just provide a single - item of data when registered. Then in your consfig you can just register - this data source to make a particular file you have on your system available - to deployments. +- It would sometimes be useful to have the SSH connection pass + ``-oHostName=<known IP address>`` when ``NETWORK:IPV4`` and/or + ``NETWORK:IPV6`` have been specified for the host, so that DNS propagation + is less likely to get in the way of configuring the host. Some hosts' SSH + daemons might only be accessible over VPNs and the like, however, so it will + need to be easy to override this. Core ---- @@ -54,10 +45,11 @@ Core - A CONCURRENTLY combinator for property application specifications, which means to apply each of the enclosed properties in parallel. Particularly useful surrounding a set of DEPLOYS applications, to concurrently deploy a - number of hosts. We use ``WITH-CURRENT-DIRECTORY`` in various places, so we - may not be able to do this using threads. But if we want to do it with lots - of forking, then practically speaking usage of this combinator will be - restricted to connection chains which start up remote Lisp images. + number of hosts. Now that we don't call fork(2) while executing + deployments, we ought to be able to do this using threads, and so it can + work in the root Lisp too. However, we still use ``WITH-CURRENT-DIRECTORY`` + in various places. Perhaps that macro could be changed to only affect RUN, + MRUN etc. for the sake of enabling multithreading. - It might be useful to have a restart for the case where an attempt is made to apply a list of properties containing some ``:LISP`` properties with a diff --git a/doc/index.rst b/doc/index.rst index 680f406..2c62559 100644 --- a/doc/index.rst +++ b/doc/index.rst @@ -8,6 +8,7 @@ Consfigurator user's manual introduction installation tutorial/disk_image + tutorial/os_installation connections properties hosts diff --git a/doc/installation.rst b/doc/installation.rst index 4a2d0b2..c71836c 100644 --- a/doc/installation.rst +++ b/doc/installation.rst @@ -6,7 +6,7 @@ Installation Debian and Debian derivatives ----------------------------- -The most recent tagged release of Consfigurator is included in `Debian +The most recent tagged release of Consfigurator is usually included in `Debian unstable`_, and the .deb there should work fine on Debian stable and testing, and derivatives like Ubuntu. After adding an apt source for unstable, if necessary, ``apt-get install cl-consfigurator/unstable``. diff --git a/doc/introduction.rst b/doc/introduction.rst index 656e7eb..b6d2f0c 100644 --- a/doc/introduction.rst +++ b/doc/introduction.rst @@ -83,7 +83,7 @@ Try it out / quick start ;; These two properties are not for debootstrap(1) for but apt ;; inside the chroot. (apt:uses-parent-proxy) ; use the apt-cacher-ng set up outside chroot - (apt:uses-parent-mirror))) ; use the apt mirror set up above + (apt:uses-parent-mirrors))) ; use the apt mirror set up above Here, "spwhitton" is my username on athena; we have to tell Consfigurator what user it will be when it tries to sudo, so it knows whose password it @@ -290,10 +290,9 @@ Portability and stability - All of the code in the core library should be portable ANSI Common Lisp, though optional packages providing properties and connection types might use - implementation-specific functionality. There is one exception: we require - an implementation of ``MACROEXPAND-ALL``, but most Lisps in use today - provide this. Little to no testing is done by the author on implementations - other than SBCL, so testing and portability patches are welcome. + implementation-specific functionality. Little to no testing is done by the + author on implementations other than SBCL, so testing and portability + patches are welcome. - Little attempt is made by the author to support systems other than Debian GNU/Linux, but again, portability patches are welcome, and the design of diff --git a/doc/pitfalls.rst b/doc/pitfalls.rst index 7a7bbae..b0610eb 100644 --- a/doc/pitfalls.rst +++ b/doc/pitfalls.rst @@ -48,3 +48,34 @@ serialisable, so you can't pass anonymous functions or objects containing those. You can work around the latter restriction by defining a new property which passes in the desired anonymous function, and then adding the new property to your property application specification. + +Code-walking limitations +------------------------ + +The preprocessing of propspecs, and the conversion of unevaluated propspecs +into propspecs, both require code walking. Consfigurator's implementation of +this is in the function ``MAP-PROPSPEC-PROPAPPS``. However, due to +limitations in the Common Lisp standard, it is not possible to implement the +work of that function in a way which is both always correct and fully +portable. I have not found a general purpose code walker which hooks into +implementation-specific functionality and that is currently maintained, and so +at present we use a best-effort portable code walker, Agnostic Lizard. + +This will almost always generate the correct expansions, but if you have +particularly advanced macro property combinators then it is possible that +``MAP-PROPSPEC-PROPAPPS`` will return incorrectly expanded forms. For full +details see Michael Raskin. 2017. "Writing a best-effort portable code +walker in Common Lisp." In *Proceedings of 10th European Lisp Symposium*, +Vrije Universiteit Brussel, Belgium, April 2017 (ELS2017). DOI: +10.5281/zenodo.3254669. + +It is possible to implement the work of ``MAP-PROPSPEC-PROPAPPS`` in terms of +``MACROEXPAND-ALL``, whose semantics are conventionally well-understood and +for which fully correct implementations are available in most implementations +of Common Lisp (the trivial-macroexpand-all library can be used to get at +these). However, note that we cannot just call ``MACROEXPAND-ALL`` on +propspecs because unquoted lists appearing as arguments to properties in +atomic property applications will look like invalid function calls to the code +walker. Avoiding this would seem to require wrapping the propspec in one +macrolet for each known property, and this makes ``MACROEXPAND-ALL`` too slow, +even if the macrolet forms are precomputed. diff --git a/doc/properties.rst b/doc/properties.rst index b21f51b..3273da6 100644 --- a/doc/properties.rst +++ b/doc/properties.rst @@ -7,8 +7,9 @@ Names The names of properties may not end in the character ``.``, because that has a special meaning in unevaluated property application specifications. -Properties occupy the function cells of symbols, so do not try to define an -ordinary function with the same name as a property. +Properties with ``:APPLY`` subroutines occupy the function cells of symbols, +so except in the case of properties with no ``:APPLY`` subroutine, do not try +to define an ordinary function with the same name as a property. Working directories ------------------- diff --git a/doc/tutorial/os_installation.rst b/doc/tutorial/os_installation.rst new file mode 100644 index 0000000..7c114f0 --- /dev/null +++ b/doc/tutorial/os_installation.rst @@ -0,0 +1,80 @@ +Tutorial: OS installation +========================= + +Consfigurator implements at least the basic elements of a number of methods +for installing operating systems. + +.. include:: conventions.rst + +Build and write out a raw disk image +------------------------------------ + +This is the simplest method, and Consfigurator has decent support built-in: +see the previous tutorial. It is less practical for systems which have large +disks and/or complex, nested partitioning schemes, such as ext4 on LVM on +LUKS, as is common for GNU/Linux laptops. In such cases it is nontrivial to +expand the partitions to fill the whole physical disk after the first +successful boot, so the disk image has to be the same size as the target disk, +which can be unwieldy. + +Live replacement of provider cloud images +----------------------------------------- + +See the docstring of the INSTALLER:CLEANLY-INSTALLED-ONCE property. This is +an efficient way to handle machines in faraway datacentres. Consfigurator's +support for installing Debian stable this way has been fairly well tested, and +the technique should work for other operating systems too, once Consfigurator +has been taught how to bootstrap them. + +Build a specialised live image +------------------------------ + +This third approach is more experimental; Consfigurator has all the necessary +capabilities, at least for Debian, but at present you'll need to string them +together yourself in your consfig. With this approach you build a live image +containing everything you need to run Consfigurator on the hardware to which +you want to install. After booting up the live system, you can either run +Consfigurator manually, or you can set things up to have it run automatically +upon boot. + +Consfigurator's ability to bootstrap fresh root filesystems typically requires +Internet access, but an alternative is to build and customise a chroot +corresponding to the root filesystem of the target system, and include that in +the live image, such that after boot Consfigurator just needs to partition the +disk, copy in the contents of the prebuilt chroot, and update /etc/fstab and +/etc/crypttab with UUIDs. Here is a sketch of how to do something like that:: + + (try-register-data-source + :git-snapshot :name "consfig" + :repo #P"src/cl/consfig/" :depth 1 :branch "master") + + (defproplist live-installer-built-for :lisp (with-chroot-for) + "Build a custom Debian Live system at /srv/live/installer.iso. + + Typically this property is not applied in a DEFHOST form, but rather run as + needed at the REPL. The reason for this is that otherwise the whole image will + get rebuilt each time a commit is made to ~/src/cl/consfig/." + (:desc "Debian Live system image built") + (disk:debian-live-iso-built. nil "/srv/live/installer.iso" + (os:debian-stable "bullseye" :amd64) + (apt:installed "task-english" "live-config" "lvm2" "cryptsetup") + (git:snapshot-extracted "/etc/skel/src/cl" "consfig") + (chroot:os-bootstrapped-for + nil + (merge-pathnames (get-hostname with-chroot-for) "/srv/chroot/") + with-chroot-for))) + +Supposing we've a DEFHOST form for test.silentflame.com, on our laptop we +could then use:: + + CONSFIG> (hostdeploy-these laptop.silentflame.com + (live-installer-built-for test.silentflame.com)) + +Then once the live system has booted on the target host, you'd use the +DISK:HOST-VOLUMES-CREATED and INSTALLER:CHROOT-INSTALLED-TO-VOLUMES properties +to complete the installation. + +To prepare a live image that is capable of installing more than one system +without an Internet connection, you'd probably need to investigate including +an apt repo, or equivalent, in the live system, and point Consfigurator's OS +bootstrapping properties at that. diff --git a/emacs/consfigurator.el.in b/emacs/consfigurator.el.in index b8c3ade..7ca9ef9 100644 --- a/emacs/consfigurator.el.in +++ b/emacs/consfigurator.el.in @@ -1,7 +1,7 @@ ;;; consfigurator.el --- Utilities for working with Consfigurator consfigs ;; Author: Sean Whitton <spwhitton@spwhitton.name> -;; Version: 0.8.0 +;; Version: 0.9.0 ;; Copyright (C) 2021 Sean Whitton @@ -33,6 +33,7 @@ corresponding to the final dot-delimited component of their names." @putforms@ ;; Other operators + (put 'with-unapply 'common-lisp-indent-function '(&body)) (put 'os:typecase 'common-lisp-indent-function '(as cond)) (put 'os:etypecase 'common-lisp-indent-function '(as cond))) diff --git a/src/combinator.lisp b/src/combinator.lisp index 0403c96..cf73cce 100644 --- a/src/combinator.lisp +++ b/src/combinator.lisp @@ -21,6 +21,15 @@ ;;;; Property combinators (defmacro define-function-property-combinator (name args &body body) + "Define a function property combinator NAME with lambda list ARGS. + +Usage notes: + +- If you need to read individual arguments to propapps passed as arguments to + NAME, call PROPAPPARGS to access them. For passing a whole list of args on + to a property subroutine, just take the cdr of the propapp. + + For an example showing both techniques at work, see POSTFIX:MAPPED-FILE." (multiple-value-bind (forms declarations docstring) (parse-body body :documentation t) `(defun ,name ,args @@ -56,15 +65,43 @@ (propappunapply (choose-propapp)))))) (setf (get ',name 'inline-combinator) t))) +(defun skip-property-restarts () + (loop for restart in (compute-restarts) + when (eql 'skip-property (restart-name restart)) + collect restart)) + +;; There can be multiple SKIP-PROPERTY restarts established at once, and we +;; need this handler to invoke the one established by WITH-SKIP-PROPERTY right +;; after we establish this handler. (defmacro with-skip-failed-changes (&body forms) - `(handler-bind ((failed-change - (lambda (c) - (with-indented-inform - (informat t - (simple-condition-format-control c) - (simple-condition-format-arguments c))) - (invoke-restart 'skip-property)))) - ,@forms)) + (with-gensyms (old-restarts) + `(let ((,old-restarts (skip-property-restarts))) + (handler-bind ((failed-change + (lambda (c) + (with-indented-inform + (apply #'informat t + (simple-condition-format-control c) + (simple-condition-format-arguments c))) + ;; We can't just use NSET-DIFFERENCE and take the + ;; LASTCAR because NSET-DIFFERENCE provides no + ;; ordering guarantees. + (loop with chosen + for restart in (skip-property-restarts) + unless (member restart ,old-restarts) + do (setq chosen restart) + finally (invoke-restart chosen))))) + ,@forms)))) + +;; N.B. if PROPAPP appears in FORM then it will get evaluated more than once. +(defmacro with-skip-property (propapp form) + (once-only (propapp) + `(restart-case ,form + (skip-property () + :report (lambda (s) + (format s "Skip (~{~S~^ ~})" + (cons (car ,propapp) (propappargs ,propapp)))) + (signal 'skipped-properties) + 'failed-change)))) (define-function-property-combinator eseqprops (&rest propapps) (:retprop :type (collapse-types (mapcar #'propapptype propapps)) @@ -93,7 +130,9 @@ apply the elements of REQUIREMENTS in reverse order." (with-skip-failed-changes (let ((return-value :no-change)) (dolist (propapp propapps return-value) - (let ((result (funcall op propapp))) + (let ((result + (with-skip-property propapp (funcall op propapp)))) + (setq result (if (eql result 'failed-change) nil result)) (unless (eql result :no-change) (setq return-value result)))))))) (:retprop :type (collapse-types (mapcar #'propapptype propapps)) @@ -110,50 +149,48 @@ apply the elements of REQUIREMENTS in reverse order." (return-value :no-change) ;; Remove any null propapps because we don't want to print anything ;; for those, and applying them will do nothing. - (propapps - (remove-if #'null (if unapply (reverse propapps) propapps)))) + (propapps (remove nil (if unapply (reverse propapps) propapps)))) (labels ((propapp-apply (propapp) (if unapply (propappunapply propapp) (propappapply propapp))) (announce-propapp-apply (propapp) - (setf (fill-pointer buffer) 0) (with-output-to-string (*standard-output* buffer) (with-indented-inform (propapp-apply propapp))))) (dolist (propapp propapps return-value) (let ((announce - (or (> *consfigurator-debug-level* 1) - (and - (not (get (get (car propapp) 'combinator) - 'inline-combinator)) + (and (or (> *consfigurator-debug-level* 2) + (not (get (get (car propapp) 'combinator) + 'inline-combinator))) ;; We don't announce properties whose names begin with ;; '%' and which have no description; these are typically ;; DEFPROPs which exist only for use within a ;; DEFPROPLIST/DEFPROPSPEC defining an exported property. - (not (and (char= #\% (char (symbol-name (car propapp)) 0)) - (not (get (car propapp) 'desc))))))) - result) - (unwind-protect-in-parent - ;; TODO Nested combinators can mean that we establish this - ;; restart more than once, and they all appear in the debugger - ;; without any way to distinguish them. Perhaps we can use the - ;; :TEST argument to RESTART-CASE such that only the - ;; innermost(?) skip option appears. - (setq result (restart-case (if announce + (not (and (< *consfigurator-debug-level* 3) + (char= #\% (char (symbol-name (car propapp)) 0)) + (not (get (car propapp) 'desc)))))) + ;; Initialise to FAILED-CHANGE here so that if there is a + ;; non-local exit from us we print "failed". For example, if + ;; the user or a combinator invokes a SKIP-PROPERTY restart + ;; established further down the property call stack. + (result 'failed-change)) + (unwind-protect (with-skip-property propapp + (setq result (if announce (announce-propapp-apply propapp) - (propapp-apply propapp)) - (skip-property () 'failed-change))) + (propapp-apply propapp)))) (when (and (plusp (length buffer)) (or (> *consfigurator-debug-level* 1) (not (eql result :no-change)))) (fresh-line) - (princ buffer))) - (when announce - (informat t "~&~@[~A :: ~]~@[~A ... ~]~A~%" - (get-hostname) (propappdesc propapp) - (case result - (:no-change "ok") - ('failed-change "failed") - (t "done")))) + (princ buffer)) + (when announce + (informat t "~&~@[~A :: ~]~@[~A ... ~]~A~%" + (get-hostname) (propappdesc propapp) + (case result + (:no-change "ok") + ('failed-change "failed") + (t "done"))))) + (setf (fill-pointer buffer) 0 + result (if (eql result 'failed-change) nil result)) (unless (eql result :no-change) (setq return-value result))))))) @@ -171,7 +208,7 @@ apply the elements of REQUIREMENTS in reverse order." ;; subroutine is only to check compatibility (with-preserve-hostattrs (apply #'propattrs psym args))) - :apply (get psym 'unapply) + :apply (get psym 'punapply) :unapply (get psym 'papply) :args args))) @@ -189,30 +226,39 @@ apply the elements of REQUIREMENTS in reverse order." (propappunapply propapp)))) (defmacro on-change (propapp &body on-change) - "If applying PROPAPP makes a change, also apply each of of the propapps -ON-CHANGE in order." - `(on-change* ,propapp ,@on-change)) + "If applying or unapplying PROPAPP makes a change, also apply each of the +propapps ON-CHANGE in order." + `(on-change* + ,propapp + ,(if (cdr on-change) `(eseqprops ,@on-change) (car on-change)) + t)) -(define-function-property-combinator on-change* (propapp &rest propapps) - (:retprop :type (collapse-types (propapptype propapp) - (mapcar #'propapptype propapps)) - :desc (get (car propapp) 'desc) - :hostattrs (lambda (&rest args) - (apply #'propattrs (car propapp) args) - (mapc #'propappattrs propapps)) - :apply (lambda (&rest args) - (if (eql :no-change - (propappapply (cons (car propapp) args))) - :no-change - (dolist (propapp propapps) - (propappapply propapp)))) - :unapply (lambda (&rest args) - (if (eql :no-change - (propappunapply (cons (car propapp) args))) +(defmacro on-apply-change (propapp &body on-change) + "If applying PROPAPP makes a change, also apply each of the propapps ON-CHANGE +in order." + `(on-change* + ,propapp + ,(if (cdr on-change) `(eseqprops ,@on-change) (car on-change)))) + +(define-function-property-combinator on-change* + (propapp on-change &optional unapply) + (let ((prop (car propapp))) + (:retprop :type + (collapse-types (propapptype propapp) (propapptype on-change)) + :desc (get prop 'desc) + :hostattrs (lambda (&rest args) + (apply #'propattrs prop args) + (propappattrs on-change)) + :apply (lambda (&rest args) + (if (eql :no-change (apply #'propapply prop args)) :no-change - (dolist (propapp (reverse propapps)) - (propappunapply propapp)))) - :args (cdr propapp))) + (propappapply on-change))) + :unapply (lambda (&rest args) + (let ((result (apply #'propunapply prop args))) + (cond ((eql :no-change result) :no-change) + (unapply (propappapply on-change)) + (t result)))) + :args (cdr propapp)))) (defmacro as (user &body properties) "Apply PROPERTIES as USER by reconnecting with the :AS connection type. @@ -239,15 +285,43 @@ FLAGFILE exists, PROPAPPS are assumed to all be already applied." (:retprop :type (propapptype propapp) :desc (get (car propapp) 'desc) :hostattrs (get (car propapp) 'hostattrs) - :check (lambda (&rest ignore) - (declare (ignore ignore)) + :check (lambda-ignoring-args (remote-exists-p flagfile)) - :apply (lambda (&rest ignore) - (declare (ignore ignore)) + :apply (lambda-ignoring-args (prog1 (propappapply propapp) + (mrun "mkdir" "-p" + (pathname-directory-pathname flagfile)) (mrun "touch" flagfile))) - :unapply (lambda (&rest ignore) - (declare (ignore ignore)) + :unapply (lambda-ignoring-args (prog1 (propappunapply propapp) - (mrun "rm" flagfile))) + (mrun "rm" "-f" flagfile))) :args (cdr propapp))) + +(define-function-property-combinator with-unapply (&rest propapps) + "As ESEQPROPS, except that if :UNAPPLY appears in PROPAPPS, then return a +property which applies the elements of PROPAPPS prior to :UNAPPLY, but which +when unapplied ignores the elements of PROPAPPS prior to :UNAPPLY, and instead +applies the elements of PROPAPPS appearing after :UNAPPLY. + +Analogously to how DEFPROPLIST/DEFPROPSPEC allow you to define a property +which works by calling other properties, this combinator allows you to define +an :UNAPPLY subroutine for a property which works by calling other properties." + (let* ((apply (loop for propapp in propapps + until (eql propapp :unapply) collect propapp)) + (unapply (member :unapply propapps)) + (apply-propapp + (if (cdr apply) (apply #'eseqprops apply) (car apply))) + (unapply-propapp (if (cddr unapply) + (apply #'eseqprops (cdr unapply)) + (cadr unapply)))) + (if unapply + (:retprop :type (collapse-propapp-types apply (cdr unapply)) + :hostattrs (lambda-ignoring-args + (propappattrs apply-propapp) + ;; as in definition of UNAPPLY combinator + (with-preserve-hostattrs + (propappattrs unapply-propapp))) + :apply (lambda-ignoring-args (propappapply apply-propapp)) + :unapply (lambda-ignoring-args + (propappapply unapply-propapp))) + apply-propapp))) diff --git a/src/connection.lisp b/src/connection.lisp index 3f979d2..9159a02 100644 --- a/src/connection.lisp +++ b/src/connection.lisp @@ -69,6 +69,8 @@ For an example of usage, see the :SUDO connection type.")) :initform nil :documentation "This connection's connection attributes."))) +(define-print-object-for-structlike connection) + (defclass lisp-connection (connection) ()) (defclass posix-connection (connection) ()) @@ -262,8 +264,7 @@ which will be cleaned up when BODY is finished." `(let ((,file (mktemp ,@(and directory-supplied-p `(:directory ,directory)) :connection ,connection))) - (unwind-protect-in-parent - (progn ,@body) + (unwind-protect (progn ,@body) (connection-run ,connection (format nil "rm -f ~A" (escape-sh-token ,file)) nil))))) @@ -276,17 +277,41 @@ which will be cleaned up when BODY is finished." "tmp.XXXXXX" (ensure-directory-pathname directory))) "'${TMPDIR:-/tmp}'/tmp.XXXXXX"))) (multiple-value-bind (out exit) - ;; mktemp(1) is not POSIX; the only POSIX way is this M4 way, - ;; apparently, but even though m4(1) is POSIX it seems like it could - ;; often be absent, so have a fallback. It would be better to avoid - ;; passing any arguments to mktemp(1) as these may differ on different - ;; platforms, but hopefully just a template is okay. + ;; mktemp(1) is not POSIX; the only POSIX sh technique at the time of + ;; writing is to use m4(1)'s mkstemp macro. However, m4 is sometimes + ;; not present, so fall back to mktemp(1). Hopefully passing the + ;; template as the only command line option to mktemp(1) is portable. + ;; + ;; Although POSIX.1-2017 says that if m4(1) fails to create a + ;; temporary file it should exit nonzero, many m4(1) implementations + ;; just write to stderr and exit zero. So we examine the stderr, and + ;; if there is any, exit nonzero ourselves. ;; ;; While GNU M4 mkstemp makes the temporary file at most readable and ;; writeable by its owner, POSIX doesn't require this, so set a umask. (connection-run connection - #?"umask 077; echo 'mkstemp(${template})' | m4 2>/dev/null || mktemp '${template}'" + #?"umask 077 +if command -v m4 >/dev/null; then + if tmpf=\$(exec 3>&1 + if err=\$(echo 'mkstemp(${template})' | m4 2>&1 1>&3); then + case $err in + ?*) printf >&2 \"%s\\n\" \"$err\"; exit 1 ;; + *) exit 0 ;; + esac + else + case $err in + ?*) printf >&2 \"%s\\n\" \"$err\" ;; + esac + exit 1 + fi); then + echo $tmpf + else + exit 1; + fi +else + mktemp '${template}' +fi" nil) (let ((lines (lines out))) (if (and (zerop exit) lines) @@ -340,7 +365,8 @@ the working directory of the Lisp process using UIOP:WITH-CURRENT-DIRECTORY." (setq cmd (if (cdr cmd) (escape-sh-command cmd) (car cmd))) (loop while env collect (format nil "~A=~A" - (symbol-name (pop env)) (escape-sh-token (pop env))) + (string-upcase (symbol-name (pop env))) + (escape-sh-token (pop env))) into accum finally (when accum @@ -361,8 +387,9 @@ the working directory of the Lisp process using UIOP:WITH-CURRENT-DIRECTORY." ;; simplicity, particularly to avoid having to check whether the connattr ;; is set yet, because setting it requires working CONNECTION-RUN. (setq cmd (format nil "export HOME=~A; cd ~A; ~A" - (escape-sh-token (unix-namestring - (get-connattr :remote-home))) + (escape-sh-token (drop-trailing-slash + (unix-namestring + (get-connattr :remote-home)))) (escape-sh-token (unix-namestring (pwd))) cmd)) ,@forms)) @@ -443,6 +470,13 @@ expected." (defun test (&rest args) (zerop (apply #'mrun :for-exit "test" args))) +(defun mountpointp (path) + "Is PATH a mount point? + +Uses mountpoint(1) from util-linux, so add a property requiring OS:LINUX or a +subclass to the :HOSTATTRS subroutine of properties calling this." + (zerop (mrun :for-exit "mountpoint" "-q" path))) + (defun delete-remote-trees (&rest paths) "Recursively delete each of PATHS." (mrun "rm" "-rf" paths)) @@ -454,8 +488,14 @@ PATH may be any kind of file, including directories." nconc (list "-e" (car path)) when (cdr path) collect "-a"))) -(defun remote-file-mode-and-size (path) - "Get the numeric mode and size in bytes of PATH, or NIL if it does not exist." +(defun remote-file-stats (path) + "Get the numeric mode, size in bytes and mtime of PATH, or NIL if it does not +exist. + +The mtime is only accurate to the nearest UTC day, rounding down, if the file +was modified in the past six months or its mtime is in the future, and only +accurate to the nearest minute, rounding down, otherwise (see the +specification of POSIX ls(1))." (flet ((sum (chars order) (+ (if (char= (elt chars 0) #\r) (* order 4) 0) (if (char= (elt chars 1) #\w) (* order 2) 0) @@ -467,12 +507,51 @@ PATH may be any kind of file, including directories." (#\x order) (#\- 0))))) (and (remote-exists-p path) - (let* ((ls (split-string (run "ls" "-ld" path))) + ;; This is a safe parse of ls(1) given its POSIX specification. + (let* ((ls (words + (run :env '(:LC_ALL "C" :TZ "UTC") "ls" "-ld" path))) (lscar (car ls))) (values (+ (sum (subseq lscar 1 4) #o100) (sum (subseq lscar 4 7) #o10) (sum (subseq lscar 7 10) 1)) - (parse-integer (nth 4 ls))))))) + (parse-integer (nth 4 ls)) + (let ((date (parse-integer (nth 6 ls))) + (month (cdr + (assoc + (nth 5 ls) + '(("Jan" . 1) ("Feb" . 2) ("Mar" . 3) + ("Apr" . 4) ("May" . 5) ("Jun" . 6) + ("Jul" . 7) ("Aug" . 8) ("Sep" . 9) + ("Oct" . 10) ("Nov" . 11) ("Dec" . 12)) + :test #'string=)))) + (if (find #\: (nth 7 ls)) + (destructuring-bind (hour minute) + (split-string (nth 7 ls) :separator ":") + (encode-universal-time + 0 (parse-integer minute) (parse-integer hour) + date month (nth-value 5 (get-decoded-time)) + 0)) + (encode-universal-time + 0 0 0 date month (parse-integer (nth 7 ls)) 0)))))))) + +(defun remote-last-reboot () + "Get the time of the last reboot, rounded down to the nearest minute." + ;; The '-b' option to who(1) is specified in POSIX, though not the output + ;; format; this parse is based on GNU coreutils who(1). + (multiple-value-bind (match groups) + (re:scan-to-strings + "([0-9]{4})-([0-9]{2})-([0-9]{2}) ([0-9]{2}):([0-9]{2})" + (car (runlines :env '(:TZ "UTC") "who" "-b"))) + (if match + (let ((groups (map 'vector #'parse-integer groups))) + (encode-universal-time 0 (elt groups 4) (elt groups 3) + (elt groups 2) (elt groups 1) (elt groups 0) + 0)) + (failed-change "Could not determine time of remote's last reboot.")))) + +(defun remote-consfigurator-cache-pathname (path) + (merge-pathnames + path (car (runlines "echo ${XDG_CACHE_HOME:-$HOME/.cache}/consfigurator/")))) (defun readfile (path) (connection-readfile diff --git a/src/connection/as.lisp b/src/connection/as.lisp index 024603d..229d238 100644 --- a/src/connection/as.lisp +++ b/src/connection/as.lisp @@ -30,8 +30,6 @@ whether it is possible to establish a :SETUID connection. Note that both these connection types require root." ;; An alternative to :SU would be :SUDO or runuser(1), but :SU is more ;; portable. - (establish-connection (if (and (lisp-connection-p) - (can-setuid) - (can-probably-fork)) + (establish-connection (if (and (lisp-connection-p) (can-setuid)) :setuid :su) remaining :to to)) diff --git a/src/connection/chroot.lisp b/src/connection/chroot.lisp index 730335f..2b2678c 100644 --- a/src/connection/chroot.lisp +++ b/src/connection/chroot.lisp @@ -24,9 +24,7 @@ (zerop (foreign-funcall "geteuid" :unsigned-int))) (defmethod establish-connection ((type (eql :chroot)) remaining &key into) - (establish-connection (if (and (lisp-connection-p) - (can-chroot) - (can-probably-fork)) + (establish-connection (if (and (lisp-connection-p) (can-chroot)) :chroot.fork :chroot.shell) remaining @@ -48,7 +46,7 @@ should be the mount point, without the chroot's root prefixed.") (slot-value connection 'into)))) ;; We only mount when the target is not already a mount point, so we ;; don't shadow anything that the user has already set up. - (when (plusp (mrun :for-exit "mountpoint" "-q" dest)) + (unless (mountpointp dest) (setq mount-args (copy-list mount-args)) (setf (lastcar mount-args) dest) (apply #'mrun "mount" mount-args) @@ -56,30 +54,25 @@ should be the mount point, without the chroot's root prefixed.") (defmethod connection-teardown :before ((connection chroot-connection)) (dolist (mount (chroot-mounts connection)) - (mrun "umount" mount))) - -(defparameter *standard-chroot-mounts* '( -("-t" "proc" "-o" "nosuid,noexec,nodev" "proc" "/proc") -("-t" "sysfs" "-o" "nosuid,noexec,nodev,ro" "sys" "/sys") -("-t" "devtmpfs" "-o" "mode=0755,nosuid" "udev" "/dev") -("-t" "devpts" "-o" "mode=0620,gid=5,nosuid,noexec" "devpts" "/dev/pts") -("-t" "tmpfs" "-o" "mode=1777,nosuid,nodev" "shm" "/dev/shm") -("-t" "tmpfs" "-o" "mode=1777,strictatime,nodev,nosuid" "tmp" "/tmp") -("--bind" "/run" "/run"))) + ;; There shouldn't be any processes left running in the chroot after we've + ;; finished deploying it, but it's quite easy to end up with things like + ;; gpg-agent holding on to /dev/null, for example, so for simplicity, do a + ;; lazy unmount. + (mrun "umount" "-l" mount))) (defmethod initialize-instance :after ((connection chroot-connection) &key) (when (string= "Linux" (stripln (run "uname"))) (with-slots (into) connection - ;; Ensure the chroot itself is a mountpoint so that findmnt(1) works + ;; Ensure the chroot itself is a mountpoint so that findmnt(8) works ;; correctly within the chroot. - (unless (zerop (mrun :for-exit "mountpoint" "-q" into)) - (chroot-mount connection "--bind" into "/")) + (unless (mountpointp into) (chroot-mount connection "--bind" into "/")) ;; Now set up the usual bind mounts. Help here from arch-chroot(8). - (dolist (mount *standard-chroot-mounts*) + (mount:assert-devtmpfs-udev-/dev) + (dolist (mount mount:*standard-linux-vfs*) (apply #'chroot-mount connection mount)) + (chroot-mount connection "--bind" "/run" "/run") (when (remote-exists-p "/sys/firmware/efi/efivars") - (chroot-mount connection "-t" "efivarfs" "-o" "nosuid,noexec,nodev" - "efivarfs" "/sys/firmware/efi/efivars"))))) + (apply #'chroot-mount connection mount:*linux-efivars-vfs*))))) (defmethod propagate-connattr ((type (eql :opened-volumes)) connattr (connection chroot-connection)) @@ -135,7 +128,7 @@ should be the mount point, without the chroot's root prefixed.") (ensure-pathname (stripln (subseq datadir-inside 1)) :defaults into* :ensure-absolute t :ensure-directory t)) - (unwind-protect-in-parent (continue-connection connection remaining) + (unwind-protect (continue-connection connection remaining) (connection-teardown connection))))) (defmethod post-fork ((connection chroot.fork-connection)) diff --git a/src/connection/fork.lisp b/src/connection/fork.lisp index 1d96501..3737a78 100644 --- a/src/connection/fork.lisp +++ b/src/connection/fork.lisp @@ -18,33 +18,6 @@ (in-package :consfigurator.connection.fork) (named-readtables:in-readtable :consfigurator) -;; Use only implementation-specific fork and waitpid calls to avoid thread -;; woes. Things like chroot(2) and setuid(2), however, should be okay. - -(defun fork () - #+sbcl (sb-posix:fork)) - -(defun waitpid (pid options) - ;; normalise any other implementations such that we always return - ;; (values PID EXIT-STATUS), as SB-POSIX:WAITPID does - #+sbcl (sb-posix:waitpid pid options)) - -(defun wifexited (status) - #+sbcl (sb-posix:wifexited status)) - -(defun wexitstatus (status) - #+sbcl (sb-posix:wexitstatus status)) - -(defun can-probably-fork () - "Return nil if we can detect other running threads, and the Lisp -implementation is known not to support forking when there are other threads. -A return value other than nil indicates only that we couldn't detect -circumstances in which it is known that we cannot fork, not that we are sure -we can fork -- a thread might be only partly initialised at the time we check, -for example, such that we don't see it." - (and - #+sbcl (> 2 (length (sb-thread:list-all-threads))))) - (defclass fork-connection (local-connection) ()) (defgeneric post-fork (connection) @@ -52,63 +25,11 @@ for example, such that we don't see it." "Code to execute after forking but before calling CONTINUE-DEPLOY*.")) (defmethod continue-connection ((connection fork-connection) remaining) - (unless (lisp-connection-p) - (error "Forking requires a Lisp-type connection.")) - #-(or sbcl) (error "Don't know how to safely fork() in this Lisp") - (upload-all-prerequisite-data - :connection connection :upload-string-data nil) - (with-remote-temporary-file (output) - (mapc #'force-output - (list *standard-output* *error-output* *debug-io* *terminal-io*)) - (let ((child (fork))) - (case child - ;; note that SB-POSIX:FORK can only return >=0 - (-1 - (error "fork(2) failed")) - (0 - (handler-bind ((serious-condition - (lambda (c) - (trivial-backtrace:print-backtrace - c :output *error-output*) - (uiop:quit 2)))) - ;; Capture child stdout in case *STANDARD-OUTPUT* has been rebound - ;; to somewhere else in the parent, e.g. by APPLY-AND-PRINT. The - ;; parent can then send the contents of the file named by OUTPUT to - ;; the correct stream. We don't use pipe(2) because then we'd need - ;; implementation-specific code to bind streams to the FDs. - (with-open-file (*standard-output* - output :direction :output :if-exists :append) - (mapc #'clear-input - (list *standard-input* *debug-io* *terminal-io*)) - (cancel-unwind-protect-in-parent-cleanup) - ;; While some kinds of data source will still work given certain - ;; subtypes of FORK-CONNECTION (e.g. if they've already cached - ;; the data in memory, or if it's also accessible to whomever we - ;; will SETUID to), others won't, so drop all registrations and - ;; rely on the call to UPLOAD-ALL-PREREQUISITE-DATA above. - (reset-data-sources) - (post-fork connection) - ;; It would be nice to reenter Consfigurator's primary loop by - ;; just calling (return-from establish-connection - ;; (establish-connection :local)) here, but we need to kill off - ;; the child afterwards, rather than returning to the child's - ;; REPL or whatever else. - (uiop:quit - (if (eql :no-change (continue-deploy* connection remaining)) - 0 - 1))))) - (t - (multiple-value-bind (pid status) (waitpid child 0) - (declare (ignore pid)) - (fresh-line) - (princ (readfile output)) - (let ((exited (wifexited status))) - (unless exited - (error - "Fork connection child did not exit normally, status #x~(~4,'0X~)" - status)) - (let ((exit-status (wexitstatus status))) - (unless (< exit-status 2) - (error - "Fork connection child failed, exit code ~D" exit-status)) - (values nil (if (zerop status) :no-change nil)))))))))) + (upload-all-prerequisite-data connection) + (eval-in-grandchild `(post-fork ,connection) + `(continue-deploy* ,connection ',remaining) (out err exit) + (inform t (lines out)) + (return-exit + exit + :on-failure (failed-change + "~&Fork connection child failed; stderr was ~%~%~A" err)))) diff --git a/src/connection/sbcl.lisp b/src/connection/sbcl.lisp index 770d408..ed68243 100644 --- a/src/connection/sbcl.lisp +++ b/src/connection/sbcl.lisp @@ -19,8 +19,6 @@ (named-readtables:in-readtable :consfigurator) (defproplist sbcl-available :posix () - (:check - (zerop (mrun :for-exit "command" "-v" "sbcl"))) (os:etypecase (debianlike (apt:installed "sbcl")))) @@ -34,7 +32,19 @@ Lisp. This can mean that prerequisite data gets extracted from encrypted stores and stored unencrypted under ~~/.cache, and as such is not recommended.")) - (ignoring-hostattrs (sbcl-available)) + (unless (zerop (mrun :for-exit "command" "-v" "sbcl")) + ;; If we're not the final hop then we don't know the OS of the host to + ;; which we're currently connected, so we can't apply SBCL-AVAILABLE. + ;; + ;; TODO In the case of INSTALLER:CLEANLY-INSTALLED-ONCE this code will + ;; have us trying to use apt to install sbcl on a Fedora host, say, upon + ;; the first connection, before Debian has been installed. Perhaps we + ;; should just have some code which tries to install sbcl based on the + ;; package manager(s) it can find on PATH. Could reuse that code for + ;; CHROOT::%DEBOOTSTRAP-MANUALLY-INSTALLED. + (if remaining + (failed-change "sbcl not on PATH and don't know how to install.") + (sbcl-available))) (let ((requirements (asdf-requirements-for-host-and-features (safe-read-from-string (run :input "(prin1 *features*)" *sbcl*) @@ -46,13 +56,14 @@ recommended.")) (multiple-value-bind (program forms) (continue-deploy*-program remaining requirements) (multiple-value-bind (out err exit) (run :may-fail :input program *sbcl*) - (inform t (if (zerop exit) "done." "failed.") :fresh-line nil) + (inform t (if (< exit 3) "done." "failed.") :fresh-line nil) (when-let ((lines (lines out))) (inform t " Output was:" :fresh-line nil) (with-indented-inform (inform t lines))) - (unless (zerop exit) - ;; print FORMS not PROGRAM because latter might contain sudo passwords - (failed-change - "~&Remote Lisp failed; stderr was:~%~%~A~&~%Program we sent:~%~%~S" - err forms))))) - nil) + (return-exit + exit + ;; print FORMS not PROGRAM because latter might contain sudo passwords + :on-failure + (failed-change + "~&Remote Lisp failed; stderr was:~%~%~A~&~%Program we sent:~%~%~S" + err forms)))))) diff --git a/src/connection/setuid.lisp b/src/connection/setuid.lisp index e61222b..d1df1b6 100644 --- a/src/connection/setuid.lisp +++ b/src/connection/setuid.lisp @@ -48,8 +48,10 @@ (datadir (ensure-directory-pathname (stripln - ;; su(1) is not POSIX but very likely to be present - ;; TODO however, this use of su(1) uses a non-portable -c argument + ;; su(1) is not POSIX but very likely to be present. Note that + ;; the -c argument here is to the user's login shell, not the + ;; -c argument to su(1) on, e.g., FreeBSD. So should be fairly + ;; portable. (mrun "su" to "-c" "echo ${XDG_CACHE_HOME:-$HOME/.cache}/consfigurator/data/"))))) diff --git a/src/connection/su.lisp b/src/connection/su.lisp index 05df15d..785302f 100644 --- a/src/connection/su.lisp +++ b/src/connection/su.lisp @@ -28,7 +28,8 @@ (defclass su-connection (shell-wrap-connection) ((user :initarg :user))) -;; TODO -c is not portable to other su implementations. +;; Note that the -c here is an argument to the user's login shell, not the -c +;; argument to su(1) on, e.g., FreeBSD. So this should be fairly portable. (defmethod connection-shell-wrap ((connection su-connection) cmd) (format nil "su ~A -c ~A" (escape-sh-token (slot-value connection 'user)) diff --git a/src/data.lisp b/src/data.lisp index eccf283..c78784c 100644 --- a/src/data.lisp +++ b/src/data.lisp @@ -271,7 +271,7 @@ and PATH has mode MODE." (let ((stream (%get-data-stream data))) (if (and (remote-exists-p path) (multiple-value-bind (existing-mode existing-size) - (remote-file-mode-and-size path) + (remote-file-stats path) (and (or (not mode-supplied-p) (= mode existing-mode)) (= (file-length stream) existing-size) (= (data-cksum data) (cksum path))))) @@ -330,19 +330,12 @@ new versions of data, to avoid them piling up.")) ((connection connection) (k (eql 'cached-data))) (make-hash-table :test #'equal)) -(defun upload-all-prerequisite-data - (&key (upload-string-data t) (connection *connection*)) +(defun upload-all-prerequisite-data (&optional (connection *connection*)) "Upload all prerequisite data required by the current deployment to the remote cache of the current connection hop, or to the remote cache of CONNECTION. -If UPLOAD-STRING-DATA is false, don't upload items of string data, but -retrieve them from data sources and keep in memory. This is for connection -types which will do something like fork after calling this function. - This is called by implementations of ESTABLISH-CONNECTION which call CONTINUE-DEPLOY* or CONTINUE-DEPLOY*-PROGRAM." - ;; Retrieving & keeping in memory refers to how %GET-DATA stores items of - ;; string data in *STRING-DATA*. (flet ((record-cached-data (iden1 iden2 version) (let ((*connection* connection)) (setf (gethash (cons iden1 iden2) (get-connattr 'cached-data)) @@ -359,18 +352,16 @@ CONTINUE-DEPLOY* or CONTINUE-DEPLOY*-PROGRAM." (get-remote-cached-prerequisite-data connection)))) for (thunk highest-local-version) - = (restart-case (multiple-value-list (%get-data iden1 iden2)) + = (handler-case (multiple-value-list (%get-data iden1 iden2)) (missing-data () nil)) if (and highest-local-version (or (not highest-remote-version) (version> highest-local-version highest-remote-version))) do (let ((data (funcall thunk))) - (when (or upload-string-data - (not (subtypep (type-of data) 'string-data))) - (connection-clear-data-cache connection iden1 iden2) - (connection-upload connection data) - (record-cached-data iden1 iden2 (data-version data)))) + (connection-clear-data-cache connection iden1 iden2) + (connection-upload connection data) + (record-cached-data iden1 iden2 (data-version data))) else if highest-remote-version do (informat 3 "~&Not uploading ~S | ~S ver ~S as remote has ~S" iden1 iden2 @@ -407,7 +398,7 @@ Note that since prerequisite data sources are queried only in the root Lisp, but items of prerequisite data are never uploaded to the root Lisp, there is no risk of clashes between fresly generated files and cached copies of files." (let ((pn (apply #'data-pathname (get-local-data-cache-dir) - (delete-if #'null (list iden1 iden2 version))))) + (delete nil (list iden1 iden2 version))))) (ensure-directories-exist (if version pn (ensure-directory-pathname pn))))) @@ -434,10 +425,7 @@ of CONNECTION, where each entry is of the form (and (zerop exit) (lines out)))))) (defun get-remote-data-cache-dir () - (ensure-directory-pathname - (car - (lines - (mrun "echo ${XDG_CACHE_HOME:-$HOME/.cache}/consfigurator/data/"))))) + (remote-consfigurator-cache-pathname "data/")) ;;;; Local caches @@ -511,232 +499,3 @@ chance of those passwords showing up in the clear in the Lisp debugger." (print-unreadable-object (passphrase stream) (format stream "PASSPHRASE"))) passphrase) - - -;;;; Programs for remote Lisp images - -(defclass asdf-requirements () - ((asdf-requirements :type list :initform nil)) - (:documentation - "A list of requirements as returned by certain calls to -ASDF:REQUIRED-COMPONENTS. -Elements are instances of ASDF:SYSTEM and/or ASDF:REQUIRE-SYSTEM.")) - -(defun asdf-requirements-for-host-and-features (remote-lisp-features) - "Make an instance of ASDF-REQUIREMENTS for starting up a remote Lisp image in -which *FEATURES* has the value of REMOTE-LISP-FEATURES, based on the Lisp -systems required by the host currently being deployed. - -Called by connection types which start up remote Lisp images." - (let ((*features* remote-lisp-features) - (requirements (make-instance 'asdf-requirements))) - (with-slots (asdf-requirements) requirements - (dolist (system (propspec-systems (host-propspec *host*))) - (dolist (requirement - ;; This call to ASDF:REQUIRED-COMPONENTS is based on one in - ;; the definition of the ASDF:COMPONENT-DEPENDS-ON generic - ;; for ((o gather-operation) (s system)). We use - ;; ASDF:COMPILE-OP as the :KEEP-OPERATION because - ;; ASDF::BASIC-COMPILE-OP is not exported, so this won't work - ;; for certain exotic systems. See the comment in ASDF source. - ;; - ;; TODO Can we detect when this won't work and fail, possibly - ;; falling back to ASDF:MONOLITHIC-CONCATENATE-SOURCE-OP? - (asdf:required-components - (asdf:find-system system) - :other-systems t :component-type 'asdf:system - :keep-component 'asdf:system :goal-operation 'asdf:load-op - :keep-operation 'asdf:compile-op)) - ;; Handle UIOP specially because it comes with ASDF. - (unless (string= "uiop" (asdf:component-name requirement)) - ;; What we really want instead of PUSHNEW here is a proper - ;; topological sort. - (pushnew requirement asdf-requirements)))) - (nreversef asdf-requirements)) - requirements)) - -(defgeneric request-asdf-requirements (asdf-requirements) - (:documentation - "Request that all Lisp systems required to fulfill ASDF-REQUIREMENTS be -uploaded to the remote cache of the currently established connection. - -Called by connection types which start up remote Lisp images.") - (:method ((asdf-requirements asdf-requirements)) - (loop for requirement in (slot-value asdf-requirements 'asdf-requirements) - for type = (type-of requirement) - when (and (subtypep type 'asdf:system) - (not (subtypep type 'asdf:require-system))) - do (require-data "--lisp-system" - (asdf:component-name requirement))))) - -(defgeneric asdf-requirements-load-form (asdf-requirements) - (:documentation - "Return form to (compile and) load each of the Lisp systems specified in -ASDF-REQUIREMENTS, after having uploaded those Lisp systems using -UPLOAD-ALL-PREREQUISITE-DATA.") - (:method ((asdf-requirements asdf-requirements)) - ;; As soon as we recompile something, we have to recompile everything else - ;; following it in the list, because macro definitions may have changed. - `(let* (recompile - (file (merge-pathnames "consfigurator/fasls" - (ensure-directory-pathname - (or (getenv "XDG_CACHE_HOME") - (strcat (getenv "HOME") "/.cache"))))) - (record (with-open-file (stream file :if-does-not-exist nil) - (and stream (safe-read-from-string - (slurp-stream-string stream)))))) - (unwind-protect - (progn - ,@(loop - with table = (get-connattr 'cached-data) - for requirement - in (slot-value asdf-requirements 'asdf-requirements) - for name = (asdf:component-name requirement) - collect - (etypecase requirement - (asdf:require-system `(require ,name)) - (asdf:system - (let ((source - (gethash (cons "--lisp-system" name) table))) - (unless source - (error "Somehow Lisp system ~A was not uploaded." - name)) - ;; Using COMPILE-FILE-PATHNAME* like this has the - ;; advantage that, for example, SBCL will save the FASL - ;; somewhere from which only the same version of SBCL - ;; will try to load FASLs. - `(let ((fasl (compile-file-pathname* ,source))) - (if (and (file-exists-p fasl) (not recompile)) - (load fasl) - ;; The concatenated source of at least - ;; Alexandria won't compile unless it's loaded - ;; first. This means we compile every library - ;; that's changed since the last deploy twice, - ;; which is not ideal. One possible improvement - ;; would be to maintain a list of systems known - ;; not to have this problem, such as - ;; Consfigurator, and switch the order of the - ;; LOAD and COMPILE-FILE* here for those. - (let ((pair (assoc ,source record))) - (load ,source) - (or (compile-file* ,source) - (error "Failed to compile ~S" ,source)) - (if pair - (rplacd pair fasl) - (setq record (acons ,source fasl record))) - (setq recompile t))))))))) - (with-open-file (stream file :direction :output :if-exists :supersede) - (with-standard-io-syntax - (prin1 record stream))))))) - -(defgeneric continue-deploy*-program (remaining-connections asdf-requirements) - (:documentation - "Return a program to complete the work of an enclosing call to DEPLOY*. - -Implementations of ESTABLISH-CONNECTION which start up remote Lisp images call -this function, instead of CONTINUE-DEPLOY*, and use the result to instruct the -newly started image. - -Will query the remote cache for paths to Lisp systems, so a connection to the -host which will run the Lisp image must already be established. - -The program returned is a single string consisting of a number of sexps -separated by newlines. Each sexp must be evaluated by the remote Lisp image -before the following sexp is offered to its reader. Usually this can be -achieved by sending the return value of this function into a REPL's stdin.") - (:method (remaining-connections (asdf-requirements asdf-requirements)) - (unless (eq (type-of *host*) 'preprocessed-host) - (error "Attempt to send unpreprocessed host to remote Lisp. - -Preprocessing must occur in the root Lisp.")) - (flet ((wrap (form) - ;; We used to bind a handler here to invoke SKIP-DATA-SOURCES - ;; upon MISSING-DATA-SOURCE, which means that remote Lisp images - ;; were allowed to try querying data sources. Now we just bind - ;; *NO-DATA-SOURCES* to t here. While some data sources make - ;; sense in remote Lisp images, others might make arbitrary - ;; network connections or read out of other users' homedirs - ;; (e.g. if you are using (:SUDO :SBCL), the remote Lisp might - ;; try to read your ~/.gnupg, or on another host, someone else's - ;; ~/.gnupg who has the same username as you), which are usually - ;; undesirable. So at least until some cool use case comes - ;; along, just require all data source queries to occur in the - ;; root Lisp. - `(let ((*no-data-sources* t) - (*consfigurator-debug-level* ,*consfigurator-debug-level*)) - ,form))) - (let* ((intern-forms - (loop for (export . name) - in '((nil . "*NO-DATA-SOURCES*") - (t . "*CONSFIGURATOR-DEBUG-LEVEL*")) - for intern-form - = `(intern ,name (find-package "CONSFIGURATOR")) - if export collect - `(export ,intern-form (find-package "CONSFIGURATOR")) - else collect intern-form)) - (proclamations `((proclaim '(special *no-data-sources*)) - (proclaim '(special *consfigurator-debug-level*)))) - (forms - `((make-package "CONSFIGURATOR") - ,@intern-forms - ,@proclamations - ;; (define-condition missing-data-source (error) ()) - (require "asdf") - ;; Hide the compile and/or load output unless there are - ;; failures or the debug level is at least 3, as it's verbose - ;; and not usually of interest. - ,(wrap - `(let ((string - (make-array '(0) :element-type 'character - :fill-pointer 0 :adjustable t))) - (handler-case - (with-output-to-string (stream string) - (let ((*error-output* stream) - (*standard-output* stream)) - ,(asdf-requirements-load-form - asdf-requirements))) - (serious-condition (c) - (format - *error-output* - "~&Failed to compile and/or load:~%~A~&~%Compile and/or load output:~%~%~A" - c string) - (uiop:quit 2))) - (when (>= *consfigurator-debug-level* 3) - (format t "~&~A" string)))) - ;; Delete old FASLs. With SBCL they are megabytes in size. - (with-lisp-data-file - (record (merge-pathnames - "consfigurator/fasls" - (ensure-directory-pathname - (or (getenv "XDG_CACHE_HOME") - (strcat (getenv "HOME") "/.cache"))))) - (loop for cell in record - if (file-exists-p (car cell)) - collect cell into accum - else do (ignore-errors (delete-file (cdr cell))) - finally (setq record accum))) - ;; Continue the deployment. - ,(wrap `(%consfigure ',remaining-connections ,*host*))))) - (handler-case - (with-standard-io-syntax - (let ((*allow-printing-passphrases* t)) - ;; need line breaks in between so that packages exist before we - ;; try to have remote Lisp read sexps containing symbols from - ;; those packages - (values - (format nil "~{~A~^~%~}" (mapcar #'prin1-to-string forms)) - forms))) - (print-not-readable (c) - (error "The Lisp printer could not serialise ~A for -transmission to the remote Lisp. - -This is probably because your property application specification and/or static -informational attributes contain values which the Lisp printer does not know -how to print. If ~:*~A is something like a function object then you need to -rework your deployment so that it does not end up in the propspec or -hostattrs; see \"Pitfalls\" in the Consfigurator user manual. - -If ~:*~A is a simple object then you may be able to resolve this by defining -a PRINT-OBJECT method for your class, possibly using -CONSFIGURATOR:DEFINE-PRINT-OBJECT-FOR-STRUCTLIKE." - (print-not-readable-object c)))))))) diff --git a/src/data/local-file.lisp b/src/data/local-file.lisp new file mode 100644 index 0000000..080c0da --- /dev/null +++ b/src/data/local-file.lisp @@ -0,0 +1,39 @@ +;;; 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.data.git-snapshot) +(named-readtables:in-readtable :consfigurator) + +(defmethod register-data-source + ((type (eql :local-file)) &key file version iden1 iden2) + "Provide the contents of a single local file on the machine running the root +Lisp. Register this data source more than once to provide multiple files. +The version of the data provided is either VERSION or the file's last +modification time." + (unless (file-exists-p file) + (missing-data-source "~A does not exist." file)) + (cons (lambda (iden1* iden2*) + (and (string= iden1 iden1*) (string= iden2 iden2*) + (file-exists-p file) + (or version (file-write-date file)))) + (lambda (iden1* iden2*) + (and (string= iden1 iden1*) (string= iden2 iden2*) + (file-exists-p file) + (make-instance 'file-data + :file file + :iden1 iden1 :iden2 iden2 + :version (or version (file-write-date file))))))) diff --git a/src/deployment.lisp b/src/deployment.lisp index fa79e81..fe56a7a 100644 --- a/src/deployment.lisp +++ b/src/deployment.lisp @@ -20,7 +20,21 @@ ;;;; Deployments -(defun %consfigure (connections host) +(defparameter *at-end-functions* nil) + +(defun at-end (function) + "Request that FUNCTION be called at the end of the current (sub)deployment. +Called by property :APPLY and :UNAPPLY subroutines. FUNCTION will be passed a +single argument representing whether or not the deployment made a change. + +Properties which call this are responsible for ensuring that the I/O performed +by FUNCTION is compatible with the connection type. This amounts to the +following requirement: if FUNCTION performs I/O beyond what :POSIX property +:APPLY subroutines are permitted to perform, the property calling AT-END to +register FUNCTION must be declared to be a :LISP property." + (push (ensure-function function) *at-end-functions*)) + +(defun %consfigure (connections host &key (collect-at-end t)) "Consfigurator's primary loop, recursively binding *CONNECTION* and *HOST*. Assumes arguments to connections in CONNECTIONS have been both normalised and @@ -29,7 +43,12 @@ preprocessed." ((apply-*host*-propspec () (let ((propapp (eval-propspec (host-propspec *host*)))) (assert-connection-supports (propapptype propapp)) - (propappapply propapp))) + (if collect-at-end + (let (*at-end-functions*) + (let ((result (propappapply propapp))) + (dolist (function *at-end-functions* result) + (funcall function result)))) + (propappapply propapp)))) (connect (connections) (destructuring-bind ((type . args) . remaining) connections ;; implementations of ESTABLISH-CONNECTION which call @@ -38,7 +57,7 @@ preprocessed." (multiple-value-bind (*connection* return) (apply #'establish-connection type remaining args) (if *connection* - (unwind-protect-in-parent + (unwind-protect (if remaining (connect remaining) (apply-*host*-propspec)) (connection-teardown *connection*)) return))))) @@ -53,7 +72,7 @@ preprocessed." (t (connect '((:local)))))))) -(defun consfigure (propspec-expression) +(defun consfigure (propspec-expression &key collect-at-end) "Immediately preprocess and apply PROPSPEC-EXPRESSION in the context of the current target host and connection. This function is provided for use by specialised property combinators. It should not be used in property @@ -69,7 +88,8 @@ will not be discarded." nil (make-host :hostattrs (hostattrs *host*) :propspec (with-*host*-*consfig* - (make-propspec :propspec propspec-expression))))) + (make-propspec :propspec propspec-expression))) + :collect-at-end collect-at-end)) (defun deploy* (connections host &optional additional-properties) "Execute the deployment which is defined by the pair (CONNECTIONS . HOST), @@ -80,8 +100,9 @@ This is the entry point to Consfigurator's primary loop. Typically users use DEPLOY, DEPLOY-THESE, and the function definitions established by DEFDEPLOY, DEFDEPLOY-THESE, etc., rather than calling this function directly. However, code which programmatically constructs deployments will need to call this." - (%consfigure (preprocess-connections connections) - (union-propspec-into-host host additional-properties))) + (with-deployment-report + (%consfigure (preprocess-connections connections) + (union-propspec-into-host host additional-properties)))) (defun deploy-these* (connections host properties) "Like DEPLOY*, but replace the properties of HOST with PROPERTIES. @@ -91,8 +112,9 @@ properties, plus any set by PROPERTIES. Static informational attributes set by PROPERTIES can override the host's usual static informational attributes, in the same way that later entries in the list of properties specified in DEFHOST forms can override earlier entries (see DEFHOST's docstring)." - (%consfigure (preprocess-connections connections) - (replace-propspec-into-host host properties))) + (with-deployment-report + (%consfigure (preprocess-connections connections) + (replace-propspec-into-host host properties)))) (defun continue-deploy* (connection remaining-connections) "Complete the work of an enclosing call to DEPLOY* or DEPLOY-THESE*. @@ -219,7 +241,8 @@ for testing properties at the REPL. See also EVALS." (run-program '("id") :output :string))) (,hostname (hostname-f)) (,host (or (symbol-value (find-symbol (string-upcase ,hostname))) - (make-host :hostattrs `(:hostname (,,hostname)))))) + (make-host :hostattrs `(:hostname (,,hostname)) + :propspec (make-propspec :systems nil))))) (deploy-these* `((:sudo :as ,(format nil "~A@~A" ,username ,hostname))) ,host @@ -270,7 +293,8 @@ PROPERTIES, like DEPLOY-THESE." (:desc (declare (ignore connections host properties)) "Subdeployment") (:preprocess (list (preprocess-connections connections) - (preprocess-host (replace-propspec-into-host host properties)) + (preprocess-host + (replace-propspec-into-host (ensure-host host) properties)) nil)) (:hostattrs (declare (ignore connections properties)) diff --git a/src/host.lisp b/src/host.lisp index 25decf9..1b6ff8f 100644 --- a/src/host.lisp +++ b/src/host.lisp @@ -54,7 +54,8 @@ (:method ((host host)) host) (:method ((hostname string)) - (make-host :hostattrs `(:hostname (,hostname))))) + (make-host :hostattrs `(:hostname (,hostname)) + :propspec (make-propspec :systems nil)))) (defmethod shallow-copy-host ((host host)) (make-instance (type-of host) @@ -132,9 +133,20 @@ Called by properties which set up such subhosts, like CHROOT:OS-BOOTSTRAPPED." ;; value to have all the hostattrs it would have were PROPSPEC not to be ;; substituted in (make-instance 'unpreprocessed-host - :hostattrs (hostattrs - (preprocess-host (shallow-copy-host host))) - :propspec propspec)) + ;; Drop items of prerequisite data the host usually requires, + ;; as we don't need them if we're not applying its usual + ;; properties. + :hostattrs (remove-from-plist + (hostattrs + (preprocess-host (shallow-copy-host host))) + :data) + :propspec (make-propspec + ;; Add the original PROPSPEC-SYSTEMS so that we + ;; know that all the hostattrs are instantiable. + :systems + (union (propspec-systems propspec) + (propspec-systems (host-propspec host))) + :propspec (propspec-props propspec)))) (defmacro defhost (hostname (&key deploy) &body properties) "Define a host with hostname HOSTNAME and properties PROPERTIES. diff --git a/src/image.lisp b/src/image.lisp new file mode 100644 index 0000000..c3f1884 --- /dev/null +++ b/src/image.lisp @@ -0,0 +1,503 @@ +;;; 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) +(named-readtables:in-readtable :consfigurator) + +;;;; Remote Lisp images + +;;; Remote Lisp images fork right after loading all required ASDF systems. +;;; The parent then enters %CONSFIGURE. Further connection hops of type +;;; FORK-CONNECTION are established in grandchildren (actually +;;; great-grandchildren) such that (i) if establishing those hops requires +;;; calling things like chroot(2), setuid(2) and setns(2), then the parent +;;; doesn't get stuck in those contexts; and (ii) subdeployments executed in +;;; those contexts will not have access to any secrets the parent might have +;;; read into its memory. +;;; +;;; Similar considerations apply to dumping executables. +;;; +;;; Previously we forked the original process right before chrooting, +;;; setuiding, etc., but this failed to ensure (ii), meant that the parent +;;; could not be multithreaded as it might later need to fork, and required us +;;; to take extra steps when using UNWIND-PROTECT to ensure cleanup forms +;;; weren't executed on both sides of any forks, using a specialised macro. +;;; +;;; Right before establishing the FORK-CONNECTION, the grandchild also +;;; recursively sets up infrastructure to request grandchildren for +;;; establishing further connection hops or dumping executables, such that it +;;; too can be multithreaded even if there are sub-subdeployments, etc.. +;;; +;;; We use named pipes for the IPC to minimise implementation-specific code. + +(defparameter *fork-control* nil) + +(defmacro with-fork-request (prerequest request (out err exit) &body forms) + (with-gensyms (input output) + `(progn + (unless (lisp-connection-p) + (failed-change "Forking requires a Lisp-type connection.")) + (unless *fork-control* + (failed-change + "Fork requested but no fork control child; is this the root Lisp?")) + (informat 3 "~&Making grandchild request ~S" ,request) + (with-mkfifos (,input ,output) + ;; We send the path to a named pipe, INPUT, rather than our actual + ;; request. That way we can be confident that what we send into the + ;; (shared) requests pipe will be less than PIPE_BUF (see pipe(7)). + (write-to-mkfifo (cons ,input ,output) *fork-control*) + (with-open-file (,input ,input :direction :output :if-exists :append + :element-type 'character) + (write-to-mkfifo ,prerequest ,input) + (write-to-mkfifo ,request ,input)) + (destructuring-bind (,out ,err ,exit) + (safe-read-file-form ,output :element-type 'character) + ,@forms))))) + +;;; These are the two requests we expect to make of grandchildren: complete +;;; the work of an enclosing call to DEPLOY* or DEPLOY-THESE*, or dump an +;;; image which will evaluate a form. In the former case we always want to +;;; carry over *HOST*, *CONNECTION* and *CONSFIGURATOR-DEBUG-LEVEL*, and in +;;; the latter case we do not carry over any of these by default. + +(defmacro eval-in-grandchild (prerequest request (out err exit) &body forms) + "Evaluate PREREQUEST and REQUEST, both readably printable Lisp forms, in a +grandchild process. PREREQUEST and REQUEST must be evaluable using only +definitions established statically by your consfig, or in one of the ASDF +systems upon which your consfig depends. Then bind OUT, ERR and EXIT to the +stdout, stderr and exit code of that process, respectively, and evaluate +FORMS. + +PREREQUEST will be evaluated before the grandchild calls fork(2) to establish +its own infrastructure for subsequent uses of this macro, and REQUEST after. +Thus, PREREQUEST must not start up any threads." + (flet ((wrap (&rest forms) + ``(let ((*host* ,*host*) + (*connection* ,*connection*) + (*no-data-sources* t) + (*consfigurator-debug-level* ,*consfigurator-debug-level*)) + ,,@forms))) + `(with-fork-request + ,(wrap '`(posix-login-environment + ,(get-connattr :remote-user) ,(get-connattr :remote-home)) + prerequest) + ,(wrap request) (,out ,err ,exit) + ,@forms))) + +(defun dump-consfigurator (filename form) + (umask #o077) + (uiop:register-image-restore-hook (lambda () (eval form)) nil) + (uiop:dump-image filename :executable t)) + +(defun dump-consfigurator-in-grandchild + (filename &optional (form `(let ((*no-data-sources* t) + (*connection* ,*connection*) + (*consfigurator-debug-level* + ,*consfigurator-debug-level*)) + (with-deployment-report + (with-fork-control + (%consfigure nil ,*host*))) + (fresh-line)))) + "Dump an executable image to FILENAME which will evaluate the readably +printable Lisp form FORM, which defaults to one which will execute the current +deployment. FORM must be evaluable using only definitions established +statically by your consfig, or in one of the ASDF systems upon which your +consfig depends. + +Only :LISP property :APPLY subroutines should call this. + +The process which performs the dump will have its umask set to #o077, but +implementation-specific image dumping code might undo this (SBCL, for example, +changes the mode of the file to #o755). You might want to ensure that the +directory containing FILENAME is locked down." + (with-fork-request nil `(dump-consfigurator ,filename ',form) (out err exit) + (declare (ignore out)) + (unless (zerop exit) + (failed-change "~&Failed to dump image; stderr was ~%~%~A" err)))) + +(defprop image-dumped :lisp (&optional filename form (always form)) + "Dump an executable image to FILENAME which will evaluate FORM, which must be +evaluable using only definitions established statically by your consfig, or in +one of the ASDF systems upon which your consfig depends. + +If FILENAME is nil then use ~/.cache/consfigurator/images/latest, and if FORM +is nil then use one which will execute the current deployment. Unless ALWAYS, +skip dumping an executable image when we can detect that the deployment is +already running from FILENAME." + (:desc (if form + (format nil "Dumped image to evaluate ~S" form) + "Dumped image to execute current deployment")) + (:apply + (let ((file (or filename (ensure-directories-exist + (ensure-pathname + (strcat (or (getenv "XDG_CACHE_HOME") + (strcat (getenv "HOME") "/.cache")) + "/consfigurator/images/latest")))))) + (unless (and (not always) + (eql :linux (uiop:operating-system)) + (pathname-equal file (resolve-symlinks "/proc/self/exe"))) + (unless filename + (mrun "chmod" "0700" (pathname-directory-pathname file))) + (if form + (dump-consfigurator-in-grandchild file form) + (dump-consfigurator-in-grandchild file)))) + ;; Return :NO-CHANGE, though we can't detect whether a change was actually + ;; made: it depends on whether the definitions determining the evaluation + ;; of FORM, or the definition of this host established by the consfig, was + ;; or were meaningfully altered since the last deployment which applied + ;; this property with the same arguments. + :no-change)) + +(defmacro with-fork-control (&body forms &aux (fork-control (gensym))) + `(let ((,fork-control (mkfifo))) + (forked-progn child + ;; We use MAPC-OPEN-INPUT-STREAMS because (i) the input streams may + ;; already have been closed if this is a recursive call; (ii) we + ;; don't want to close the output streams in the case of *DEBUG-IO* + ;; and *TERMINAL-IO*; and (iii) there is some ambiguity in the + ;; standard about closing synonym streams; see + ;; <https://bugs.launchpad.net/sbcl/+bug/1904257>. + (loop initially (mapc-open-input-streams + #'close *standard-input* *debug-io* *terminal-io*) + with ,fork-control = (open ,fork-control + :element-type 'character) + for (input . output) = (handler-case (with-safe-io-syntax () + (read ,fork-control)) + (end-of-file () + (close ,fork-control) + (uiop:quit))) + do (mapc-open-output-streams + #'force-output + *standard-output* *error-output* *debug-io* *terminal-io*) + when (zerop (fork)) + do (setsid) + (close ,fork-control) + (handle-fork-request input output) + (uiop:quit)) + (let ((*fork-control* (open ,fork-control + :direction :output :if-exists :append + :element-type 'character))) + ;; Opening named pipes for writing blocks on the other end being + ;; opened for reading, so at this point we know the child has it + ;; open. Then delete the filesystem reference right away in case we + ;; are about to chroot or similar, such that we couldn't do it later. + (delete-file ,fork-control) + (unwind-protect (progn ,@forms) + (close *fork-control*) + (let ((status (nth-value 1 (waitpid child 0)))) + (unless (and (wifexited status) (zerop (wexitstatus status))) + (error "Fork control child did not exit zero.")))))))) + +;; IPC security considerations +;; +;; The grandchild initially shouldn't have anything in memory other than the +;; ASDF systems we've loaded, and a few bits of IPC information like OUT and +;; ERR. The INPUT pipe has mode 0600. So by directly evaluating the first +;; thing we receive all that we're permitting is for a process with the same +;; UID and a sufficiently similar view of the filesystem as us to execute and +;; potentially introspect the consfig. That should not in itself be a +;; security concern, because the consfig should not contain any secrets. +;; +;; The data we get from INPUT is potentially security-sensitive; for example, +;; specifications of onward connection chains might contain sudo passwords +;; (though this would be an unusual way to use Consfigurator). Another writer +;; to the pipe might insert a reference to the #. reader macro which causes us +;; to reveal what we get from INPUT, or another reader from the pipe might be +;; able to get some of INPUT. Again, however, only an attacker who has +;; already managed to change to our UID or otherwise circumvent normal POSIX +;; permissions could do any of this. We might consider encrypting the data we +;; send down the named pipes using a pre-shared key. +;; +;; An alternative to forking would be to dump an image which we reexecute each +;; time we would have created another grandchild; then we can send the request +;; on stdin. That would mean writing ~75MB out to disk every time we start up +;; a remote Lisp image and every time we establish a further FORK-CONNECTION, +;; however. If we took this approach, then we'd have implementation-specific +;; dumping code but the code to reinvoke the dumped images would be fully +;; portable. In place of :SETUID connections we might runuser(1) the image, +;; which would have the advantage of getting us a fresh PAM session, although +;; it would mean making the executable readable by the target user. +(defun handle-fork-request (input output &aux (out (mkfifo)) (err (mkfifo))) + (forked-progn child + (with-backtrace-and-exit-code + ;; Capture stdout and leave it to the request submitter to decide what + ;; to do with it, because perhaps the requester has rebound + ;; *STANDARD-OUTPUT*, e.g. in an enclosing call to APPLY-AND-PRINT. + ;; + ;; Similarly for stderr. In particular, we discard the stderr from + ;; remote Lisp images unless they fail due to an unhandled error, so + ;; if we just leave stderr uncaptured then it might be the case that + ;; the user will never see it. Also see commit 9e7ae48590. + (with-open-file (*standard-output* out :direction :output + :if-exists :append + :element-type 'character) + (with-open-file (*error-output* err :direction :output + :if-exists :append + :element-type 'character) + ;; Try to ensure that the new fork control child does not end up + ;; with the actual request in its memory. + (with-open-file (input input :element-type 'character) + (flet ((eval-input () + (eval + (with-standard-io-syntax (slurp-stream-form input))))) + (eval-input) + (with-fork-control (eval-input))))))) + (unwind-protect + (with-open-file (out out :element-type 'character) + (with-open-file (err err :element-type 'character) + (let ((status (nth-value 1 (waitpid child 0)))) + (unless (wifexited status) + (failed-change + "~&Grandchild process did not exit normally, status #x~(~4,'0X~)." + status)) + (with-open-file (output output :direction :output + :if-exists :append + :element-type 'character) + (write-to-mkfifo (list (slurp-stream-string out) + (slurp-stream-string err) + (wexitstatus status)) + output))))) + (delete-file out) (delete-file err)))) + +(defclass asdf-requirements () + ((asdf-requirements :type list :initform nil)) + (:documentation + "A list of requirements as returned by certain calls to +ASDF:REQUIRED-COMPONENTS. +Elements are instances of ASDF:SYSTEM and/or ASDF:REQUIRE-SYSTEM.")) + +(defun asdf-requirements-for-host-and-features (remote-lisp-features) + "Make an instance of ASDF-REQUIREMENTS for starting up a remote Lisp image in +which *FEATURES* has the value of REMOTE-LISP-FEATURES, based on the Lisp +systems required by the host currently being deployed. + +Called by connection types which start up remote Lisp images." + (let ((*features* remote-lisp-features) + (requirements (make-instance 'asdf-requirements))) + (with-slots (asdf-requirements) requirements + (dolist (system (propspec-systems (host-propspec *host*))) + (dolist (requirement + ;; This call to ASDF:REQUIRED-COMPONENTS is based on one in + ;; the definition of the ASDF:COMPONENT-DEPENDS-ON generic + ;; for ((o gather-operation) (s system)). We use + ;; ASDF:COMPILE-OP as the :KEEP-OPERATION because + ;; ASDF::BASIC-COMPILE-OP is not exported, so this won't work + ;; for certain exotic systems. See the comment in ASDF source. + ;; + ;; TODO Can we detect when this won't work and fail, possibly + ;; falling back to ASDF:MONOLITHIC-CONCATENATE-SOURCE-OP? + (asdf:required-components + (asdf:find-system system) + :other-systems t :component-type 'asdf:system + :keep-component 'asdf:system :goal-operation 'asdf:load-op + :keep-operation 'asdf:compile-op)) + ;; Handle UIOP specially because it comes with ASDF. + (unless (string= "uiop" (asdf:component-name requirement)) + ;; What we really want instead of PUSHNEW here is a proper + ;; topological sort. + (pushnew requirement asdf-requirements)))) + (nreversef asdf-requirements)) + requirements)) + +(defgeneric request-asdf-requirements (asdf-requirements) + (:documentation + "Request that all Lisp systems required to fulfill ASDF-REQUIREMENTS be +uploaded to the remote cache of the currently established connection. + +Called by connection types which start up remote Lisp images.") + (:method ((asdf-requirements asdf-requirements)) + (loop for requirement in (slot-value asdf-requirements 'asdf-requirements) + for type = (type-of requirement) + when (and (subtypep type 'asdf:system) + (not (subtypep type 'asdf:require-system))) + do (require-data "--lisp-system" + (asdf:component-name requirement))))) + +(defgeneric asdf-requirements-load-form (asdf-requirements) + (:documentation + "Return form to (compile and) load each of the Lisp systems specified in +ASDF-REQUIREMENTS, after having uploaded those Lisp systems using +UPLOAD-ALL-PREREQUISITE-DATA.") + (:method ((asdf-requirements asdf-requirements)) + ;; As soon as we recompile something, we have to recompile everything else + ;; following it in the list, because macro definitions may have changed. + `(let* (recompile + (file (merge-pathnames "consfigurator/fasls" + (ensure-directory-pathname + (or (getenv "XDG_CACHE_HOME") + (strcat (getenv "HOME") "/.cache"))))) + (record (with-open-file (stream file :if-does-not-exist nil) + (and stream (safe-read-from-string + (slurp-stream-string stream)))))) + (unwind-protect + (progn + ,@(loop + with table = (get-connattr 'cached-data) + for requirement + in (slot-value asdf-requirements 'asdf-requirements) + for name = (asdf:component-name requirement) + collect + (etypecase requirement + (asdf:require-system `(require ,name)) + (asdf:system + (let ((source + (gethash (cons "--lisp-system" name) table))) + (unless source + (error "Somehow Lisp system ~A was not uploaded." + name)) + ;; Using COMPILE-FILE-PATHNAME* like this has the + ;; advantage that, for example, SBCL will save the FASL + ;; somewhere from which only the same version of SBCL + ;; will try to load FASLs. + `(let ((fasl (compile-file-pathname* ,source))) + (if (and (file-exists-p fasl) (not recompile)) + (load fasl) + ;; The concatenated source of at least + ;; Alexandria won't compile unless it's loaded + ;; first. This means we compile every library + ;; that's changed since the last deploy twice, + ;; which is not ideal. One possible improvement + ;; would be to maintain a list of systems known + ;; not to have this problem, such as + ;; Consfigurator, and switch the order of the + ;; LOAD and COMPILE-FILE* here for those. + (let ((pair (assoc ,source record))) + (load ,source) + (or (compile-file* ,source) + (error "Failed to compile ~S" ,source)) + (if pair + (rplacd pair fasl) + (setq record (acons ,source fasl record))) + (setq recompile t))))))))) + (with-open-file (stream file :direction :output :if-exists :supersede) + (with-standard-io-syntax + (prin1 record stream))))))) + +(defgeneric continue-deploy*-program (remaining-connections asdf-requirements) + (:documentation + "Return a program to complete the work of an enclosing call to DEPLOY*. + +Implementations of ESTABLISH-CONNECTION which start up remote Lisp images call +this function, instead of CONTINUE-DEPLOY*, and use the result to instruct the +newly started image. + +Will query the remote cache for paths to Lisp systems, so a connection to the +host which will run the Lisp image must already be established. + +The program returned is a single string consisting of a number of sexps +separated by newlines. Each sexp must be evaluated by the remote Lisp image +before the following sexp is offered to its reader, on standard input.") + (:method (remaining-connections (asdf-requirements asdf-requirements)) + (unless (eq (type-of *host*) 'preprocessed-host) + (error "Attempt to send unpreprocessed host to remote Lisp. + +Preprocessing must occur in the root Lisp.")) + (flet ((wrap (form) + ;; We used to bind a handler here to invoke SKIP-DATA-SOURCES + ;; upon MISSING-DATA-SOURCE, which means that remote Lisp images + ;; were allowed to try querying data sources. Now we just bind + ;; *NO-DATA-SOURCES* to t here. While some data sources make + ;; sense in remote Lisp images, others might make arbitrary + ;; network connections or read out of other users' homedirs + ;; (e.g. if you are using (:SUDO :SBCL), the remote Lisp might + ;; try to read your ~/.gnupg, or on another host, someone else's + ;; ~/.gnupg who has the same username as you), which are usually + ;; undesirable. So at least until some cool use case comes + ;; along, just require all data source queries to occur in the + ;; root Lisp. + `(let ((*no-data-sources* t) + (*consfigurator-debug-level* ,*consfigurator-debug-level*)) + ,form))) + (let* ((intern-forms + (loop for (export . name) + in '((nil . "*NO-DATA-SOURCES*") + (t . "*CONSFIGURATOR-DEBUG-LEVEL*")) + for intern-form + = `(intern ,name (find-package "CONSFIGURATOR")) + if export collect + `(export ,intern-form (find-package "CONSFIGURATOR")) + else collect intern-form)) + (proclamations `((proclaim '(special *no-data-sources*)) + (proclaim '(special *consfigurator-debug-level*)))) + (forms + `((make-package "CONSFIGURATOR") + ,@intern-forms + ,@proclamations + ;; (define-condition missing-data-source (error) ()) + (require "asdf") + ;; Hide the compile and/or load output unless there are + ;; failures or the debug level is at least 3, as it's verbose + ;; and not usually of interest. + ,(wrap + `(let ((string + (make-array '(0) :element-type 'character + :fill-pointer 0 :adjustable t))) + (handler-case + (with-output-to-string (stream string) + (let ((*error-output* stream) + (*standard-output* stream)) + ,(asdf-requirements-load-form + asdf-requirements))) + (serious-condition (c) + (format + *error-output* + "~&Failed to compile and/or load:~%~A~&~%Compile and/or load output:~%~%~A" + c string) + (uiop:quit 3))) + (when (>= *consfigurator-debug-level* 3) + (format t "~&~A" string)))) + ;; Delete old FASLs. With SBCL they are megabytes in size. + (with-lisp-data-file + (record (merge-pathnames + "consfigurator/fasls" + (ensure-directory-pathname + (or (getenv "XDG_CACHE_HOME") + (strcat (getenv "HOME") "/.cache"))))) + (loop for cell in record + if (file-exists-p (car cell)) + collect cell into accum + else do (ignore-errors (delete-file (cdr cell))) + finally (setq record accum))) + ;; Continue the deployment. The READ indirection is to try + ;; to ensure that the fork control child does not end up with + ;; information about the deployment in its memory. + ,(wrap `(with-backtrace-and-exit-code + (with-fork-control (eval (read))))) + (%consfigure ',remaining-connections ,*host*)))) + (handler-case + (with-standard-io-syntax + (let ((*allow-printing-passphrases* t)) + ;; need line breaks in between so that packages exist before we + ;; try to have remote Lisp read sexps containing symbols from + ;; those packages + (values + (format nil "~{~A~^~%~}" (mapcar #'prin1-to-string forms)) + forms))) + (print-not-readable (c) + (error "The Lisp printer could not serialise ~A for +transmission to the remote Lisp. + +This is probably because your property application specification and/or static +informational attributes contain values which the Lisp printer does not know +how to print. If ~:*~A is something like a function object then you need to +rework your deployment so that it does not end up in the propspec or +hostattrs; see \"Pitfalls\" in the Consfigurator user manual. + +If ~:*~A is a simple object then you may be able to resolve this by defining +a PRINT-OBJECT method for your class, possibly using +CONSFIGURATOR:DEFINE-PRINT-OBJECT-FOR-STRUCTLIKE." + (print-not-readable-object c)))))))) diff --git a/src/package.lisp b/src/package.lisp index b4c0b76..5cde365 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -8,6 +8,7 @@ #:string-prefix-p #:string-suffix-p #:split-string + #:first-char #:last-char #:run-program #:read-file-string @@ -18,10 +19,12 @@ #:unix-namestring #:pathname-directory-pathname #:pathname-parent-directory-pathname + #:resolve-symlinks #:with-temporary-file #:ensure-directory-pathname #:ensure-pathname #:enough-pathname + #:pathname-equal #:subpathp #:getenv #:subdirectories @@ -29,7 +32,11 @@ #:file-exists-p #:directory-exists-p #:with-current-directory + #:delete-empty-directory #:delete-directory-tree + #:with-safe-io-syntax + #:slurp-stream-form + #:safe-read-file-form #:safe-read-from-string #:compile-file* #:compile-file-pathname*) @@ -38,6 +45,7 @@ #:string-prefix-p #:string-suffix-p #:split-string + #:first-char #:last-char #:run-program #:read-file-string @@ -48,10 +56,12 @@ #:unix-namestring #:pathname-directory-pathname #:pathname-parent-directory-pathname + #:resolve-symlinks #:with-temporary-file #:ensure-directory-pathname #:ensure-pathname #:enough-pathname + #:pathname-equal #:subpathp #:getenv #:subdirectories @@ -59,7 +69,11 @@ #:file-exists-p #:directory-exists-p #:with-current-directory + #:delete-empty-directory #:delete-directory-tree + #:with-safe-io-syntax + #:slurp-stream-form + #:safe-read-file-form #:safe-read-from-string #:compile-file* #:compile-file-pathname* @@ -76,6 +90,8 @@ #:plist-to-cmd-args #:with-local-temporary-directory #:pathname-file + #:directory-contents + #:ensure-trailing-slash #:drop-trailing-slash #:quote-nonselfeval #:define-print-object-for-structlike @@ -84,6 +100,9 @@ #:escape-sh-token #:escape-sh-command #:defpackage-consfig + #:lambda-ignoring-args + #:parse-cidr + #:system #:*consfigurator-debug-level* #:with-indented-inform @@ -98,8 +117,8 @@ #:string->filename #:filename->string - #:unwind-protect-in-parent - #:cancel-unwind-protect-in-parent-cleanup + #:with-backtrace-and-exit-code + #:return-exit #:posix-login-environment ;; connection.lisp @@ -127,7 +146,10 @@ #:runlines #:test #:remote-exists-p - #:remote-file-mode-and-size + #:remote-file-stats + #:remote-last-reboot + #:remote-consfigurator-cache-pathname + #:mountpointp #:delete-remote-trees #:readfile #:writefile @@ -138,7 +160,9 @@ #:propattrs #:propunapply #:collapse-types + #:collapse-propapp-types #:propapptype + #:propappargs #:propappdesc #:propappattrs #:propappcheck @@ -164,9 +188,15 @@ #:maybe-writefile-string #:call-with-os #:with-change-if-changes-file + #:with-change-if-changes-files #:with-change-if-changes-file-content #:with-change-if-changes-file-content-or-mode + #:ptype + #:plambda + #:papply + #:punapply + ;; propspec.lisp #:in-consfig #:propspec-systems @@ -185,8 +215,10 @@ #:unapply #:desc #:on-change + #:on-apply-change #:as #:with-flagfile + #:with-unapply ;; host.lisp #:host @@ -204,6 +236,7 @@ #:with-replace-hostattrs ;; deployment.lisp + #:at-end #:consfigure #:defdeploy #:defdeploy-these @@ -243,6 +276,7 @@ #:get-remote-cached-prerequisite-data #:get-local-cached-prerequisite-data #:get-highest-local-cached-prerequisite-data + #:get-remote-data-cache-dir #:try-register-data-source #:register-data-source @@ -257,6 +291,11 @@ #:passphrase #:make-passphrase #:get-data-protected-string + + ;; image.lisp + #:eval-in-grandchild + #:dump-consfigurator-in-grandchild + #:image-dumped #:asdf-requirements-for-host-and-features #:request-asdf-requirements #:continue-deploy*-program)) @@ -270,14 +309,18 @@ (:local-nicknames (#:re #:cl-ppcre)) (:export #:map-file-lines #:has-content + #:exists-with-content #:contains-lines #:lacks-lines #:has-mode + #:has-ownership #:does-not-exist + #:directory-does-not-exist #:data-uploaded #:host-data-uploaded #:secret-uploaded #:host-secret-uploaded + #:data-cache-purged #:contains-conf-equals #:contains-conf-space #:contains-conf-tab @@ -307,6 +350,7 @@ #:debian-stable #:debian-testing #:debian-unstable + #:debian-experimental #:debian-suite #:debian-architecture #:typecase @@ -321,6 +365,11 @@ (:export #:contained #:when-contained)) +(defpackage :consfigurator.property.periodic + (:use #:cl #:consfigurator) + (:local-nicknames (#:file #:consfigurator.property.file)) + (:export #:at-most)) + (defpackage :consfigurator.property.mount (:use #:cl #:alexandria #:consfigurator) (:local-nicknames (#:os #:consfigurator.property.os) @@ -328,7 +377,11 @@ (#:file #:consfigurator.property.file)) (:export #:mounted #:unmounted-below - #:unmounted-below-and-removed)) + #:unmounted-below-and-removed + #:all-mounts + #:*standard-linux-vfs* + #:*linux-efivars-vfs* + #:assert-devtmpfs-udev-/dev)) (defpackage :consfigurator.property.service (:use #:cl #:alexandria #:consfigurator) @@ -336,6 +389,8 @@ (#:file #:consfigurator.property.file)) (:export #:no-services #:running + #:restarted + #:reloaded #:without-starting-services)) (defpackage :consfigurator.property.apt @@ -346,22 +401,31 @@ (#:os #:consfigurator.property.os) (#:service #:consfigurator.property.service)) (:export #:installed + #:installed-minimally #:removed #:reconfigured #:service-installed-running #:all-configured #:updated + #:upgraded + #:autoremoved #:periodic-updates #:unattended-upgrades #:mirror - #:uses-parent-mirror + #:uses-parent-mirrors #:proxy #:uses-parent-proxy #:uses-local-cacher + #:get-mirrors #:standard-sources.list + #:additional-sources #:cache-cleaned + #:trusts-key #:all-installed-p - #:none-installed-p)) + #:none-installed-p + #:suites-available-pinned + #:pinned + #:no-pdiffs)) (defpackage :consfigurator.connection.sbcl (:use #:cl #:alexandria #:consfigurator) @@ -370,9 +434,11 @@ (defpackage :consfigurator.property.user (:use #:cl #:consfigurator) - (:local-nicknames (#:file #:consfigurator.property.file)) + (:local-nicknames (#:file #:consfigurator.property.file) + (#:os #:consfigurator.property.os)) (:export #:has-account #:has-groups + #:has-desktop-groups #:has-login-shell #:has-enabled-password #:passwd-entry)) @@ -383,6 +449,7 @@ (#:apt #:consfigurator.property.apt) (#:os #:consfigurator.property.os) (#:container #:consfigurator.property.container) + (#:mount #:consfigurator.property.mount) (#:file #:consfigurator.property.file)) (:shadow #:deploys #:deploys. #:deploys-these #:deploys-these.) (:export #:deploys @@ -394,21 +461,11 @@ #:os-bootstrapped #:os-bootstrapped.)) -(defpackage :consfigurator.property.live-build - (:use #:cl #:alexandria #:consfigurator) - (:local-nicknames (#:apt #:consfigurator.property.apt) - (#:os #:consfigurator.property.os) - (#:file #:consfigurator.property.file) - (#:mount #:consfigurator.property.mount) - (#:chroot #:consfigurator.property.chroot)) - (:export #:installed - #:image-built - #:image-built.)) - (defpackage :consfigurator.property.disk (:use #:cl #:alexandria #:consfigurator) (:local-nicknames (#:re #:cl-ppcre) (#:chroot #:consfigurator.property.chroot) + (#:cmd #:consfigurator.property.cmd) (#:file #:consfigurator.property.file) (#:os #:consfigurator.property.os) (#:apt #:consfigurator.property.apt)) @@ -460,6 +517,8 @@ #:has-volumes #:caches-cleaned #:raw-image-built-for + #:debian-live-iso-built + #:debian-live-iso-built. #:host-volumes-created #:host-logical-volumes-exist @@ -485,19 +544,28 @@ (defpackage :consfigurator.property.gnupg (:use #:cl #:consfigurator) - (:export #:public-key-imported)) + (:local-nicknames (#:re #:cl-ppcre)) + (:export #:public-key-imported + #:secret-key-imported)) (defpackage :consfigurator.property.git (:use #:cl #:consfigurator) - (:local-nicknames (#:file #:consfigurator.property.file)) - (:export #:snapshot-extracted)) + (:local-nicknames (#:os #:consfigurator.property.os) + (#:file #:consfigurator.property.file) + (#:apt #:consfigurator.property.apt)) + (:export #:installed + #:snapshot-extracted + #:cloned + #:pulled + #:repo-configured)) (defpackage :consfigurator.property.sshd (:use #:cl #:consfigurator) (:local-nicknames (#:re #:cl-ppcre) (#:os #:consfigurator.property.os) (#:file #:consfigurator.property.file) - (#:apt #:consfigurator.property.apt)) + (#:apt #:consfigurator.property.apt) + (#:service #:consfigurator.property.service)) (:export #:installed #:configured #:no-passwords @@ -510,6 +578,7 @@ (:local-nicknames (#:file #:consfigurator.property.file) (#:sshd #:consfigurator.property.sshd)) (:export #:authorized-keys + #:has-user-key #:known-host #:globally-known-host #:parent-is-globally-known-host)) @@ -524,17 +593,27 @@ (:export #:available #:selected-for)) +(defpackage :consfigurator.property.reboot + (:use #:cl #:consfigurator) + (:local-nicknames (#:container #:consfigurator.property.container)) + (:export #:rebooted-at-end)) + (defpackage :consfigurator.property.installer (:use #:cl #:alexandria #:consfigurator #:consfigurator.property.disk) (:local-nicknames (#:os #:consfigurator.property.os) + (#:cmd #:consfigurator.property.cmd) (#:file #:consfigurator.property.file) (#:chroot #:consfigurator.property.chroot) + (#:mount #:consfigurator.property.mount) (#:fstab #:consfigurator.property.fstab) + (#:reboot #:consfigurator.property.reboot) (#:crypttab #:consfigurator.property.crypttab)) (:export #:install-bootloader-propspec #:install-bootloader-binaries-propspec #:chroot-installed-to-volumes - #:bootloader-binaries-installed)) + #:bootloader-binaries-installed + #:bootloaders-installed + #:cleanly-installed-once)) (defpackage :consfigurator.property.grub (:use #:cl #:alexandria #:consfigurator @@ -556,7 +635,7 @@ #:u-boot-installed-rockchip)) (defpackage :consfigurator.property.hostname - (:use #:cl #:consfigurator) + (:use #:cl #:alexandria #:consfigurator) (:local-nicknames (#:cmd #:consfigurator.property.cmd) (#:container #:consfigurator.property.container) (#:file #:consfigurator.property.file)) @@ -566,10 +645,15 @@ #:search-configured)) (defpackage :consfigurator.property.network - (:use #:cl #:consfigurator) + (:use #:cl #:alexandria #:consfigurator) (:local-nicknames (#:os #:consfigurator.property.os) (#:file #:consfigurator.property.file)) - (:export #:static)) + (:export #:aliases + #:ipv4 + #:ipv6 + #:clean-/etc/network/interfaces + #:static + #:preserve-static-once)) (defpackage :consfigurator.property.libvirt (:use #:cl #:alexandria #:consfigurator) @@ -587,7 +671,138 @@ #:kvm-boots-chroot-for #:kvm-boots-chroot-for. #:kvm-boots-chroot - #:kvm-boots-chroot.)) + #:kvm-boots-chroot. + #:virsh-get-columns)) + +(defpackage :consfigurator.property.ccache + (:use #:cl #:consfigurator) + (:local-nicknames (#:os #:consfigurator.property.os) + (#:file #:consfigurator.property.file) + (#:apt #:consfigurator.property.apt)) + (:export #:installed + #:has-limits + #:group-cache)) + +(defpackage :consfigurator.property.schroot + (:use #:cl #:consfigurator) + (:local-nicknames (#:os #:consfigurator.property.os) + (#:file #:consfigurator.property.file) + (#:apt #:consfigurator.property.apt)) + (:export #:installed + #:uses-overlays + #:overlays-in-tmpfs)) + +(defpackage :consfigurator.property.sbuild + (:use #:cl #:alexandria #:consfigurator) + (:local-nicknames (#:os #:consfigurator.property.os) + (#:file #:consfigurator.property.file) + (#:chroot #:consfigurator.property.chroot) + (#:user #:consfigurator.property.user) + (#:apt #:consfigurator.property.apt) + (#:ccache #:consfigurator.property.ccache) + (#:schroot #:consfigurator.property.schroot) + (#:periodic #:consfigurator.property.periodic)) + (:export #:installed + #:usable-by + #:built + #:built. + #:standard-debian-schroot)) + +(defpackage :consfigurator.property.postfix + (:use #:cl #:alexandria #:consfigurator) + (:local-nicknames (#:cmd #:consfigurator.property.cmd) + (#:service #:consfigurator.property.service) + (#:apt #:consfigurator.property.apt) + (#:os #:consfigurator.property.os) + (#:file #:consfigurator.property.file)) + (:export #:installed + #:reloaded + #:main-configured + #:mapped-file)) + +(defpackage :consfigurator.property.cron + (:use #:cl #:consfigurator) + (:local-nicknames (#:re #:cl-ppcre) + (#:service #:consfigurator.property.service) + (#:apt #:consfigurator.property.apt) + (#:os #:consfigurator.property.os) + (#:file #:consfigurator.property.file)) + (:export #:system-job + #:nice-system-job + #:runs-consfigurator + #:user-crontab)) + +(defpackage :consfigurator.property.lets-encrypt + (:use #:cl #:alexandria #:consfigurator) + (:local-nicknames (#:apt #:consfigurator.property.apt) + (#:os #:consfigurator.property.os)) + (:export #:installed + #:agree-tos + #:certificate-obtained + #:fullchain-for + #:chain-for + #:certificate-for + #:privkey-for)) + +(defpackage :consfigurator.property.apache + (:use #:cl #:consfigurator) + (:local-nicknames (#:service #:consfigurator.property.service) + (#:apt #:consfigurator.property.apt) + (#:os #:consfigurator.property.os) + (#:file #:consfigurator.property.file) + (#:network #:consfigurator.property.network) + (#:lets-encrypt #:consfigurator.property.lets-encrypt)) + (:export #:installed + #:reloaded + #:mod-enabled + #:conf-enabled + #:conf-available + #:site-enabled + #:site-available + #:https-vhost)) + +(defpackage :consfigurator.property.systemd + (:use #:cl #:consfigurator) + (:export #:started + #:stopped + #:enabled + #:disabled + #:masked)) + +(defpackage :consfigurator.property.firewalld + (:use #:cl #:alexandria #:consfigurator) + (:local-nicknames (#:cmd #:consfigurator.property.cmd) + (#:file #:consfigurator.property.file) + (#:apt #:consfigurator.property.apt) + (#:os #:consfigurator.property.os)) + (:export #:installed + #:service + #:policy + #:zone + #:has-zone + #:zone-target + #:default-route-zoned-once + #:zone-has-interface + #:zone-has-service + #:zone-masquerade + #:zone-rich-rule + #:zone-direct-rule + #:default-zone)) + +(defpackage :consfigurator.property.timezone + (:use #:cl #:consfigurator) + (:local-nicknames (#:file #:consfigurator.property.file) + (#:apt #:consfigurator.property.apt) + (#:os #:consfigurator.property.os)) + (:export #:configured + #:configured-from-parent)) + +(defpackage :consfigurator.property.swap + (:use #:cl #:consfigurator) + (:local-nicknames (#:cmd #:consfigurator.property.cmd) + (#:fstab #:consfigurator.property.fstab) + (#:os #:consfigurator.property.os)) + (:export #:has-swap-file)) (defpackage :consfigurator.connection.local (:use #:cl #:consfigurator #:alexandria) @@ -639,7 +854,8 @@ #:consfigurator.connection.rehome #:consfigurator.connection.shell-wrap #:cffi) - (:local-nicknames (#:disk #:consfigurator.property.disk))) + (:local-nicknames (#:disk #:consfigurator.property.disk) + (#:mount #:consfigurator.property.mount))) (defpackage :consfigurator.connection.setuid (:use #:cl @@ -666,3 +882,6 @@ (defpackage :consfigurator.data.ssh-askpass (:use #:cl #:alexandria #:consfigurator) (:local-nicknames (#:re #:cl-ppcre))) + +(defpackage :consfigurator.data.local-file + (:use #:cl #:consfigurator)) diff --git a/src/property.lisp b/src/property.lisp index 8b38db9..9e517f2 100644 --- a/src/property.lisp +++ b/src/property.lisp @@ -46,7 +46,7 @@ (when apply (setf (get sym 'papply) apply)) (when unapply - (setf (get sym 'unapply) unapply)) + (setf (get sym 'punapply) unapply)) sym) (defun isprop (prop) @@ -63,9 +63,18 @@ (get (car propapp) 'ptype) :posix)) +(defun propappargs (propapp) + (if (and (listp (cadr propapp)) (member :orig-args (cadr propapp))) + (getf (cadr propapp) :orig-args) + (cdr propapp))) + (defun collapse-types (&rest lists) (if (member :posix (flatten lists)) :posix :lisp)) +(defun collapse-propapp-types (&rest lists) + (if (member :posix (mapcan (curry #'mapcar #'propapptype) lists)) + :posix :lisp)) + (defun propdesc (prop &rest args) (apply (get prop 'desc #'noop) args)) @@ -109,8 +118,8 @@ (defun propunapply (prop &rest args) (with-some-errors-are-failed-change (let ((check (get prop 'check)) - (apply (get prop 'apply)) - (unapply (get prop 'unapply))) + (apply (get prop 'papply)) + (unapply (get prop 'punapply))) ;; Only fail if there's no :UNAPPLY when there is an :APPLY, because ;; that is the case in which we can't do what was requested. If there ;; is no :APPLY then we can infer that there is nothing on the host to @@ -133,22 +142,10 @@ (defvar *known-properties* nil "All properties whose definitions have been loaded.") -(defvar *known-property-macrolets* nil - "Macro definitions for all known properties as used in MAP-PROPSPEC-PROPAPPS. - -This variable exists just to avoid consing these forms over and over again; -see MAP-PROPSPEC-PROPAPPS for how they are used.") - (defun record-known-property (psym) (unless (get psym 'isprop) (setf (get psym 'isprop) t) - (push psym *known-properties*) - (push `(,psym (&rest args) - (let ((gensym (gensym))) - (push (list* gensym ',psym args) - *replaced-propapps*) - gensym)) - *known-property-macrolets*))) + (push psym *known-properties*))) (defun dump-properties-for-emacs (from to) (let ((put-forms @@ -280,7 +277,8 @@ parsing FORMSV and pushing SETPROP keyword argument pairs to plist SLOTSV." (with-gensyms (name body declarations) `(defmacro ,mname (,name ,typev ,lambdav &body ,body) ,@(and mdocstring `(,mdocstring)) - (let ((,slotsv (list :type ,typev :lambda `',,lambdav))) + (let ((programmatic-warning t) + (,slotsv (list :type ,typev :lambda `',,lambdav))) (multiple-value-bind (,formsv ,declarations) (parse-body ,body :documentation t) (when (> (length ,declarations) 1) @@ -306,17 +304,20 @@ parsing FORMSV and pushing SETPROP keyword argument pairs to plist SLOTSV." ;; Properties with :HOSTATTRS subroutines which set ;; new hostattrs should not be used programmatically ;; in this way, so issue a warning. - ,@(and (getf ,slotsv :hostattrs) - '((programmatic-apply-hostattrs))) + ,@(and programmatic-warning + (getf ,slotsv :hostattrs) + `((warn 'programmatic-apply-hostattrs + :property ',,name))) (consfigure (cons ',,name args))))))))))))) -(define-condition programmatic-apply-hostattrs (simple-warning) ()) - -(defun programmatic-apply-hostattrs () - (warn 'programmatic-apply-hostattrs - :format-control - "Calling property which has :HOSTATTRS subroutine programmatically. -Use DEFPROPLIST/DEFPROPSPEC to avoid trouble.")) +(define-condition programmatic-apply-hostattrs (warning) + ((property :initarg :property)) + (:report (lambda (condition stream) + (format stream "Calling property ~S, +which has :HOSTATTRS subroutine, programmatically. Use DEFPROPLIST/DEFPROPSPEC +to avoid trouble. Use IGNORING-HOSTATTRS to muffle this warning if +~:*~S does not push any new hostattrs." + (slot-value condition 'property))))) (defmacro ignoring-hostattrs (form) "Where FORM is a programmatic call to a property which has a :HOSTATTRS @@ -365,13 +366,14 @@ subroutines at the right time. If the first element of the body is a string, it will be considered a docstring for the resulting property. If the first element of the body after any such string is a list beginning with :DESC, the remainder will be used as -the :DESC subroutine for the resulting property, like DEFPROP. Supplying a -:CHECK subroutine in the same way is also supported. Otherwise, the body -defines a function of the arguments specified by the lambda list which returns -the property application specification expression to be evaluated and applied. -It should be a pure function aside from retrieving hostattrs (as set by other -properties applied to the hosts to which the resulting property is applied, -not as set by the properties in the returned propspec). +the :DESC subroutine for the resulting property, like DEFPROP. Supplying +:CHECK and :HOSTATTRS subroutines in the same way is also supported. +Otherwise, the body defines a function of the arguments specified by the +lambda list which returns the property application specification expression to +be evaluated and applied. It should be a pure function aside from retrieving +hostattrs (as set by other properties applied to the hosts to which the +resulting property is applied, not as set by the properties in the returned +propspec). Macro property combinators should be usable in the normal way in the body, but some other macros commonly used in DEFHOST and DEFPROPLIST forms will not work @@ -403,15 +405,19 @@ You can usually use DEFPROPLIST instead of DEFPROPSPEC, which see." (loop while (and (listp (car forms)) (keywordp (caar forms))) do (setf (getf slots (caar forms)) `(lambda (plist) - (destructuring-bind ,lambda (getf plist :orig-args) - ,@(and (member (caar forms) '(:desc :hostattrs)) - `((declare - (ignorable - ,@(ordinary-ll-variable-names - lambda :include-supplied-p t))))) - ,@(cdr (pop forms)))))) + (with-*host*-*consfig* + (destructuring-bind ,lambda (getf plist :orig-args) + ,@(and (member (caar forms) '(:desc :hostattrs)) + `((declare + (ignorable + ,@(ordinary-ll-variable-names + lambda :include-supplied-p t))))) + ,@(cdr (pop forms))))))) + (unless (getf slots :hostattrs) + (setq programmatic-warning nil)) (setf (getf slots :hostattrs) `(lambda (plist) + ,@(cddr (getf slots :hostattrs)) (let ((propspec (with-*host*-*consfig* (preprocess-propspec (make-propspec @@ -430,7 +436,7 @@ If the first element of PROPERTIES is a string, it will be considered a docstring for the resulting property. If the first element of PROPERTIES after any such string is a list beginning with :DESC, the remainder will be used as the :DESC subroutine for the resulting property, like DEFPROP. -Supplying a :CHECK subroutine in the same way is also supported. +Supplying :CHECK and :HOSTATTRS subroutines in the same way is also supported. Otherwise, the body should not contain any references to variables other than those in LAMBDA. LAMBDA is an ordinary lambda list, so you can use &AUX @@ -450,8 +456,9 @@ other than constant values and propapps to property combinators." (loop for remaining on properties for car = (car remaining) if (or (stringp car) - (and (listp car) (member (car car) - '(:desc :check declare)))) + (and (listp car) + (member (car car) + '(:desc :check :hostattrs declare)))) collect car into begin else return (nreverse @@ -470,7 +477,8 @@ install an apt package but the host is FreeBSD.") "HOST value currently being preprocessed. Used by GET-HOSTATTRS to break infinite loops.") -(defun get-hostattrs (k &optional (host *host*) &aux (host (ensure-host host))) +(defun get-hostattrs + (k &optional host &aux (host (ensure-host (or host *host*)))) "Retrieve the list of static informational attributes of type KEY. Called by property :HOSTATTRS, :APPLY and :UNAPPLY subroutines." @@ -544,7 +552,7 @@ apply or unapply properties.") PATH already has the specified CONTENT and MODE." (if (and (remote-exists-p path) (multiple-value-bind (existing-mode existing-size) - (remote-file-mode-and-size path) + (remote-file-stats path) (and (or (not mode-supplied-p) (= mode existing-mode)) (and (>= (* 4 (length content)) existing-size) (string= (readfile path) content))))) @@ -570,11 +578,14 @@ PATH already has the specified CONTENT and MODE." ;; this is a safe parse of ls(1) output given its POSIX specification (defun ls-cksum (file) - (let ((ls (ignore-errors - (split-string (run :env '(:LOCALE "C") "ls" "-dlL" file)))) - (cksum (ignore-errors (cksum file)))) - (when (and ls cksum) - (list* (car ls) cksum (subseq ls 2 8))))) + (when-let* ((ls (ignore-errors + (words (run :env '(:LC_ALL "C") "ls" "-dlL" file)))) + (ls-car (car ls)) + (ls-end (subseq ls 2 8))) + (if (char= #\d (elt ls-car 0)) + (cons ls-car ls-end) + (let ((cksum (ignore-errors (cksum file)))) + (and cksum (list* ls-car cksum ls-end)))))) (defmacro with-change-if-changes-file ((file) &body forms) "Execute FORMS and yield :NO-CHANGE if FILE does not change. @@ -586,7 +597,21 @@ changes in properties which will change the file but not the output of `ls (with-gensyms (before) `(let* ((,before (ls-cksum ,file)) (result (progn ,@forms))) - (if (and ,before (equal ,before (ls-cksum ,file))) + (if (or (eql result :no-change) + (and ,before (equal ,before (ls-cksum ,file)))) + :no-change result)))) + +(defmacro with-change-if-changes-files ((&rest files) &body forms) + "Execute FORMS and yield :NO-CHANGE if none of FILES change. +See WITH-CHANGE-IF-CHANGES-FILE docstring regarding the sense of 'change'." + (with-gensyms (filesg beforeg) + `(let* ((,filesg (list ,@files)) + (,beforeg (mapcar #'ls-cksum ,filesg)) + (result (progn ,@forms))) + (if (or (eql result :no-change) + (loop for file in ,filesg and before in ,beforeg + always before + always (equal before (ls-cksum file)))) :no-change result)))) (defmacro with-change-if-changes-file-content ((file) &body forms) @@ -594,7 +619,8 @@ changes in properties which will change the file but not the output of `ls (with-gensyms (before) `(let* ((,before (ignore-errors (cksum ,file))) (result (progn ,@forms))) - (if (and ,before (eql ,before (cksum ,file))) + (if (or (eql result :no-change) + (and ,before (eql ,before (cksum ,file)))) :no-change result)))) (defmacro with-change-if-changes-file-content-or-mode ((file) &body forms) @@ -603,8 +629,10 @@ afterwards." (with-gensyms (before) `(let* ((,before (ls-cksum ,file)) (result (progn ,@forms))) - (let ((after (ls-cksum ,file))) - (if (and ,before - (string= (car ,before) (car after) :start1 1 :start2 1) - (eql (cadr ,before) (cadr after))) - :no-change result))))) + (if (equal result :no-change) + :no-change + (let ((after (ls-cksum ,file))) + (if (and ,before + (string= (car ,before) (car after) :start1 1 :start2 1) + (eql (cadr ,before) (cadr after))) + :no-change result)))))) diff --git a/src/property/apache.lisp b/src/property/apache.lisp new file mode 100644 index 0000000..5cd2564 --- /dev/null +++ b/src/property/apache.lisp @@ -0,0 +1,146 @@ +;;; 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.apache) +(named-readtables:in-readtable :consfigurator) + +(defproplist installed :posix () + (:desc "Apache installed") + (os:etypecase + (debianlike (apt:installed "apache2")))) + +(defproplist reloaded :posix () + (:desc "Apache reloaded") + (service:reloaded "apache2")) + +(defprop %mod-enabled :posix (name) + (:hostattrs (os:required 'os:debianlike)) + (:check (zerop (mrun :for-exit "a2query" "-q" "-m" name))) + (:apply (mrun "a2enmod" "--quiet" name)) + (:unapply (mrun "a2dismod" "--quiet" name))) + +(defproplist mod-enabled :posix (name) + (:desc #?"Apache module ${name} enabled") + (installed) + (on-change (%mod-enabled name) + (reloaded))) + +(defproplist conf-available :posix (name config) + (:desc #?"Apache conf ${name} available") + (file:exists-with-content + (merge-pathnames (strcat name ".conf") #P"/etc/apache2/conf-available/") + config)) + +(defprop %conf-enabled :posix (name) + (:hostattrs (os:required 'os:debianlike)) + (:check (zerop (mrun :for-exit "a2query" "-q" "-c" name))) + (:apply (mrun "a2enconf" "--quiet" name)) + (:unapply (mrun "a2disconf" "--quiet" name))) + +(defpropspec conf-enabled :posix (name &optional config) + (:desc #?"Apache configuration ${name} enabled") + `(eseqprops + (installed) + (on-change ,(if config + `(eseqprops (conf-available ,name ,config) + (%conf-enabled ,name)) + `(%conf-enabled ,name)) + (reloaded)))) + +(defproplist site-available :posix (domain config) + (:desc #?"Apache site ${domain} available") + (file:exists-with-content + (merge-pathnames (strcat domain ".conf") #P"/etc/apache2/sites-available/") + config)) + +(defprop %site-enabled :posix (domain) + (:hostattrs (os:required 'os:debianlike)) + (:check (zerop (mrun :for-exit "a2query" "-q" "-s" domain))) + (:apply (mrun "a2ensite" "--quiet" domain)) + (:unapply (mrun "a2dissite" "--quiet" domain))) + +(defpropspec site-enabled :posix (domain &optional config) + (:desc #?"Apache site ${domain} enabled") + `(eseqprops + (installed) + (on-change ,(if config + `(eseqprops (site-available ,domain ,config) + (%site-enabled ,domain)) + `(%site-enabled ,domain)) + (reloaded)))) + +(defpropspec https-vhost :posix + (domain htdocs agree-tos + &key aliases additional-config additional-config-https) + "Configure an HTTPS Apache virtual host using a Let's Encrypt certificate. +ALIASES are the values for ServerAlias entries; these must be specified +separately for proper handling of the redirects from HTTP to HTTPS. Use of +this property implies agreement with the Let's Encrypt Subscriber Agreement; +AGREE-TOS is an instance of LETS-ENCRYPT:AGREE-TOS. ADDITIONAL-CONFIG are +additional lines to add to the Apache configuration for both the HTTP and +HTTPS virtual hosts; ADDITIONAL-CONFIG-HTTPS are additional lines to be added +only to the HTTPS virtual host. + +Unapplying removes the Apache site config but leaves the certificate behind." + `(with-unapply + (network:aliases ,domain ,@aliases) + (mod-enabled "ssl") + (conf-enabled "stapling" + ("SSLStaplingCache shmcb:/tmp/stapling_cache(128000)")) + (mod-enabled "rewrite") + (site-enabled + ,domain + ,(let ((initial `(,(strcat "DocumentRoot " htdocs) + "ErrorLog /var/log/apache2/error.log" + "LogLevel warn" + "CustomLog /var/log/apache2/access.log combined" + "ServerSignature on"))) + `(,(strcat "<IfFile " (unix-namestring + (lets-encrypt:certificate-for domain)) + ">") + "<VirtualHost *:443>" + ,(strcat "ServerName " domain ":443") + ,@(loop for alias in aliases collect (strcat "ServerAlias " alias)) + ,@initial + "SSLEngine on" + ,(strcat "SSLCertificateFile " + (unix-namestring (lets-encrypt:certificate-for domain))) + ,(strcat "SSLCertificateKeyFile " + (unix-namestring (lets-encrypt:privkey-for domain))) + ,(strcat "SSLCertificateChainFile " + (unix-namestring (lets-encrypt:chain-for domain))) + "SSLUseStapling on" + ,@additional-config + ,@additional-config-https + "</VirtualHost>" "</IfFile>" + ,@(loop for name in (cons domain aliases) append + `("" + "<VirtualHost *:80>" + ,(strcat "ServerName " name ":80") + ,@initial + "RewriteEngine On" + "RewriteRule ^/.well-known/(.*) - [L]" + ;; redirect everything else to https + ,(strcat "RewriteRule ^/(.*) https://" name "/$1 [L,R,NE]") + ,@additional-config + "</VirtualHost>"))))) + (on-change (lets-encrypt:certificate-obtained + ,agree-tos ,htdocs ,domain ,@aliases) + (reloaded)) + :unapply + (unapply (site-enabled ,domain)) + (unapply (site-available ,domain "")))) diff --git a/src/property/apt.lisp b/src/property/apt.lisp index 12fae2e..cd0e938 100644 --- a/src/property/apt.lisp +++ b/src/property/apt.lisp @@ -1,6 +1,6 @@ ;;; Consfigurator -- Lisp declarative configuration management system -;;; Copyright (C) 2021 Sean Whitton <spwhitton@spwhitton.name> +;;; Copyright (C) 2017, 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 @@ -27,7 +27,7 @@ (updated) ,form))) -(defmacro with-changes-dpkg-status (&rest forms) +(defmacro with-changes-dpkg-status (&body forms) `(with-change-if-changes-file-content ("/var/lib/dpkg/status") ,@forms)) (define-constant +sections+ '("main" "contrib" "non-free") :test #'equal) @@ -43,14 +43,21 @@ "Ensure all of the apt packages PACKAGES are installed." (:desc #?"apt installed @{packages}") (:preprocess (flatten packages)) - (:hostattrs - (declare (ignore packages)) - (os:required 'os:debianlike)) - (:check - (all-installed-p packages)) + (:hostattrs (os:required 'os:debianlike)) + (:check (all-installed-p packages)) (:apply (with-maybe-update (apt-get :inform "-y" "install" packages)))) +(defprop installed-minimally :posix (&rest packages) + "Ensure all of the apt packages PACKAGES are installed, without recommends." + (:desc #?"apt installed @{packages}") + (:preprocess (flatten packages)) + (:hostattrs (os:required 'os:debianlike)) + (:check (all-installed-p packages)) + (:apply + (with-maybe-update + (apt-get :inform "-y" "--no-install-recommends" "install" packages)))) + (defprop removed :posix (&rest packages) "Ensure all of the apt packages PACKAGES are removed." (:desc #?"apt removed @{packages}") @@ -74,7 +81,8 @@ Typically used with the ON-CHANGE combinator." (:apply (assert-euid-root) (run - :input (loop for triple in triples collect #?"${package} @{triple}") + :input (unlines + (loop for triple in triples collect #?"${package} @{triple}")) "debconf-set-selections") (run :env +noninteractive-env+ "dpkg-reconfigure" "-fnone" package))) @@ -106,6 +114,18 @@ E.g. (APT:SERVICE-INSTALLED-RUNNING \"apache2\")." (cmd:single :env +noninteractive-env+ :inform "apt-get" "update" "--allow-releaseinfo-change")))) +(defprop upgraded :posix () + (:desc "apt upgraded") + (:hostattrs (os:required 'os:debianlike)) + (:apply (with-changes-dpkg-status + (apt-get :inform "-y" "dist-upgrade")))) + +(defprop autoremoved :posix () + (:desc "apt removed automatically installed packages") + (:hostattrs (os:required 'os:debianlike)) + (:apply (with-changes-dpkg-status + (apt-get :inform "-y" "autoremove")))) + (defprop periodic-updates :posix () "Enable periodically updating the apt indexes and downloading new versions of packages. Does not do any automatic upgrades." @@ -127,26 +147,30 @@ EOF)) Note that in its default configuration on Debian, unattended-upgrades will only upgrade Debian stable." (:desc "Unattended upgrades enabled") - (on-change (installed "unattended-upgrades") - (reconfigured - "unattended-upgrades" - '("unattended-upgrades/enable_auto_updates" "boolean" "true"))) - (service:running "cron") - (desc "unattended-upgrades will mail root" - (file:contains-lines "/etc/apt/apt.conf.d/50unattended-upgrades" - "Unattended-Upgrade::Mail \"root\";")) - ;; work around Debian bug #812380 - (file:does-not-exist "/etc/apt/apt.conf.d/50unattended-upgrades.ucf-dist")) + (with-unapply + (on-change (installed "unattended-upgrades") + (reconfigured + "unattended-upgrades" + '("unattended-upgrades/enable_auto_updates" "boolean" "true"))) + (service:running "cron") + (desc "unattended-upgrades will mail root" + (file:contains-lines "/etc/apt/apt.conf.d/50unattended-upgrades" + "Unattended-Upgrade::Mail \"root\";")) + ;; work around Debian bug #812380 + (file:does-not-exist "/etc/apt/apt.conf.d/50unattended-upgrades.ucf-dist") + :unapply (removed "unattended-upgrades"))) (defprop mirror :posix (uri) (:desc #?"${uri} apt mirror selected") (:hostattrs (pushnew-hostattrs :apt.mirror uri))) -(defproplist uses-parent-mirror :posix () - (:desc #?"Uses parent's apt mirror") - (mirror (or (get-parent-hostattrs-car :apt.mirror) - (failed-change "Parent has no apt mirror")))) +(defpropspec uses-parent-mirrors :posix () + (:desc #?"Uses parent's apt mirror(s), if any") + (let ((mirrors (get-parent-hostattrs :apt-mirror))) + (and mirrors + `(eseqprops + ,@(loop for mirror in mirrors collect `(mirror ,mirror)))))) (defprop proxy :posix (uri) (:desc #?"${uri} apt proxy selected") @@ -172,25 +196,41 @@ only upgrade Debian stable." (defmethod get-default-mirrors ((os os:debian)) '("http://deb.debian.org/debian")) -(defprop standard-sources.list :posix () +(defproplist standard-sources.list :posix () (:desc "Standard sources.list") - (:apply - (file:has-content "/etc/apt/sources.list" - (call-with-os #'standard-sources-for)))) + (file:has-content "/etc/apt/sources.list" + (call-with-os #'standard-sources-for))) (defmethod standard-sources-for ((os os:debian)) (let* ((suite (os:debian-suite os)) (archive (mapcar (lambda (m) (list* m suite +sections+)) (get-mirrors))) + (updates (and (subtypep (type-of os) 'os:debian-stable) + (mapcar (lambda (m) + (list* m #?"${suite}-updates" +sections+)) + (get-mirrors)))) + (backports (and (subtypep (type-of os) 'os:debian-stable) + (mapcar (lambda (m) + (list* m #?"${suite}-backports" +sections+)) + (get-mirrors)))) (security-suite (if (memstring= suite '("stretch" "jessie" "buster")) #?"${suite}/updates" #?"${suite}-security")) - (security (and (not (subtypep (type-of os) 'os:debian-unstable)) + (security (and (or (subtypep (type-of os) 'os:debian-stable) + (subtypep (type-of os) 'os:debian-testing)) (list (list* "http://security.debian.org/debian-security" - security-suite +sections+))))) + security-suite +sections+))))) (mapcan (lambda (l) (list #?"deb @{l}" #?"deb-src @{l}")) - (nconc archive security)))) + (nconc archive updates backports security)))) + +(defproplist additional-sources :posix (basename content) + "Add additional apt source lines to a file in /etc/apt/sources.list.d named +after BASENAME. CONTENT is as the content argument to FILE:HAS-CONTENT." + (declare (indent 1)) + (on-change (file:exists-with-content + #?"/etc/apt/sources.list.d/${basename}.list" content) + (updated))) (defprop cache-cleaned :posix () "Empty apt's cache to recover disk space." @@ -198,6 +238,113 @@ only upgrade Debian stable." (:hostattrs (os:required 'os:debianlike)) (:apply (apt-get "clean") :no-change)) +(defproplist trusts-key :posix + (fingerprint &optional (basename (remove #\Space fingerprint)) + &aux (file #?"/etc/apt/trusted.gpg.d/${basename}.asc")) + "Have apt trust the PGP key identified by FINGERPRINT to sign apt archives." + (:desc #?"apt trusts PGP public key ${fingerprint}") + (with-unapply + (file:data-uploaded "--pgp-pubkey" (remove #\Space fingerprint) file) + :unapply (file:does-not-exist file))) + +(defproplist no-pdiffs :posix () + "Disable the use of PDiffs for machines with high bandwidth connections." + (file:exists-with-content "/etc/apt/apt.conf.d/20pdiffs" + '("Acquire::PDiffs \"false\";"))) + + +;;;; Pinning + +(defmethod suite-pin ((os os:debian-stable)) + (strcat "n=" (os:debian-suite os))) + +(defmethod suite-pin ((os os:debian)) + (strcat "a=" (os:debian-suite os))) + +(defmethod suite-pin-block ((pref string) (os os:debian) pin-priority) + `("Explanation: This file added by Consfigurator" + ,(strcat "Package: " pref) + ,(strcat "Pin: release " (suite-pin os)) + ,(format nil "Pin-Priority: ~D" pin-priority))) + +(defpropspec suites-available-pinned :posix (&rest pairs) + "Where PAIRS is a list of even length of alternating instances of OS:DEBIAN +and apt pin priorities, add an apt source for the instance of OS:DEBIAN and +pin that suite to a given pin value (see apt_preferences(5)). Unapply to drop +the source and unpin the suite. + +If the OS:DEBIAN is the host's OS, the suite is pinned, but no source is +added. That apt source should already be available, or you can use a property +like APT:STANDARD-SOURCES.LIST." + (:desc (loop for (os pin) on pairs by #'cddr + for suite = (os:debian-suite os) + collect #?{Debian "${suite}" pinned, priority ${pin}} + into accum + finally (return (format nil "~{~A~^; ~}" accum)))) + (:hostattrs (os:required 'os:debian)) + `(eseqprops + ,@(loop for (os pin) on pairs by #'cddr + for suite = (os:debian-suite os) + do (check-type pin integer) + collect `(file:exists-with-content + ,#?"/etc/apt/preferences.d/20${suite}.pref" + ,(suite-pin-block "*" os pin)) + unless (and + (subtypep (type-of (get-hostattrs-car :os)) 'os:debian) + (string= suite (os:debian-suite (get-hostattrs-car :os)))) + ;; Unless we are pinning a backports suite, filter out any + ;; backports sources that were added by STANDARD-SOURCES-FOR. + ;; Probably don't want those to be pinned to the same value. + collect `(additional-sources + ,suite ,(if (string-suffix-p suite "-backports") + (standard-sources-for os) + (loop for line in (standard-sources-for os) + unless (search "-backports" line) + collect line)))))) + +(defpropspec pinned :posix (preferences &rest pairs) + "Pins a list of packages, package wildcards and/or regular expressions, +PREFERENCES, to a list of suites and corresponding pin priorities. Unapply to +unpin. PAIRS is a list of even length of alternating instances of OS:DEBIAN +and apt pin priorities. + +Each package, package wildcard or regular expression will be pinned to all of +the specified suites. Each of PREFERENCES is the name of a package, a glob to +match the names of packages, or a regexp surrounded by slashes to match the +names of packages. See apt_preferences(5), \"Regular expressions and glob(7) +syntax\". + +Note that this will have no effect unless there is an apt source for each of +the suites. One way to add an apt source is APT:SUITES-AVAILABLE-PINNED. + +For example, to obtain Emacs Lisp addon packages not present in your stable +release of Debian from testing, falling back to sid if they're not available +in testing, you could use: + + (os:debian-stable \"bullseye\" :amd64) + (apt:suites-available-pinned (os:debian-testing) -10 + (os:debian-unstable) -10) + (apt:pinned '(\"elpa-*\") + (os:debian-testing) 100 + (os:debian-unstable) 50)" + (:desc (loop for (os pin) on pairs by #'cddr + for suite = (os:debian-suite os) + collect #?{Debian "${suite}", priority ${pin}} into accum + finally (return (format nil "~{~A~^, ~} pinned to ~{~A~^; ~}" + preferences accum)))) + (:hostattrs (os:required 'os:debian)) + `(eseqprops + ,@(loop for preference in preferences + collect (list + 'file:exists-with-content + (strcat "/etc/apt/preferences.d/10consfig_" + (string->filename preference) + ".pref") + (nbutlast + (loop for (os pin) on pairs by #'cddr + nconc (suite-pin-block preference os pin) + collect "")))))) + ;;;; Reports on installation status diff --git a/src/property/ccache.lisp b/src/property/ccache.lisp new file mode 100644 index 0000000..79be9cd --- /dev/null +++ b/src/property/ccache.lisp @@ -0,0 +1,62 @@ +;;; 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.ccache) +(named-readtables:in-readtable :consfigurator) + +(defproplist installed :posix () + (:desc "ccache installed") + (os:etypecase + (debianlike (apt:installed "ccache")))) + +(defprop has-limits :posix (cache + &key (max-size nil max-size-supplied-p) + (max-files nil max-files-supplied-p)) + "Set limits on a given ccache. +See ccache(1) for the format of MAX-SIZE." + (:desc (format nil "~A has max size ~D & max files ~D" + cache max-size max-files)) + (:apply + (installed) + (with-change-if-changes-file-content + ((merge-pathnames "ccache.conf" (ensure-directory-pathname cache))) + ;; Let ccache(1) handle editing and deduplicating the config file, etc. + (mrun "ccache" :env `(:CCACHE_DIR ,cache) + (and max-size-supplied-p + (strcat "--max-size=" (or max-size "0"))) + (and max-files-supplied-p + (strcat "--max-files=" (or max-files "0"))))))) + +(defpropspec group-cache :posix + (group &key (max-size nil max-size-supplied-p) + (max-files nil max-files-supplied-p) + &aux (dir (ensure-directory-pathname + (strcat "/var/cache/ccache-" group)))) + "Configures a ccache in /var/cache for a group." + (:desc #?"ccache for group ${group} exists") + `(with-unapply + (installed) + (file:directory-exists ,dir) + (file:has-mode ,dir #o2775) + (file:has-ownership ,dir :user "root" :group ,group) + ,@(and (or max-size-supplied-p max-files-supplied-p) + `((has-limits ,dir + ,@(and max-size-supplied-p + `(:max-size ,max-size)) + ,@(and max-files-supplied-p + `(:max-files ,max-files))))) + :unapply (file:directory-does-not-exist ,dir))) diff --git a/src/property/chroot.lisp b/src/property/chroot.lisp index e92bed8..ecf7698 100644 --- a/src/property/chroot.lisp +++ b/src/property/chroot.lisp @@ -26,26 +26,58 @@ (if (test "-d" (merge-pathnames "debootstrap/" (ensure-directory-pathname root))) (progn (delete-remote-trees root) nil) - (remote-exists-p (merge-pathnames "usr/lib/os-release" root)))) + (remote-exists-p (chroot-pathname "/usr/lib/os-release" root)))) (:apply - (let* ((os (get-hostattrs-car :os host)) + (destructuring-bind + (&key (apt.proxy (get-hostattrs-car :apt.proxy host)) + (apt.mirror (get-hostattrs-car :apt.mirror host)) + &allow-other-keys + &aux (os (get-hostattrs-car :os host)) (args (list "debootstrap" - (plist-to-cmd-args options) + (plist-to-cmd-args + (remove-from-plist options :apt.proxy :apt.mirror)) (strcat "--arch=" (os:debian-architecture os)) (os:debian-suite os) root))) - (when-let ((proxy (get-hostattrs-car :apt.proxy))) - (setq args (list* :env (list :http_proxy proxy) args))) - (when-let ((mirror (get-hostattrs-car :apt.mirror))) - (nconcf args (list mirror))) + options + + ;; In the case where the chroot arch is not equal to the host arch, we + ;; could execute arch-test(1) here to confirm the architecture is + ;; executable by the running kernel; we'd add arch-test alongside + ;; qemu-user-static in %OS-BOOTSTRAPPER-INSTALLED. Or possibly we only + ;; try to execute arch-test(1) when we find it's already on PATH. + + (when apt.proxy + (setq args (list* :env (list :http_proxy apt.proxy) args))) + (when apt.mirror + (nconcf args (list apt.mirror))) (apply #'run args)))) +(defprop %debootstrap-manually-installed :posix () + (:check (zerop (mrun :for-exit "command" "-v" "debootstrap"))) + (:apply + (failed-change "Don't know how to install debootstrap(8) manually."))) + (defpropspec %os-bootstrapper-installed :posix (host) - (:desc (declare (ignore host)) "OS bootstrapper installed") - `(os:host-etypecase ,host - (debian - (os:etypecase - (debianlike (apt:installed "debootstrap" "qemu-user-static")))))) + (:desc "OS bootstrapper installed") + (let ((host (preprocess-host host))) + `(os:host-etypecase ,host + (debian + ;; Have %DEBOOTSTRAP-MANUALLY-INSTALLED like this to enable installing + ;; Debian on arbitrary unixes, where Consfigurator doesn't know how to + ;; install packages, but the user has manually ensured that + ;; debootstrap(8) is on PATH. However, we don't have such an escape + ;; hatch for the case where the architectures do not match because + ;; ensuring that debootstrap(8) will be able to bootstrap a foreign + ;; arch is more involved. + (os:typecase + (debianlike (apt:installed "debootstrap")) + (t (%debootstrap-manually-installed))) + ,@(and (not (call-with-os + #'os:supports-arch-p + (os:linux-architecture (get-hostattrs-car :os host)))) + '((os:etypecase + (debianlike (apt:installed "qemu-user-static"))))))))) (defpropspec %os-bootstrapped :posix (options root host) "Bootstrap OS into ROOT, e.g. with debootstrap(1)." @@ -80,7 +112,8 @@ starting services in the chroot, and set up access to parent hostattrs." (:desc #?"Subdeployment of ${root}") (consfigurator:deploys `((:chroot :into ,root)) - (%make-child-host (replace-propspec-into-host host properties)))) + (%make-child-host + (replace-propspec-into-host (ensure-host host) properties)))) (defproplist os-bootstrapped-for :lisp (options root host &optional additional-properties @@ -93,9 +126,11 @@ OPTIONS is a plist of values to pass to the OS-specific bootstrapping property." (:desc (declare (ignore options)) #?"Built chroot for ${(get-hostname child-host*)} @ ${root}") - (%os-bootstrapper-installed child-host*) - (%os-bootstrapped options root child-host*) - (consfigurator:deploys `((:chroot :into ,root)) child-host)) + (with-unapply + (%os-bootstrapper-installed child-host*) + (%os-bootstrapped options root child-host*) + (consfigurator:deploys `((:chroot :into ,root)) child-host) + :unapply (mount:unmounted-below-and-removed root))) (defproplist os-bootstrapped :lisp (options root properties) "Bootstrap an OS into ROOT and apply PROPERTIES. diff --git a/src/property/cmd.lisp b/src/property/cmd.lisp index 39cc8dd..1f46b60 100644 --- a/src/property/cmd.lisp +++ b/src/property/cmd.lisp @@ -18,6 +18,8 @@ (in-package :consfigurator.property.cmd) (named-readtables:in-readtable :consfigurator) +;; The name of this property comes from the idea that we might want to add a +;; property in this package to run a user-supplied shell script. (defprop single :posix (&rest args) "A property which can be applied by running a single shell command. ARGS is either a single string specifying a shell-escaped command, or number of @@ -27,4 +29,9 @@ strings which will be shell-escaped and then concatenated. Keyword argument :ENV is a plist of environment variables to be set when running the command, using env(1)." - (:apply (apply #'run args))) + (:desc (loop for arg in args + if (stringp arg) + collect (escape-sh-token arg) into accum + else collect (prin1-to-string arg) into accum + finally (return (format nil "~{~A~^ ~}" accum)))) + (:apply (apply #'mrun args))) diff --git a/src/property/container.lisp b/src/property/container.lisp index a99bbb6..454cd75 100644 --- a/src/property/container.lisp +++ b/src/property/container.lisp @@ -58,13 +58,10 @@ container type." ,form :no-change)))) (:retprop :type (propapptype propapp) - :hostattrs (lambda (&rest ignore) - (declare (ignore ignore)) + :hostattrs (lambda-ignoring-args (propappattrs propapp)) - :apply (lambda (&rest ignore) - (declare (ignore ignore)) + :apply (lambda-ignoring-args (check-contained (propappapply propapp))) - :unapply (lambda (&rest ignore) - (declare (ignore ignore)) + :unapply (lambda-ignoring-args (check-contained (propappunapply propapp))) :args (cdr propapp)))) diff --git a/src/property/cron.lisp b/src/property/cron.lisp new file mode 100644 index 0000000..a071cd1 --- /dev/null +++ b/src/property/cron.lisp @@ -0,0 +1,143 @@ +;;; 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.cron) +(named-readtables:in-readtable :consfigurator) + +;;; A number of techniques here are from Propellor's Cron properties module. + +(defpropspec system-job :posix (desc when user shell-command) + "Installs a cronjob running SHELL-COMMAND as USER to /etc/cron.*. +DESC must be unique, as it will be used as a filename for a script. WHEN is +either :DAILY, WEEKLY, :MONTHLY or a string formatted according to crontab(5), +e.g. \"0 3 * * *\". + +The output of the cronjob will be mailed only if the job exits nonzero." + (:desc #?"Cronned ${desc}") + (:hostattrs + ;; /etc/cron.* is Debian-specific. Also, we rely on runuser(1), which is + ;; Linux-specific. This is done because su(1) for non-interactive usage + ;; has some pitfalls. + (os:required 'os:debianlike)) + (let* ((times (not (keywordp when))) + (dir (ensure-directory-pathname + (strcat "/etc/cron." (if (keywordp when) + (string-downcase (symbol-name when)) + "d")))) + (job (merge-pathnames (string->filename desc) dir)) + (script (merge-pathnames (strcat (string->filename desc) "_cronjob") + #P"/usr/local/bin/")) + (script* (escape-sh-token (unix-namestring script)))) + `(eseqprops + (apt:service-installed-running "cron") + (apt:installed "moreutils") + (file:has-content ,job + ,`(,@(and (not times) '("#!/bin/sh" "" "set -e" "")) + "SHELL=/bin/sh" + "PATH=/usr/local/sbin:/usr/local/bin:/sbin:/bin:/usr/sbin:/usr/bin" + "" + ,@`(,(if times + #?"${when} ${user} chronic ${script*}" + (if (string= user "root") + (format nil "chronic ~A" script*) + (format nil "chronic runuser -u ~A -c ~A" + user script*))))) + ,@(and (not times) '(:mode #o755))) + ;; Using a separate script makes for more readable e-mail subject lines, + ;; and also makes it easy to do a manual run of the job. + (file:has-content ,script + ,`("#!/bin/sh" + "" + "set -e" + "" + ;; Use flock(1) to ensure that only one instance of the job is ever + ;; running, no matter how long one run of the job takes. + ,(format nil "flock -n ~A sh -c ~A" + (escape-sh-token (unix-namestring job)) + (escape-sh-token shell-command))) + :mode #o755)))) + +(defproplist nice-system-job :posix (desc when user shell-command) + "Like CRON:SYSTEM-JOB, but run the command niced and ioniced." + (:desc #?"Cronned ${desc}, niced and ioniced") + (system-job desc when user (format nil "nice ionice -c 3 sh -c ~A" + (escape-sh-token shell-command)))) + +(defproplist runs-consfigurator :lisp (when) + "Re-execute the most recent deployment that included an application of this +property, or of IMAGE-DUMPED with no arguments, using CRON:NICE-SYSTEM-JOB. + +This can be useful to ensure that your system remains in a consistent state +between manual deployments, and to ensure the timely application of properties +modified by the PERIODIC:AT-MOST combinator. + +For hosts to which this property is applied, mixing usage of DEPLOY and +DEPLOY-THESE (or HOSTDEPLOY and HOSTDEPLOY-THESE, etc.) can lead to some +inconsistent situations. For example, suppose you + + (hostdeploy foo.example.org (additional-property)) + +and then later + + (hostdeploy-these foo.example.org (unapply (additional-property)). + +As neither CRON:RUNS-CONFIGURATOR nor IMAGE-DUMPED with no arguments was +applied since ADDITIONAL-PROPERTY was unapplied, the executable invoked by the +CRON:RUNS-CONFIGURATOR cronjob will try to apply ADDITIONAL-PROPERTY again. +One straightforward way to reduce the incidence of this sort of problem would +be to refrain from using the ADDITIONAL-PROPERTIES argument to DEPLOY, +HOSTDEPLOY etc." + (image-dumped) + (nice-system-job + "consfigurator" when "root" + "${XDG_CACHE_HOME:-$HOME/.cache}/consfigurator/images/latest")) + +(defprop user-crontab :posix (env &rest jobs) + "Set the contents of the current user's crontab. ENV is like the ENV argument +to RUN/MRUN, except that the environment variables will be set at the top of +the generated crontab. Each of JOBS is a line for the body of the crontab. +In both ENV and JOBS, the string \"$HOME\" is replaced with the remote home +directory." + ;; We set the contents of the whole file rather than providing properties to + ;; specify individual jobs, because then it is straightforward to + ;; incrementally develop jobs without having to unapply old versions first. + (:desc "Crontab populated") + (:apply + (unless (member :path env) + (setq env + (list* + :path + (if (zerop (get-connattr :remote-uid)) + "/usr/local/sbin:/usr/local/bin:/sbin:/bin:/usr/sbin:/usr/bin" + "/usr/local/bin:/bin:/usr/bin") + env))) + (let* ((home (drop-trailing-slash + (unix-namestring (get-connattr :remote-home)))) + (old (runlines :may-fail "crontab" "-l")) + (new + (mapcar + (lambda (line) (re:regex-replace-all #?/\$HOME/ line home)) + (nconc + (list "# Automatically updated by Consfigurator; do not edit" "") + (loop for (k v) on env by #'cddr + collect (strcat (string-upcase (symbol-name k)) "=" v)) + (list "") + jobs)))) + (if (tree-equal old new :test #'string=) + :no-change + (mrun :input (unlines new) + "crontab" "-u" (get-connattr :remote-user) "-"))))) diff --git a/src/property/disk.lisp b/src/property/disk.lisp index c3db619..3fa97ee 100644 --- a/src/property/disk.lisp +++ b/src/property/disk.lisp @@ -721,15 +721,14 @@ MOUNT-BELOW specifies a pathname to prefix to mount points when opening FILESYSTEM volumes. OPENED-VOLUMES specifies a symbol to which a list of all volumes that were opened will be bound, which can be used to do things like populate /etc/fstab and /etc/crypttab. Do not modify this list." - (once-only (mount-below) - (let ((opened-volumes (or opened-volumes (gensym)))) - `(let ((,opened-volumes (open-volumes-and-contents - ,volumes - ,@(and mount-below-supplied-p - `(:mount-below ,mount-below))))) - (unwind-protect (progn ,@forms) - (mrun "sync") - (mapc #'close-volume ,opened-volumes)))))) + (let ((opened-volumes (or opened-volumes (gensym)))) + `(let ((,opened-volumes (open-volumes-and-contents + ,volumes + ,@(and mount-below-supplied-p + `(:mount-below ,mount-below))))) + (unwind-protect (progn ,@forms) + (mrun "sync") + (mapc #'close-volume ,opened-volumes))))) (defmacro with-these-open-volumes ((volumes &key (mount-below nil mount-below-supplied-p)) &body propapps) @@ -751,18 +750,16 @@ must not be modified." (volumes propapp &key (mount-below nil mount-below-supplied-p)) (:retprop :type (propapptype propapp) - :hostattrs (lambda (&rest ignore) - (declare (ignore ignore)) + :hostattrs (lambda-ignoring-args (require-volumes-data volumes) (propappattrs propapp)) :apply - (lambda (&rest ignore) - (declare (ignore ignore)) + (lambda-ignoring-args (with-connattrs (:opened-volumes (apply #'open-volumes-and-contents `(,volumes ,@(and mount-below-supplied-p `(:mount-below ,mount-below))))) - (unwind-protect-in-parent (propappapply propapp) + (unwind-protect (propappapply propapp) (mrun "sync") (mapc #'close-volume (get-connattr :opened-volumes))))) :args (cdr propapp))) @@ -825,6 +822,7 @@ the LVM physical volumes corresponding to those volume groups." (defproplist caches-cleaned :posix () "Clean all caches we know how to clean in preparation for image creation." (:desc "Caches cleaned") + (file:data-cache-purged) (os:typecase (debianlike (apt:cache-cleaned)))) @@ -889,6 +887,10 @@ the LVM physical volumes corresponding to those volume groups." ;; Finally, create the volumes. (create-volumes-and-contents volumes)))) +(defun image-chroot (image-pathname) + (ensure-directory-pathname + (strcat (unix-namestring image-pathname) ".chroot"))) + (defpropspec raw-image-built-for :lisp (options host image-pathname &key rebuild) "Build a raw disk image for HOST at IMAGE-PATHNAME. @@ -914,8 +916,7 @@ Unless REBUILD, the image will not be repartitioned even if the specification of the host's volumes changes, although the contents of the image's filesystems will be incrementally updated when other properties change." (:desc #?"Built image for ${(get-hostname host)} @ ${image-pathname}") - (let ((chroot (ensure-directory-pathname - (strcat (unix-namestring image-pathname) ".chroot"))) + (let ((chroot (image-chroot image-pathname)) (volumes (loop with found @@ -942,6 +943,111 @@ filesystems will be incrementally updated when other properties change." (consfigurator.property.installer:chroot-installed-to-volumes ,host ,chroot ,volumes)))) +(defprop %squashfsed :posix (chroot image &optional (compression "xz")) + (:apply + (file:does-not-exist image) + (with-remote-temporary-file (excludes) + (writefile excludes + (format nil "~@{~&~A~}" "/boot" "/proc" "/dev" "/sys" "/run")) + (run :inform "nice" "mksquashfs" chroot image + "-no-progress" "-comp" compression "-ef" excludes)))) + +;; Based on live-wrapper, and some help from this guide: +;; <https://willhaley.com/blog/custom-debian-live-environment/> +(defpropspec debian-live-iso-built :lisp (options image-pathname properties) + "Build a Debian Live hybrid ISO at IMAGE-PATHNAME for a host with properties +PROPERTIES, which should specify, at a minimum, the operating system for the +live system. OPTIONS is a plist of keyword parameters: + + - :CHROOT-OPTIONS -- passed on to CHROOT:OS-BOOTSTRAPPED-FOR, which see. + +Currently only BIOS boot is implemented." + (:desc #?"Debian Live ISO built @ ${image-pathname}") + (destructuring-bind + (&key chroot-options + &aux (chroot (image-chroot image-pathname)) + (iso-root (ensure-directory-pathname + (strcat (unix-namestring image-pathname) ".cd"))) + (isolinux (merge-pathnames "isolinux/" iso-root)) + (squashfs (merge-pathnames "live/filesystem.squashfs" iso-root)) + (host (make-host + :hostattrs '(:hostname ("debian")) + :propspec + (append-propspecs + properties + (make-propspec + :propspec + '(eseqprops + (apt:installed "initramfs-tools" "linux-image-amd64" + "live-boot" "task-laptop" "libnss-myhostname" + "syslinux-common" "isolinux") + (caches-cleaned)))))) + (host-arch (os:linux-architecture (get-hostattrs-car :os host)))) + options + (unless (member host-arch '(:amd64)) + (inapplicable-property + "Architecture ~A of live host not supported." host-arch)) + `(eseqprops + (apt:installed "squashfs-tools" "xorriso") + (file:directory-exists ,isolinux) + (file:containing-directory-exists ,squashfs) + (on-change (chroot:os-bootstrapped-for ,chroot-options ,chroot ,host) + + (%squashfsed ,chroot ,squashfs) + + ;; Copy the chroot's versions of bootloader binaries. + (file:is-copy-of ,(merge-pathnames "isolinux.bin" isolinux) + ,(chroot-pathname "/usr/lib/ISOLINUX/isolinux.bin" + chroot)) + ,@(loop for basename in '("ldlinux" "libcom32" "vesamenu" "libutil" + "libutil" "libmenu" "libgpl" "hdt") + for file = (strcat basename ".c32") + collect + `(file:is-copy-of + ,(merge-pathnames file isolinux) + ,(chroot-pathname + (merge-pathnames file "/usr/lib/syslinux/modules/bios/") + chroot))) + + ;; Copy the targets of the symlinks in the root of the chroot. + (file:is-copy-of ,(merge-pathnames "live/vmlinuz" iso-root) + ,(merge-pathnames "vmlinuz" chroot)) + (file:is-copy-of ,(merge-pathnames "live/initrd.img" iso-root) + ,(merge-pathnames "initrd.img" chroot)) + + (file:exists-with-content ,(merge-pathnames "isolinux.cfg" isolinux) + ("UI vesamenu.c32" + "" + "MENU TITLE Live Boot Menu" + "DEFAULT linux" + "TIMEOUT 600" + "MENU RESOLUTION 640 480" + "" + "LABEL linux" + " MENU LABEL Debian Live [BIOS/ISOLINUX]" + " MENU DEFAULT" + " KERNEL /live/vmlinuz" + " APPEND initrd=/live/initrd.img boot=live" + "" + "LABEL linux" + " MENU LABEL Debian Live [BIOS/ISOLINUX] (nomodeset)" + " MENU DEFAULT" + " KERNEL /live/vmlinuz" + " APPEND initrd=/live/initrd.img boot=live nomodeset")) + + (cmd:single + :inform + "xorriso" "-as" "mkisofs" "-iso-level" "3" "-o" ,image-pathname + "-full-iso9660-filenames" "-volid" "DEBIAN_LIVE" + "-isohybrid-mbr" ,(chroot-pathname "/usr/lib/ISOLINUX/isohdpfx.bin" + chroot) + + "-eltorito-boot" "isolinux/isolinux.bin" + "-no-emul-boot" "-boot-load-size" "4" "-boot-info-table" + "--eltorito-catalog" "isolinux/isolinux.cat" + + ,iso-root))))) + (defprop host-volumes-created :lisp () "Recursively create the volumes as specified by DISK:HAS-VOLUMES. **THIS PROPERTY UNCONDITIONALLY FORMATS DISKS, POTENTIALLY DESTROYING DATA, diff --git a/src/property/file.lisp b/src/property/file.lisp index a54d38c..bdda926 100644 --- a/src/property/file.lisp +++ b/src/property/file.lisp @@ -42,8 +42,25 @@ CONTENT can be a list of lines or a single string." (string (format nil "~A~&" content))) (and mode-supplied-p `(:mode ,mode))))) +(defpropspec exists-with-content :posix + (path content &key (mode nil mode-supplied-p)) + "Like FILE:HAS-CONTENT, but unapplicable, where unapplying means deleting +PATH, rather than restoring any old content it might have had. + +The semantics of this property are that if it is applied, the file has content +CONTENT, and if it is not applied to a host, the file does not exist. Thus, +it should be used to create new files on the host, not to replace the contents +of existing files, such as those installed by operating system packages. For +replacing the contents of existing files, prefer FILE:HAS-CONTENT." + (declare (indent 1)) + (:desc #?"${path} exists with defined content") + `(with-unapply + (has-content ,path ,content ,@(and mode-supplied-p `(:mode ,mode))) + :unapply (does-not-exist ,path))) + (defprop contains-lines :posix (path &rest lines) "Ensure there is a file at PATH containing each of LINES once." + (declare (indent 1)) (:apply (let ((new-lines (copy-list (ensure-cons lines))) (existing-lines (and (remote-exists-p path) @@ -68,6 +85,19 @@ CONTENT can be a list of lines or a single string." (with-change-if-changes-file (path) (mrun (format nil "chmod ~O ~A" mode path))))) +(defprop has-ownership :posix (path &key user group) + "Ensure that a file has particular ownership and group ownership." + (:desc (format nil "~A has~:[~; owner ~:*~A~]~:[~;~2:*~:[~;,~] group ~A~]" + path user group)) + (:hostattrs + (unless (or user group) + (inapplicable-property "Not enough arguments."))) + (:apply + (with-change-if-changes-file (path) + (if user + (mrun "chown" "-h" (format nil "~A~:[~;:~:*~A~]" user group) path) + (mrun "chgrp" "-h" group path))))) + (defprop does-not-exist :posix (&rest paths) "Ensure that files do not exist." (:desc (if (cdr paths) @@ -76,6 +106,21 @@ CONTENT can be a list of lines or a single string." (:check (not (apply #'remote-exists-p paths))) (:apply (mrun "rm" "-f" paths))) +(defprop directory-does-not-exist :posix + (&rest directories + ;; Ensure that there's a trailing slash at the end of each + ;; namestring, such that if a regular file of the same name as the + ;; directory exists, 'rm -rf' will not delete it. + &aux (directories + (mapcar (compose #'ensure-trailing-slash #'unix-namestring) + directories))) + "Recursively ensure that DIRECTORIES do not exist." + (:desc (if (cdr directories) + #?"@{directories} do not exist" + #?"${(car directories)} does not exist")) + (:check (not (apply #'remote-exists-p directories))) + (:apply (mrun "rm" "-rf" directories))) + (defprop data-uploaded :posix (iden1 iden2 destination) (:hostattrs (declare (ignore destination)) @@ -84,11 +129,13 @@ CONTENT can be a list of lines or a single string." (containing-directory-exists destination) (maybe-writefile-data destination iden1 iden2))) -(defprop host-data-uploaded :posix (destination) - (:hostattrs - (require-data (get-hostname) destination)) - (:apply - (data-uploaded (get-hostname) destination destination))) +(defproplist host-data-uploaded :posix + (destination + ;; Require an absolute path because we don't know the remote home + ;; directory at hostattrs time, so can't resolve it ourselves. + &aux (destination (unix-namestring + (ensure-pathname destination :want-absolute t)))) + (data-uploaded (get-hostname) destination destination)) (defprop secret-uploaded :posix (iden1 iden2 destination) (:hostattrs @@ -98,12 +145,17 @@ CONTENT can be a list of lines or a single string." (containing-directory-exists destination) (maybe-writefile-data destination iden1 iden2 :mode #o600))) -(defprop host-secret-uploaded :posix - (destination &aux (destination (unix-namestring destination))) - (:hostattrs - (require-data (get-hostname) destination)) - (:apply - (secret-uploaded (get-hostname) destination destination))) +(defproplist host-secret-uploaded :posix + (destination + ;; Require an absolute path like with HOST-DATA-UPLOADED. + &aux (destination (unix-namestring + (ensure-pathname destination :want-absolute t)))) + (secret-uploaded (get-hostname) destination destination)) + +(defprop data-cache-purged :posix () + "Ensure that any prerequisite data cached in the remote home directory is removed." + (:desc "Consfigurator data cache cleaned") + (:apply (directory-does-not-exist (get-remote-data-cache-dir)))) (defprop regex-replaced-lines :posix (file regex replace) "Like s/REGEX/REPLACE/ on the lines of FILE. @@ -134,14 +186,19 @@ Uses CL-PPCRE:REGEX-REPLACE, which see for the syntax of REPLACE." ;; likewise assume it was already there :no-change)) -;; readlink(1) is not POSIX +;; readlink(1) is not POSIX. This is a safe parse of ls(1) output given its +;; POSIX specification. (defun remote-link-target (symlink) - (loop with s = (stripln (run :env '(:LOCALE "POSIX") "ls" "-ld" symlink)) - with found = 0 + (loop with s = (stripln (run :env '(:LC_ALL "C") "ls" "-ld" symlink)) + and found = 0 and just-found for i from 0 below (length s) - when (char= (elt s i) #\Space) - do (incf found) - when (>= found 9) + + if (char= (elt s i) #\Space) + unless just-found do (incf found) (setq just-found t) + end + else do (setq just-found nil) + + when (>= found 8) return (subseq s (+ (length symlink) i 5)))) (defprop symlinked :posix (&key from to) @@ -258,7 +315,7 @@ Other arguments: collect (list commentedp current-section k v) else collect line)) (mapped (funcall map unmapped))) - (loop with current-section + (loop with current-section and collectedp for line in mapped for line-section = (etypecase line (cons (cadr line)) @@ -267,7 +324,7 @@ Other arguments: if (and (listp line) line-section (not (string= line-section current-section))) - collect "" + when collectedp collect "" end and collect (funcall new-section line-section) and do (setq current-section line-section) else if (and (stringp line) @@ -281,7 +338,8 @@ Other arguments: (declare (ignore sec)) (when commentedp (princ new-comment s)) (princ (funcall new-kv k v) s))) - else collect line))))) + else collect line + do (setq collectedp t)))))) (defun simple-conf-update (file pairs &rest args) (let ((keys (make-hash-table :test #'equal))) @@ -342,7 +400,7 @@ commented out; the first commented or uncommented line for each key will be uncommented and used to set the value, if it exists." (:desc (format nil "~A has ~{~A = ~A~^, ~}" file pairs)) (:apply (simple-conf-update file pairs - :parse-kv #?/^(\S+) = (.+)/ + :parse-kv #?/^([^\s=]+)\s?=\s?(.*)/ :new-kv (lambda (k v) #?"${k} = ${v}")))) (defprop contains-conf-shell :posix (file &rest pairs) @@ -360,7 +418,7 @@ uncommented and used to set the value, if it exists." ;; include quoting as part of the value so we ;; don't end up substituting double quotation ;; marks for single, or similar - :parse-kv #?/^(\S+)\s?=\s?(.*)/ + :parse-kv #?/^([^\s=]+)\s?=\s?(.*)/ :new-kv (lambda (k v) #?"${k}=${v}")))) (defprop contains-ini-settings :posix (file &rest triples) @@ -436,7 +494,15 @@ ENTRIES, using a simple merge procedure: existing lines of the file with the same value for the TARGETth field are updated to match the corresponding members of ENTRIES, except that if the SOURCEth field of the existing entry is not NO-SOURCE and the corresponding member of ENTRIES is STRING= to either -NO-SOURCE or \"PLACEHOLDER\", use the existing field value." +NO-SOURCE or \"PLACEHOLDER\", use the existing field value. + +Sort the lines to avoid certain possible failures. For each pair of lines, if +the TARGETth or the SOURCEth field of the first line is a path and a subpath +of the TARGETth field of the second line, sort the second line earlier. +Otherwise, try to avoid disturbing line order. This avoids failures to mount +because the filesystem containing the mount point is not mounted yet, and +ensures that partitions containing things like swap files are mounted before +an attempt is made to activate the swap, set up the bind mount, etc." (let ((unknown (list no-source "PLACEHOLDER")) (pending (make-hash-table :test #'equal))) (dolist (entry entries) @@ -444,18 +510,36 @@ NO-SOURCE or \"PLACEHOLDER\", use the existing field value." (map-file-lines file (lambda (lines) - (loop for line in lines - for line-fields = (words line) - for line-source = (nth source line-fields) - and line-target = (nth target line-fields) - for entry = (when-let* ((entry (gethash line-target pending)) - (fields (words entry))) - (when (and (member (nth source fields) - unknown :test #'string=) - (not (string= line-source no-source))) - (setf (nth source fields) line-source)) - (format nil "~{~A~^ ~}" fields)) - if entry - collect it into accum and do (remhash line-target pending) - else collect line into accum - finally (return (nconc accum (hash-table-values pending)))))))) + (stable-sort + (loop for line in lines + for line-fields = (words line) + for line-source = (nth source line-fields) + and line-target = (nth target line-fields) + for entry = (when-let* ((entry (gethash line-target pending)) + (fields (words entry))) + (when (and (member (nth source fields) + unknown :test #'string=) + (not (string= line-source no-source))) + (setf (nth source fields) line-source)) + (format nil "~{~A~^ ~}" fields)) + if entry + collect it into accum and do (remhash line-target pending) + else collect line into accum + finally (return (nconc accum (hash-table-values pending)))) + (lambda (a b) + (flet ((subpathp (x y) + (and (plusp (length x)) (plusp (length y)) + (char= #\/ (first-char x) (first-char y)) + (subpathp (ensure-pathname x) + (ensure-directory-pathname y))))) + (and + ;; If either line is blank treat as equal. + (plusp (length a)) (plusp (length b)) + ;; If either line is a comment treat as equal. + (not (char= #\# (first-char a))) (not (char= #\# (first-char b))) + ;; Now compare the TARGETth and SOURCEth fields of B to the + ;; TARGETth field of A. + (let ((a (words a)) (b (words b))) + (let ((a-target (nth target a))) + (or (subpathp (nth target b) a-target) + (subpathp (nth source b) a-target)))))))))))) diff --git a/src/property/firewalld.lisp b/src/property/firewalld.lisp new file mode 100644 index 0000000..a39b22c --- /dev/null +++ b/src/property/firewalld.lisp @@ -0,0 +1,224 @@ +;;; 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.firewalld) +(named-readtables:in-readtable :consfigurator) + +(defproplist installed :posix () + (:desc "firewalld installed") + (os:etypecase + (debianlike (apt:installed "firewalld")))) + +(defprop %firewall-cmd :posix (file warning &rest args) + (:apply + ;; --add-service will always tell us ALREADY_ENABLED if nothing was + ;; changed, but --set-target won't tell us whether a change was made, so we + ;; have to be prepared to look at whether the file changed, too. + ;; + ;; If we make no change to a builtin zone, or similar, then the + ;; corresponding .xml file may not exist either before or after running the + ;; command, and given how WITH-CHANGE-IF-CHANGES-FILE works, that means we + ;; fail to return :NO-CHANGE. However, we have enough :CHECK subroutines + ;; defined to avoid this situation actually arising. + (flet ((run () + (let ((output (mrun "firewall-cmd" args))) + (and warning (search warning output) :no-change)))) + (let ((result (if file + (with-change-if-changes-file + ((merge-pathnames file #P"/etc/firewalld/")) (run)) + (run)))) + (unless (eql result :no-change) + (mrun "firewall-cmd" "--reload")) + result)))) + + +;;;; Setting contents of XML configuration files + +(defproplist %setxml :posix (type name xml) + (installed) + (on-change + (file:exists-with-content #?"/etc/firewalld/${type}/${name}.xml" xml) + (cmd:single "firewall-cmd" "--reload"))) + +(defproplist service :posix (service xml) + (:desc #?"firewalld knows service ${service}") + (%setxml "services" service xml)) + +(defproplist policy :posix (policy xml) + (:desc #?"firewalld has policy ${policy}") + (%setxml "policies" policy xml)) + +(defproplist zone :posix (zone xml) + "Set the whole XML configuration for zone ZONE. + +In preference to using this property, it is usually best to incrementally +build up the configuration for a zone using properties like +FIREWALLD:ZONE-HAS-SERVICE, FIREWALLD:ZONE-HAS-INTERFACE etc.. Using this +property forces most of your firewall configuration to be in a single place in +your consfig, but it is typically more readable and flexible to have +properties which set up the actual services and interfaces interact with the +firewall configuration themselves, to render the things that those properties +set up appropriately accessible and inaccessible. + +(By contrast, for defining services and policies we take the simpler approach +of just setting the whole XML configuration, using FIREWALLD:SERVICE and +FIREWALLD:POLICY.)" + (:desc #?"firewalld has zone configuration for ${zone}") + (%setxml "zones" zone xml)) + + +;;;; Incremental configuration of zones + +(defprop has-zone :posix (zone) + "Ensure that the zone ZONE exists. + +You will not usually need to call this property directly; it is applied by +properties which add services, interfaces etc. to zones." + (:desc #?"firewalld zone ${zone} exists") + (:check (zerop (mrun :for-exit "firewall-cmd" "--permanent" + #?"--zone=${zone}" "--get-target"))) + (:apply (mrun "firewall-cmd" "--permanent" #?"--new-zone=${zone}")) + (:unapply (mrun "firewall-cmd" "--permanent" #?"--delete-zone=${zone}"))) + +(defproplist zone-target :posix (zone target) + (:desc #?"firewalld zone ${zone} has target ${target}") + (:check (string= target + (stripln (run :may-fail "firewall-cmd" "--permanent" + #?"--zone=${zone}" "--get-target")))) + (installed) + (has-zone zone) + (%firewall-cmd #?"zones/${zone}.xml" nil "--permanent" + #?"--zone=${zone}" #?"--set-target=${target}")) + +(defprop %default-route-zoned :posix (zone) + (:apply + (if-let ((default-route-interface + (loop for line in (runlines "ip" "route" "list" "scope" "global") + when (string-prefix-p "default " line) + return (fifth (words line))))) + (%firewall-cmd #?"zones/${zone}.xml" nil + "--permanent" #?"--zone=${zone}" + #?"--change-interface=${default-route-interface}") + (failed-change "Could not determine the interface of the default route.")))) + +(defproplist default-route-zoned-once :posix (&optional (zone "public")) + "Bind the interface of the default route to zone ZONE, only if this property +has not done that yet for at least one (INTERFACE . ZONE) pair. + +This property is intended for machines which have firewalld but do not use +Network Manager, as is typical on Debian servers using firewalld. On such +machines firewalld will fail to add the primary network interface to any zone +when the interface comes up before firewalld does. + +This property avoids the situation in which the primary network interface is +not part of any zone by explicitly adding it to ZONE, determining the name of +the interface by examining the current default route. The property only adds +an interface to a zone once, as the default route might later be changed +temporarily by something like a VPN connection, and in such a case the +firewall should not be reconfigured. + +Typically you will apply both this property and FIREWALLD:DEFAULT-ZONE, +passing the same zone name to each. If you have Network Manager, you need +only FIREWALLD:DEFAULT-ZONE." + (with-flagfile "/etc/consfigurator/firewalld/default-route-zoned" + (installed) + (has-zone zone) + (%default-route-zoned zone))) + +(defproplist zone-has-interface :posix (zone interface) + (:desc #?"firewalld zone ${zone} has interface ${interface}") + (:check (zerop (mrun :for-exit "firewall-cmd" "--permanent" + #?"--zone=${zone}" + #?"--query-interface=${interface}"))) + (with-unapply + (installed) + (has-zone zone) + (%firewall-cmd #?"zones/${zone}.xml" nil + "--permanent" #?"--zone=${zone}" + #?"--change-interface=${interface}") + :unapply (%firewall-cmd #?"zones/${zone}.xml" nil + "--permanent" #?"--zone=${zone}" + #?"--remove-interface=${interface}"))) + +(defproplist zone-has-service :posix (zone service) + (:desc #?"firewalld zone ${zone} has service ${service}") + (:check (zerop (mrun :for-exit "firewall-cmd" "--permanent" + #?"--zone=${zone}" #?"--query-service=${service}"))) + (with-unapply + (installed) + (has-zone zone) + (%firewall-cmd #?"zones/${zone}.xml" "ALREADY_ENABLED" + "--permanent" #?"--zone=${zone}" + #?"--add-service=${service}") + :unapply (%firewall-cmd #?"zones/${zone}.xml" "NOT_ENABLED" + "--permanent" #?"--zone=${zone}" + #?"--remove-service=${service}"))) + +(defproplist zone-masquerade :posix (zone) + (:desc #?"firewalld zone ${zone} has masquerade") + (:check (zerop (mrun :for-exit "firewall-cmd" "--permanent" + #?"--zone=${zone}" "--query-masquerade"))) + (with-unapply + (installed) + (has-zone zone) + (%firewall-cmd #?"zones/${zone}.xml" "ALREADY_ENABLED" + "--permanent" + #?"--zone=${zone}" "--add-masquerade") + :unapply (%firewall-cmd #?"zones/${zone}.xml" "NOT_ENABLED" + "--permanent" + #?"--zone=${zone}" "--remove-masquerade"))) + +(defproplist zone-rich-rule :posix (zone rule) + (:desc #?"firewalld zone ${zone} has rich rule \"${rule}\"") + (:check (zerop (mrun :for-exit "firewall-cmd" + "--permanent" #?"--zone=${zone}" + (strcat "--query-rich-rule=" rule)))) + (with-unapply + (installed) + (has-zone zone) + (%firewall-cmd #?"zones/${zone}.xml" "ALREADY_ENABLED" + "--permanent" #?"--zone=${zone}" + (strcat "--add-rich-rule=" rule)) + :unapply + (%firewall-cmd #?"zones/${zone}.xml" "NOT_ENABLED" + "--permanent" #?"--zone=${zone}" + (strcat "--remove-rich-rule=" rule)))) + +;; Note that direct rules will be deprecated as of firewalld 1.0.0, as +;; policies and rich rules should be able to cover all uses of direct rules. +;; <https://firewalld.org/2021/06/the-upcoming-1-0-0> +(defpropspec zone-direct-rule :posix (&rest rule-args) + (:desc #?"firewalld has direct rule \"@{rule-args}\"") + (:check (zerop (mrun :for-exit "firewall-cmd" + "--permanent" "--direct" "--query-rule" rule-args))) + `(with-unapply + (installed) + (%firewall-cmd "direct.xml" "ALREADY_ENABLED" + "--permanent" "--direct" "--add-rule" ,@rule-args) + :unapply + (%firewall-cmd "direct.xml" "NOT_ENABLED" + "--permanent" "--direct" "--remove-rule" ,@rule-args))) + + +;;;; Daemon configuration + +(defproplist default-zone :posix (zone) + (:desc #?"firewalld default zone is ${zone}") + (installed) + (has-zone zone) + (%firewall-cmd "firewalld.conf" "ZONE_ALREADY_SET" + #?"--set-default-zone=${zone}")) diff --git a/src/property/fstab.lisp b/src/property/fstab.lisp index 643e54e..a4eaf98 100644 --- a/src/property/fstab.lisp +++ b/src/property/fstab.lisp @@ -18,7 +18,7 @@ (in-package :consfigurator.property.fstab) (named-readtables:in-readtable :consfigurator) -;;; Use of findmnt(1) makes much of this Linux-specific. +;;; Use of findmnt(8) makes much of this Linux-specific. ;;;; Methods on volumes to get strings for fstab @@ -58,7 +58,7 @@ Other properties might fill it in." "vfat") (defmethod fs-mntops ((volume filesystem)) - (or (mount-options volume) '("none"))) + (or (mount-options volume) '("defaults"))) (defmethod fs-freq ((volume filesystem)) 0) diff --git a/src/property/git.lisp b/src/property/git.lisp index 9cd49f8..60d404a 100644 --- a/src/property/git.lisp +++ b/src/property/git.lisp @@ -18,6 +18,12 @@ (in-package :consfigurator.property.git) (named-readtables:in-readtable :consfigurator) +(defproplist installed :posix () + "Ensures that git(1) is installed." + (:desc "Git installed") + (os:etypecase + (debianlike (apt:installed "git")))) + (defprop snapshot-extracted :posix (directory snapshot-name &key replace @@ -41,7 +47,58 @@ available version of the snapshot is present on the remote system." (file:directory-exists directory) (with-remote-current-directory (directory) (mrun :input (get-data-stream "--git-snapshot" snapshot-name) - "tar" "xfz" "-"))) + "tar" (if (zerop (get-connattr :remote-uid)) "oxfz" "xfz") "-"))) (:unapply (declare (ignore replace)) (delete-remote-trees dest))) + +(defprop %cloned :posix (url dest branch + &aux (dest (ensure-directory-pathname dest))) + (:check + (declare (ignore branch)) + (let ((config (merge-pathnames ".git/config" dest))) + (and (remote-exists-p config) + (string= url (car (runlines "git" "config" "--file" config + "remote.origin.url")))))) + (:apply + (delete-remote-trees dest) + (file:containing-directory-exists dest) + (run "git" "clone" url dest) + (with-remote-current-directory (dest) + (when branch + (mrun "git" "checkout" branch)) + ;; Do this in case this repo is to be served via HTTP, though note that + ;; we don't set up the hook to do this upon update here. + (mrun "git" "update-server-info")))) + +(defproplist cloned :posix (url dest &optional branch) + "Clone git repo available at URL to DEST. +If the directory already exists and contains anything but a git repo cloned +from URL, recursively delete it first. If BRANCH, check out that branch." + (:desc #?"${url} cloned to ${dest}") + (installed) + (%cloned url dest branch)) + +(defprop %pulled :posix (dest &aux (dest (ensure-directory-pathname dest))) + (:apply + (with-change-if-changes-file-content + ((merge-pathnames ".git/FETCH_HEAD" dest)) + (with-remote-current-directory (dest) + (mrun "git" "pull") + (mrun "git" "update-server-info"))))) + +(defproplist pulled :posix (url dest &optional branch) + "Like GIT:CLONED, but also 'git pull' each time this property is applied." + (:desc #?"${url} pulled to ${dest}") + (installed) + (%cloned url dest branch) + (%pulled dest)) + +(defprop repo-configured :posix (repo &rest pairs) + (:desc + (format nil "git repo at ~S has configuration ~{~A=~A~^, ~}" repo pairs)) + (:check (loop for (k v) on pairs by #'cddr + always (string= v (stripln + (run :may-fail "git" "-C" repo "config" k))))) + (:apply (loop for (k v) on pairs by #'cddr + do (mrun "git" "-C" repo "config" k v)))) diff --git a/src/property/gnupg.lisp b/src/property/gnupg.lisp index 6f3167f..d551914 100644 --- a/src/property/gnupg.lisp +++ b/src/property/gnupg.lisp @@ -18,9 +18,7 @@ (in-package :consfigurator.property.gnupg) (named-readtables:in-readtable :consfigurator) -(defprop public-key-imported :posix (fingerprint) - "Import the PGP public key identified by FINGERPRINT to gpg's default -keyring." +(defprop %public-key-imported :posix (fingerprint) (:desc #?"PGP public key ${fingerprint} imported") (:preprocess (list (remove #\Space fingerprint))) @@ -32,3 +30,37 @@ keyring." (with-change-if-changes-file (".gnupg/pubring.kbx") (mrun :input (get-data-stream "--pgp-pubkey" fingerprint) "gpg" "--import")))) + +(defprop %trusts-public-key :posix (fingerprint level) + (:desc #?"PGP public key ${fingerprint} trusted, level ${level}") + (:preprocess (list (remove #\Space fingerprint) level)) + (:apply (with-change-if-changes-file (".gnupg/trustdb.gpg") + (mrun :input (format nil "~A:~A:~%" fingerprint level) + "gpg" "--import-ownertrust")))) + +(defpropspec public-key-imported :posix (fingerprint &key trust-level) + "Import the PGP public key identified by FINGERPRINT to gpg's default keyring. +If TRUST-LEVEL, also ensure that the key is trusted at that level, an +integer." + (:desc + (if trust-level + #?"PGP public key ${fingerprint} imported and trusted, level ${trust-level}" + #?"PGP public key ${fingerprint} imported")) + (if trust-level + `(eseqprops (%public-key-imported ,fingerprint) + (%trusts-public-key ,fingerprint ,trust-level)) + `(%public-key-imported ,fingerprint))) + +(defprop secret-key-imported :posix (fingerprint) + (:desc #?"PGP public key ${fingerprint} imported") + (:preprocess (list (remove #\Space fingerprint))) + (:hostattrs (require-data "--pgp-seckey" fingerprint)) + (:check + ;; Look for plain "sec" not, e.g., "sec#", which indicates the secret key + ;; is not available. + (multiple-value-bind (out err exit) + (run :may-fail "gpg" "--list-secret-keys" fingerprint) + (declare (ignore err)) + (and (zerop exit) (re:scan #?/^sec\s/ out)))) + (:apply (mrun :input (get-data-stream "--pgp-seckey" fingerprint) + "gpg" "--import"))) diff --git a/src/property/hostname.lisp b/src/property/hostname.lisp index 0ff8828..da1610e 100644 --- a/src/property/hostname.lisp +++ b/src/property/hostname.lisp @@ -19,7 +19,9 @@ (named-readtables:in-readtable :consfigurator) (defun domain (hostname) - (subseq hostname (min (length hostname) (1+ (position #\. hostname))))) + (if-let ((pos (position #\. hostname))) + (subseq hostname (min (length hostname) (1+ pos))) + "")) (defprop is :posix (hostname) "Specify that the hostname of this host is HOSTNAME. diff --git a/src/property/installer.lisp b/src/property/installer.lisp index c270bdf..2830703 100644 --- a/src/property/installer.lisp +++ b/src/property/installer.lisp @@ -132,3 +132,266 @@ install a package providing /usr/sbin/grub-install, but it won't execute it." (setq propspecs (delete-duplicates propspecs :test #'tree-equal)) (return (if (cdr propspecs) (cons 'eseqprops propspecs) (car propspecs))))) + +(defpropspec bootloaders-installed :lisp (&key (running-on-target t)) + "Install the host's bootloaders to its volumes. +Intended to be attached to properties like INSTALLER:CLEANLY-INSTALLED-ONCE +using a combinator like ON-CHANGE, or applied manually with DEPLOY-THESE." + (:desc "Bootloaders installed") + `(eseqprops + (bootloader-binaries-installed) + ,@(get-propspecs (get-hostattrs :volumes) running-on-target))) + + +;;;; Live replacement of GNU/Linux distributions + +;;; This is based on Propellor's OS.cleanInstallOnce property -- very cool! +;;; +;;; We prepare only a base system chroot, and then apply the rest of the +;;; host's properties after the flip, rather than applying all of the host's +;;; properties to the chroot and only then flipping. This has the advantage +;;; that properties which normally restrict themselves when running in a +;;; chroot will instead apply all of their changes. There could be failures +;;; due to still running the old OS's kernel and init system, however, which +;;; might be avoided by applying the properties only to the chroot. +;;; +;;; Another option would be a new SERVICES:WITHOUT-STARTING-SERVICES-UNTIL-END +;;; which would disable starting services and push the cleanup forms inside +;;; the definition of SERVICES:WITHOUT-STARTING-SERVICES to *AT-END-FUNCTIONS* +;;; in a closure. We'd also want %CONSFIGURE to use UNWIND-PROTECT to ensure +;;; that the AT-END functions get run even when there's a nonlocal exit from +;;; %CONSFIGURE's call to PROPAPPAPPLY; perhaps we could pass a second +;;; argument to the AT-END functions indicating whether there was a non-local +;;; transfer of control. REBOOT:REBOOTED-AT-END might only reboot when there +;;; was a normal return from PROPAPPAPPLY, whereas the cleanup forms from +;;; SERVICES:WITHOUT-STARTING-SERVICES would always be evaluated. + +(defprop %root-filesystems-flipped :lisp (new-os old-os) + (:hostattrs (os:required 'os:linux)) + (:apply + (assert-euid-root) + (let ((new-os (ensure-directory-pathname new-os)) + (old-os + (ensure-directories-exist (ensure-directory-pathname old-os))) + (preserved-directories + '(;; This can contain sockets, remote Lisp image output, etc.; + ;; avoid upsetting any of those. + #P"/tmp/" + ;; Makes sense to keep /proc until we replace the running init, + ;; and we want to retain all the systemd virtual filesystems + ;; under /sys to avoid problems applying other properties. Both + ;; are empty directories right after debootstrap, so nothing to + ;; copy out. + #P"/proc/" #P"/sys/" + ;; This we make use of below. + #P"/old-run/")) + efi-system-partition-mount-args) + (flet ((preservedp (pathname) + (member pathname preserved-directories :test #'pathname-equal))) + (mount:assert-devtmpfs-udev-/dev) + (unless (mountpointp "/run") + (failed-change "/run is not a mount point; don't know what to do.")) + + ;; If there's an EFI system partition, we need to store knowledge of + ;; how to mount it so that we can restore the mount after doing the + ;; moves, so that installing an EFI bootloader is possible. The user + ;; is responsible for adding an entry for the EFI system partition to + ;; the new system's fstab, but we are responsible for restoring + ;; knowledge of the partition to the kernel's mount table. + (when (mountpointp "/boot/efi") + (destructuring-bind (type source options) + (words (stripln (run "findmnt" "-nro" "FSTYPE,SOURCE,OPTIONS" + "/boot/efi"))) + (setq efi-system-partition-mount-args + `("-t" ,type "-o" ,options ,source "/boot/efi")))) + + ;; /run is tricky because we want to retain the contents of the tmpfs + ;; mounted there until reboot, for similar reasons to wanting to retain + ;; /tmp, but unlike /tmp, /proc and /sys, a freshly debootstrapped + ;; system contains a few things under /run and we would like to move + ;; these out of /new-os. So we temporarily relocate the /run mount. + ;; + ;; If this causes problems we could reconsider -- there's usually a + ;; tmpfs mounted at /run, so those files underneath might not matter. + (mrun "mount" "--make-private" "/") + (system "mount" "--move" "/run" (ensure-directories-exist "/old-run/")) + + ;; We are not killing any processes, so lazily unmount everything + ;; before trying to perform any renames. (Present structure of this + ;; loop assumes that each member of PRESERVED-DIRECTORIES is directly + ;; under '/'.) + ;; + ;; We use system(3) to mount and unmount because once we unmount /dev, + ;; there may not be /dev/null anymore, depending on whether the root + ;; filesystems of the old and new OSs statically contain the basic /dev + ;; entries or not, and at least on SBCL on Debian UIOP:RUN-PROGRAM + ;; wants to open /dev/null when executing a command with no input. + ;; Another option would be to pass an empty string as input. + (loop with sorted = (cdr (mount:all-mounts)) ; drop '/' itself + as next = (pop sorted) + while next + do (loop while (subpathp (car sorted) next) do (pop sorted)) + unless (preservedp next) + do (system "umount" "--recursive" "--lazy" next)) + + (let (done) + (handler-case + (flet ((rename (s d) (rename-file s d) (push (cons s d) done))) + (dolist (file (directory-contents #P"/")) + (unless (or (preservedp file) + (pathname-equal file new-os) + (pathname-equal file old-os)) + (rename file (chroot-pathname file old-os)))) + (dolist (file (directory-contents new-os)) + (let ((dest (in-chroot-pathname file new-os))) + (unless (preservedp dest) + (when (or (file-exists-p dest) (directory-exists-p dest)) + (failed-change + "~A already exists in root directory." dest)) + (rename file dest))))) + (serious-condition (c) + ;; Make a single attempt to undo the moves to increase the chance + ;; we can fix things and try again. + (loop for (source . dest) in done do (rename-file dest source)) + (signal c)))) + (delete-directory-tree new-os :validate t) + + ;; Restore /run and any submounts, like /run/lock. + (system "mount" "--move" "/old-run" "/run") + (delete-empty-directory "/old-run") + + ;; For the freshly bootstrapped OS let's assume that HOME is /root and + ;; XDG_CACHE_HOME is /root/.cache; we do want to try to read the old + ;; OS's actual XDG_CACHE_HOME. Move cache & update environment. + (let ((source + (chroot-pathname + (merge-pathnames "consfigurator/" + (ensure-directory-pathname + (or (getenv "XDG_CACHE_HOME") + (strcat (getenv "HOME") "/.cache/")))) + old-os))) + (when (directory-exists-p source) + (rename-file source (ensure-directories-exist + #P"/root/.cache/consfigurator/")))) + (setf (get-connattr :remote-user) "root") + (setf (get-connattr :remote-home) "/root") + (posix-login-environment "root" "/root") + + ;; Remount (mainly virtual) filesystems that other properties we will + ;; apply might require (esp. relevant for installing bootloaders). + (dolist (mount mount:*standard-linux-vfs*) + (unless (preservedp (ensure-directory-pathname (lastcar mount))) + (apply #'system "mount" mount))) + (when efi-system-partition-mount-args + (ensure-directories-exist #P"/boot/efi/") + (apply #'mrun "mount" efi-system-partition-mount-args)))))) + +(defproplist cleanly-installed-once :lisp + (&optional options (original-os '(os:linux :amd64)) + &aux (minimal-new-host + (make-host :hostattrs (list :os (get-hostattrs :os)))) + (original-host + (make-host + :propspec + (make-propspec + :propspec + `(eseqprops ,original-os + (chroot:os-bootstrapped-for + ,options "/new-os" ,minimal-new-host)))))) + "Replaces whatever operating system the host has with a clean installation of +the OS that the host is meant to have, and reboot, once. This is intended for +freshly launched machines in faraway datacentres, where your provider has +installed some operating system image to get you started, but you'd like have +a greater degree of control over the contents and configuration of the +machine. For example, this can help you ensure that the operation of the host +does not implicitly depend upon configuration present in the provider's image +but not captured by your consfig. This property's approach can fail and leave +the system unbootable, but it's an time-efficient way to ensure that you're +starting from a truly clean slate for those cases in which it works. + +ORIGINAL-OS is a propapp specifying the old OS, as you would apply to a host +with that OS. It will be used when trying to install the OS bootstrapper. +For example, if you're trying to switch a host from a provider's Debian +\"buster\" image to upstream Debian \"bullseye\", passing '(OS:DEBIAN-STABLE +\"buster\" :AMD64) would cause Consfigurator to use apt to install +debootstrap(8). Alternatively, you can pass '(OS:LINUX :AMD64) and install +the bootstrapper manually; this is useful for OSs whose package managers +Consfigurator doesn't yet know how to drive. You might apply an OS-agnostic +property before this one which manually downloads the bootstrapper and puts it +on PATH. + +OPTIONS will be passed on to CHROOT:OS-BOOTSTRAPPED-FOR, which see. + +The files from the old OS will be left in '/old-os'. Typically you will need +to perform some additional configuration before rebooting to increase the +likelihood that the system boots and is network-accessible. This might +require copying information from '/old-os' and/or the kernel's state before +the reboot. Some of this will need to be attached to the application of this +property using ON-CHANGE, whereas other fixes can just be applied subsequent +to this property. Here are two examples. If you already know the machine's +network configuration you might use + + (os:debian-stable \"bullseye\" :amd64) + (installer:cleanly-installed-once ...) + (network:static \"ens3\" \"1.2.3.4\" ...) + (file:has-content \"/etc/resolv.conf\" ...) + +whereas if you don't have that information, you would want something like + + (os:debian-stable \"bullseye\" :amd64) + (on-change (installer:cleanly-installed-once ...) + (file:is-copy-of \"/etc/resolv.conf\" \"/old-os/etc/resolv.conf\")) + (network:preserve-static-once) + +Here are some other propapps you might want to attach to the application of +this property with ON-CHANGE: + + (bootloaders-installed) + (fstab:entries-for-volumes + (disk:volumes + (mounted-ext4-filesystem :mount-point #P\"/\") + (partition (mounted-fat32-filesystem :mount-point #P\"/boot/efi/\")))) + (file:is-copy-of \"/root/.ssh/authorized_keys\" + \"/old-os/root/.ssh/authorized_keys\") + (mount:unmounted-below-and-removed \"/old-os\") + +You will probably need to install a kernel, bootloader, sshd etc. in the list +of properties subsequent to this one. A more complete example: + + (os:debian-stable \"bullseye\" :amd64) + (disk:has-volumes + (physical-disk + :device-file #P\"/dev/sda\" + :boots-with '(grub:grub :target \"x86_64-efi\"))) + (on-change (installer:cleanly-installed-once + nil '(os:debian-stable \"buster\" :amd64)) + ;; Clear out the old OS's EFI system partition contents. + (file:directory-does-not-exist \"/boot/efi/EFI\") + + (apt:installed \"linux-image-amd64\") + (installer:bootloaders-installed) + + (fstab:entries-for-volumes + (disk:volumes + (mounted-ext4-filesystem :mount-point #P\"/\") + (partition + (mounted-fat32-filesystem :mount-point #P\"/boot/efi/\")))) + + (file:is-copy-of \"/etc/resolv.conf\" \"/old-os/etc/resolv.conf\") + (mount:unmounted-below-and-removed \"/old-os\")) + (network:static ...) + (sshd:installed) + (swap:has-swap-file \"2G\") + +If the system is not freshly provisioned, you couldn't easily recover from the +system becoming unbootable, or you have physical access to the machine, it is +probably better to use Consfigurator to build a disk image, or boot into a +live system and use Consfigurator to install to the host's usual storage." + (:desc "OS cleanly installed once") + (:hostattrs (os:required 'os:linux)) + (with-flagfile "/etc/consfigurator/os-cleanly-installed" + (deploys :local original-host) + (%root-filesystems-flipped "/new-os" "/old-os") + ;; Prevent boot issues caused by disabled shadow passwords. + (cmd:single "shadowconfig" "on") + (reboot:rebooted-at-end))) diff --git a/src/property/lets-encrypt.lisp b/src/property/lets-encrypt.lisp new file mode 100644 index 0000000..b87224c --- /dev/null +++ b/src/property/lets-encrypt.lisp @@ -0,0 +1,92 @@ +;;; 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.lets-encrypt) +(named-readtables:in-readtable :consfigurator) + +(defproplist installed :posix () + (:desc "Let's Encrypt client installed") + (os:etypecase + (debianlike (apt:installed "certbot")))) + +(defclass agree-tos () + ((email-address :initarg :email-address)) + (:documentation + "Object representing your agreement with the Let's Encrypt Subscriber +Agreement; you will need to pass this to properties which will invoke the +Let's Encrypt client. Supply an e-mail address so that Let's Encrypt can +contact you for things like certificate expiry, planned outage notifications +etc.")) + +(define-print-object-for-structlike agree-tos) + +(defmacro agree-tos (&key (email-address nil email-address-supplied-p)) + `(make-instance 'agree-tos ,@(and email-address-supplied-p + `(:email-address ,email-address)))) + +;; Based on Propellor's LetsEncrypt.letsEncrypt' property. +(defprop %obtained :posix (agree-tos htdocs domains) + (:apply + (check-type agree-tos agree-tos) + (let ((dir (ensure-directory-pathname + (merge-pathnames (car domains) #P"/etc/letsencrypt/live/")))) + (with-change-if-changes-files ((merge-pathnames "cert.pem" dir) + (merge-pathnames "chain.pem" dir) + (merge-pathnames "privkey.pem" dir) + (merge-pathnames "fullchain.pem" dir)) + (mrun "letsencrypt" "certonly" "--agree-tos" + (if (slot-boundp agree-tos 'email-address) + (strcat "--email=" (slot-value agree-tos 'email-address)) + "--register-unsafely-without-email") + "--webroot" "--webroot-path" htdocs + "--text" "--noninteractive" "--keep-until-expiring" + ;; Always request expansion in case DOMAINS has changed. + "--expand" + (loop for domain in domains + when (and (stringp domain) (plusp (length domain))) + collect (strcat "--domain=" domain))))))) + +(defproplist certificate-obtained :posix (agree-tos htdocs &rest domains) + "Obtains, and renews as necessary, an SSL certificate for DOMAINS. +The first element of DOMAINS, after flattening, is the Common Name of the +certificate. Use of this property implies agreement with the Let's Encrypt +Subscriber Agreement; AGREE-TOS is an instance of LETS-ENCRYPT:AGREE-TOS. +HTDOCS is the web root for DOMAINS, which must be writeable, and publically +available over plain HTTP. + +This property does nothing to ensure that your web server will actually use +the obtained certificate. Typically you'll want to combine this property with +web server-specific properties in a DEFPROPLIST/DEFPROPSPEC." + (:desc (format nil "Let's Encrypt for ~{~A~^, ~}" domains)) + (installed) + (%obtained agree-tos htdocs (flatten domains))) + +(defun dir-for (domain) + (ensure-directory-pathname + (merge-pathnames domain #P"/etc/letsencrypt/live/"))) + +(defun fullchain-for (domain) + (merge-pathnames "fullchain.pem" (dir-for domain))) + +(defun chain-for (domain) + (merge-pathnames "chain.pem" (dir-for domain))) + +(defun certificate-for (domain) + (merge-pathnames "cert.pem" (dir-for domain))) + +(defun privkey-for (domain) + (merge-pathnames "privkey.pem" (dir-for domain))) diff --git a/src/property/libvirt.lisp b/src/property/libvirt.lisp index dea12bc..d07073c 100644 --- a/src/property/libvirt.lisp +++ b/src/property/libvirt.lisp @@ -117,11 +117,9 @@ already running, for a VM which is not always booted, e.g. on a laptop." (:retprop :type (propapptype propapp) :desc (get (car propapp) 'desc) :hostattrs (get (car propapp) 'hostattrs) - :apply (lambda (&rest ignore) - (declare (ignore ignore)) + :apply (lambda-ignoring-args (check-started (propappapply propapp))) - :unapply (lambda (&rest ignore) - (declare (ignore ignore)) + :unapply (lambda-ignoring-args (check-started (propappunapply propapp))) :args (cdr propapp)))) @@ -200,7 +198,8 @@ Sample usage: (apt:installed \"linux-image-amd64\") (hostname:configured) - (network:static \"ens4\" \"192.168.122.31\" \"192.168.122.1\") + (network:static \"ens4\" + \"192.168.122.31\" \"192.168.122.1\" \"255.255.255.0\") (file:has-content \"/etc/resolv.conf\" \"...\") (sshd:installed) diff --git a/src/property/live-build.lisp b/src/property/live-build.lisp deleted file mode 100644 index e729234..0000000 --- a/src/property/live-build.lisp +++ /dev/null @@ -1,126 +0,0 @@ -;;; 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.live-build) -(named-readtables:in-readtable :consfigurator) - -(defproplist installed :posix () - "Install the Debian Live tool suite. See live-build(7)." - (:desc "Debian Live live-build installed") - (os:etypecase - (debianlike (apt:installed "live-build")))) - -(defun auto/config (config) - (with-output-to-string (s) - (format s "#!/bin/sh~%lb config noauto") - (dolist (argument config) - (princ " " s) - (princ (escape-sh-token argument) s)) - (princ " \"${@}\"" s) - (terpri s))) - -(defprop %lbconfig :posix (dir) - (:desc (declare (ignore dir)) - "lb config") - (:apply - (with-remote-current-directory (dir) - (run :inform "lb" "config")))) - -(defprop %lbbootstrap :posix - (config-changed dir &aux (chroot (merge-pathnames "chroot/" dir))) - (:desc (declare (ignore config-changed chroot)) - "lb bootstrap") - (:hostattrs - (declare (ignore config-changed chroot)) - (os:required 'os:linux)) - (:check - (and (not config-changed) - (remote-exists-p chroot) - (not (remote-exists-p (merge-pathnames "debootstrap/" chroot))))) - (:apply - (declare (ignore config-changed)) - (ignoring-hostattrs (mount:unmounted-below-and-removed chroot)) - (with-remote-current-directory (dir) - (apply #'run :inform - (if-let ((proxy (get-hostattrs-car :apt.proxy))) - (list :env (list :http_proxy proxy) "lb" "bootstrap") - '("lb" "bootstrap")))))) - -(defprop %lbchroot :posix (dir) - (:desc (declare (ignore dir)) - "lb chroot") - (:apply - (with-remote-current-directory (dir) - (run "lb" "chroot" "--force")))) - -(defprop %lbbinary :posix (dir) - (:desc (declare (ignore dir)) - "lb binary") - (:apply - (with-remote-current-directory (dir) - (run :inform "lb" "binary" "--force")))) - -(defpropspec image-built :lisp (config dir properties) - "Build an image under DIR using live-build(7), where the resulting live -system has PROPERTIES, which should contain, at a minimum, a property from -CONSFIGURATOR.PROPERTY.OS setting the Debian suite and architecture. CONFIG -is a list of arguments to pass to lb_config(1), not including the '-a' and -'-d' options, which Consfigurator will supply based on PROPERTIES. - -This property runs the lb_config(1), lb_bootstrap(1), lb_chroot(1) and -lb_binary(1) commands to build or rebuild the image. Rebuilding occurs only -when changes to CONFIG or PROPERTIES mean that the image is potentially -out-of-date; e.g. if you just add some new items to PROPERTIES then in most -cases only lb_chroot(1) and lb_binary(1) will be re-run. - -Note that lb_chroot(1) and lb_binary(1) both run after applying PROPERTIES, -and might undo some of their effects. For example, to configure -/etc/apt/sources.list, you will need to use CONFIG not PROPERTIES." - (:desc (declare (ignore config properties)) - #?"Debian Live image built in ${dir}") - (let* ((dir (ensure-directory-pathname dir)) - (chroot (merge-pathnames "chroot/" dir)) - (auto/config (merge-pathnames "auto/config" dir)) - (clean (mapcar (rcurry #'merge-pathnames - (merge-pathnames "config/" dir)) - '("binary" "bootstrap" "chroot" "common" "source"))) - (host (make-host :propspec properties)) - (host-os (get-hostattrs-car :os (preprocess-host host)))) - (when-let ((mirror (get-hostattrs-car :apt.mirror))) - (setq config (list* "-m" mirror config))) - (setq config (list* "-a" (os:debian-architecture host-os) - "-d" (os:debian-suite host-os) config)) - `(eseqprops - (installed) - (file:directory-exists ,(merge-pathnames "auto/" dir)) - (on-change - (eseqprops - (on-change - (file:has-content ,auto/config ,(auto/config config) :mode #o755) - (file:does-not-exist ,@clean) - (%lbconfig ,dir) - (%lbbootstrap t ,dir)) - (%lbbootstrap nil ,dir) - (deploys ((:chroot :into ,chroot)) ,host)) - ;; We could run lb_chroot before DEPLOYS, but lb_binary resets things - ;; like /etc/apt/sources.list too, so doing that wouldn't avoid the - ;; problem that sometimes CONFIG must be used when you'd normally use - ;; PROPERTIES. And we can't really determine whether or not lb_chroot - ;; made a change, so it is not good for running inside the first - ;; argument to ON-CHANGE. - (%lbchroot ,dir) - (%lbbinary ,dir))))) diff --git a/src/property/mount.lisp b/src/property/mount.lisp index 53d1b2e..e0c3430 100644 --- a/src/property/mount.lisp +++ b/src/property/mount.lisp @@ -33,17 +33,17 @@ the mount is not actually active." "Unmount anything mounted at or below DIR. Not aware of shared subtrees, so you might need to use the --make-rslave -option to mount(1) first. For example, if you did 'mount --rbind /dev +option to mount(8) first. For example, if you did 'mount --rbind /dev chroot/dev' then unless you also execute 'mount --make-rslave chroot/dev', this property will empty /dev, breaking all kinds of things." (:desc #?"${dir} unmounted") (:hostattrs - ;; findmnt(1) & --recursive argument to umount(1) are from util-linux + ;; findmnt(8) & --recursive argument to umount(8) are from util-linux (os:required 'os:linux)) (:apply (with-change-if-changes-file-content ("/proc/mounts") ;; We used to call --make-rslave as we worked through, but for mounts - ;; which were *not* made using the --rbind option to mount(1) or similar, + ;; which were *not* made using the --rbind option to mount(8) or similar, ;; doing that can can get us into a state where we can unmount everything ;; we can see under DIR but the kernel will still consider the block ;; device to be in use. That's a bit much for this property to deal @@ -66,16 +66,11 @@ this property will empty /dev, breaking all kinds of things." ;; /proc, and the second can't be removed until the bind mount is ;; removed. (This situation arises because :CHROOT.FORK connections bind ;; mount the chroot on itself if it is not already a mount point.) - (let* ((dir (ensure-directory-pathname dir)) - (all-mounts - (mapcar #'ensure-directory-pathname - (runlines "findmnt" "-rn" "--output" "target"))) - (mounts-below (remove-if-not (rcurry #'subpathp dir) all-mounts)) - (sorted (sort mounts-below #'string< :key #'unix-namestring))) - (loop as next = (pop sorted) - while next - do (loop while (subpathp (car sorted) next) do (pop sorted)) - (mrun "umount" "--recursive" next)))))) + (loop with sorted = (all-mounts dir) + as next = (pop sorted) + while next + do (loop while (subpathp (car sorted) next) do (pop sorted)) + (mrun "umount" "--recursive" next))))) (defproplist unmounted-below-and-removed :posix (dir) "Unmount anything mounted at or below DIR and recursively delete dir." @@ -83,3 +78,39 @@ this property will empty /dev, breaking all kinds of things." (:check (not (remote-exists-p dir))) (unmounted-below dir) (cmd:single "rm" "-rf" dir)) + +(defun all-mounts (&optional (below #P"/")) + "Retrieve all mountpoints below BELOW, ordered lexicographically. +If BELOW is itself a mountpoint, it will be included as the first element. + +Uses findmnt(8), so Linux-specific." + (let* ((below (ensure-directory-pathname below)) + (all-mounts (mapcar #'ensure-directory-pathname + (runlines "findmnt" "-rn" "--output" "target"))) + (mounts-below (remove-if-not (rcurry #'subpathp below) all-mounts))) + (sort mounts-below #'string< :key #'unix-namestring))) + + +;;;; Utilities for :LISP properties + +(defparameter *standard-linux-vfs* '( +("-t" "proc" "-o" "nosuid,noexec,nodev" "proc" "/proc") +("-t" "sysfs" "-o" "nosuid,noexec,nodev,ro" "sys" "/sys") +("-t" "devtmpfs" "-o" "mode=0755,nosuid" "udev" "/dev") +("-t" "devpts" "-o" "mode=0620,gid=5,nosuid,noexec" "devpts" "/dev/pts") +("-t" "tmpfs" "-o" "mode=1777,nosuid,nodev" "shm" "/dev/shm") +("-t" "tmpfs" "-o" "mode=1777,strictatime,nodev,nosuid" "tmp" "/tmp"))) + +(defparameter *linux-efivars-vfs* + '("-t" "efivarfs" "-o" "nosuid,noexec,nodev" "efivarfs" + "/sys/firmware/efi/efivars") + "Arguments to mount(8) to mount the UEFI NVRAM. +After mounting /sys, mount this when /sys/firmware/efi/efivars exists.") + +(defun assert-devtmpfs-udev-/dev () + "On a system with the Linux kernel, assert that /dev has fstype devtmpfs." + (unless (and (mountpointp "/dev") + (string= "devtmpfs udev" + (stripln (run "findmnt" "-nro" "fstype,source" "/dev")))) + (failed-change + "/dev is not udev devtmpfs; support for other kinds of /dev unimplemented."))) diff --git a/src/property/network.lisp b/src/property/network.lisp index 59d34b0..0a59428 100644 --- a/src/property/network.lisp +++ b/src/property/network.lisp @@ -18,14 +18,61 @@ (in-package :consfigurator.property.network) (named-readtables:in-readtable :consfigurator) -(defprop static :posix (interface address &optional gateway &rest options) +(defprop aliases :posix (&rest aliases) + "Record other DNS names by which the host is known. For example, a mail +server might have aliases like imap.example.org and smtp.example.org, even +though its hostname is neither 'imap' nor 'smtp'." + (:desc (format nil "Has alias~1{~#[es~;~;es~]~} ~:*~{~A~^, ~}" aliases)) + (:hostattrs (apply #'pushnew-hostattrs + :aliases (delete (get-hostname) (flatten aliases) + :test #'string=)))) + +(defprop ipv4 :posix (&rest addresses) + "Record the host's public Internet IPv4 addresses. + +If you need to record other addresses in hostattrs, such as on a LAN, write a +similar property which pushes hostattrs identified by a non-keyword +symbol (unless your consfig deals only in hosts without public IP addresses, +in which case you can use this property)." + (:desc (format nil "Has public IPv4 ~{~A~^, ~}" addresses)) + (:hostattrs (apply #'pushnew-hostattrs :ipv4 (flatten addresses)))) + +(defprop ipv6 :posix (&rest addresses) + "Record the host's public Internet IPv6 addresses. + +If you need to record other addresses in hostattrs, such as on a LAN, write a +similar property which pushes hostattrs identified by a non-keyword +symbol (unless your consfig deals only in hosts without public IP addresses, +in which case you can use this property)." + (:desc (format nil "Has public IPv6 ~{~A~^, ~}" addresses)) + (:hostattrs (apply #'pushnew-hostattrs :ipv6 (flatten addresses)))) + +(defproplist clean-/etc/network/interfaces :posix () + "Empty /etc/network/interfaces in preparation for configuring interfaces using +/etc/network/interfaces.d. On fresh installs this property should not be +necessary, but it is useful for removing configuration inserted by your VPS +hosting provider, for example." + (:hostattrs (os:required 'os:debianlike)) + (file:has-content "/etc/network/interfaces" + ;; This is the contents of the file on fresh Debian "bullseye" installs -- + ;; the IPv4 loopback interface is no longer configured here. + '("# interfaces(5) file used by ifup(8) and ifdown(8)" + "# Include files from /etc/network/interfaces.d:" + "source /etc/network/interfaces.d/*"))) + +(defprop static :posix + (interface address &optional gateway netmask &rest options) "Configures an interface with a static IP address. OPTIONS is a list of even length of alternating keys and values." (:desc #?"Static interface ${interface} configured") + ;; We don't push ADDRESS as an :IPV4 hostattr because perhaps it is not an + ;; address on the public Internet. (:hostattrs (os:required 'os:debianlike)) (:apply (when gateway (setq options (list* "gateway" gateway options))) + (when netmask + (setq options (list* "netmask" netmask options))) (setq options (list* "address" address options)) (file:has-content (merge-pathnames (string->filename interface) @@ -35,3 +82,45 @@ OPTIONS is a list of even length of alternating keys and values." interface (if (find #\. address) "inet" "inet6")) (loop for (k v) on options by #'cddr collect (format nil " ~A ~A" k v)))))) + +;; Based on Propellor's Network.preserveStatic property. +(defprop preserve-static-once :posix (&optional interface &rest options) + "Writes configuration to bring up INTERFACE, statically, with the IP addresses +and routing configuration currently associated with the interface, assuming +that INTERFACE has already been brought up by other means, such as DHCP. +INTERFACE defaults to the interface of the default route. This property does +nothing if the interface configuration file already exists. OPTIONS is a list +of even length of alternating keys and values. + +IPv6 addresses are ignored, as it is assumed these use stateless configuration +of some form, which is best implemented using a property which does not query +the networking stack's current state like this one does." + (:hostattrs (os:required 'os:debianlike)) + (:apply + (let* ((default + (loop for line in (runlines "ip" "route" "list" "scope" "global") + when (string-prefix-p "default " line) + return (words line))) + (interface (or interface (fifth default))) + (gateway (and (string= (fifth default) interface) (third default))) + (file (merge-pathnames (string->filename interface) + #P"/etc/network/interfaces.d/"))) + (if (remote-exists-p file) + :no-change + (file:has-content file + (cons + (strcat "auto " interface) + (loop for line in (runlines "ip" "-o" "addr" "show" interface + "scope" "global") + for fields = (words line) + when (string= "inet" (third fields)) + collect (strcat "iface " interface " inet static") + and nconc (multiple-value-bind (addr nm) + (parse-cidr (fourth fields)) + (list (strcat " address " addr) + (strcat " netmask " nm))) + and if gateway collect (strcat " gateway " gateway) + end + and nconc + (loop for (k v) on options by #'cddr + collect (format nil " ~A ~A" k v))))))))) diff --git a/src/property/os.lisp b/src/property/os.lisp index cec032d..e9a9d8e 100644 --- a/src/property/os.lisp +++ b/src/property/os.lisp @@ -28,6 +28,12 @@ :documentation "Keyword whose name is Debian's name for this architecture, e.g. :AMD64"))) +(defprop linux :posix (architecture) + (:desc "Host kernel is Linux") + (:hostattrs (push-hostattrs :os (make-instance 'linux :arch architecture)))) + +(define-print-object-for-structlike linux) + (defclass debianlike (linux) ()) (defclass debian (debianlike) @@ -39,6 +45,9 @@ (defclass debian-stable (debian) ()) +(defun debian-stable (suite) + (make-instance 'debian-stable :suite suite)) + (defprop debian-stable :posix (suite architecture) (:desc (declare (ignore architecture)) @@ -51,6 +60,9 @@ (defclass debian-testing (debian) ((suite :initform "testing"))) +(defun debian-testing () + (make-instance 'debian-testing)) + (defprop debian-testing :posix (architecture) (:desc (declare (ignore architecture)) @@ -63,6 +75,9 @@ (defclass debian-unstable (debian) ((suite :initform "unstable"))) +(defun debian-unstable () + (make-instance 'debian-unstable)) + (defprop debian-unstable :posix (architecture) (:desc (declare (ignore architecture)) @@ -72,6 +87,12 @@ (make-instance 'debian-unstable :arch architecture)))) +(defclass debian-experimental (debian) + ((suite :initform "experimental"))) + +(defun debian-experimental () + (make-instance 'debian-experimental)) + (defmethod debian-architecture ((os linux)) "Return a string representing the architecture of OS as used by Debian." (string-downcase (symbol-name (linux-architecture os)))) @@ -138,8 +159,10 @@ Used in property :HOSTATTRS subroutines." (defun supports-arch-p (os arch) "Can binaries of type ARCH run on OS?" - (cl:typecase os - (debian (or (eq (linux-architecture os) arch) - (member arch (assoc (linux-architecture os) - '((:amd64 :i386) - (:i386 :amd64)))))))) + (let ((same (eq (linux-architecture os) arch))) + (cl:typecase os + (debian (or same + (member arch (assoc (linux-architecture os) + '((:amd64 :i386) + (:i386 :amd64)))))) + (linux same)))) diff --git a/src/property/periodic.lisp b/src/property/periodic.lisp new file mode 100644 index 0000000..6c0eab3 --- /dev/null +++ b/src/property/periodic.lisp @@ -0,0 +1,68 @@ +;;; 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.periodic) +(named-readtables:in-readtable :consfigurator) + +;; Use of this combinator requires always supplying a description, to reduce +;; the chance of accidental description clashes. +(defmacro at-most (period desc &rest propapps) + "Only attempt to apply PROPAPPS at most every PERIOD. Supported values for +PERIOD are :each-reboot, :hourly, :daily, :weekly, :monthly, :yearly. It is +assumed that a month has 30 days and a year has 365.25 days. + +The purpose of this combinator is to avoid applying properties that are +expensive to apply more often than it is useful to apply them. It is not for +scheduling tasks to occur at specific times or on specific days. + +The application of PROPAPPS is tracked by creating a flagfile on the remote +with a name computed from DESC. The mtime of this file is examined to +determine whether PERIOD has passed and another attempt to apply PROPAPPS +should be made. Thus, you must ensure that DESC is unique among the +descriptions of all the properties that will be applied to this host as this +user." + `(at-most* ,period ,desc + ,(if (cdr propapps) `(eseqprops ,@propapps) (car propapps)))) + +(define-function-property-combinator at-most* (period desc propapp) + (symbol-macrolet + ((flagfile (merge-pathnames + (string->filename desc) + (remote-consfigurator-cache-pathname "at-most/")))) + (destructuring-bind (psym . args) propapp + (:retprop :type (propapptype propapp) + :desc (lambda-ignoring-args desc) + :hostattrs (get psym 'hostattrs) + :check + (lambda-ignoring-args + (let ((now (get-universal-time)) + (mtime (nth-value 2 (remote-file-stats flagfile)))) + (and + mtime + (case period + (:each-reboot (< (remote-last-reboot) mtime)) + (:hourly (< now (+ #.(* 60 60) mtime))) + (:daily (< now (+ #.(* 24 60 60) mtime))) + (:weekly (< now (+ #.(* 7 24 60 60) mtime))) + (:monthly (< now (+ #.(* 30 24 60 60) mtime))) + (:yearly + (< now (+ #.(ceiling (* 365.25 24 60 60)) mtime))))))) + :apply (lambda-ignoring-args + (prog1 (propappapply propapp) + (file:containing-directory-exists flagfile) + (mrun "touch" flagfile))) + :args args)))) diff --git a/src/property/postfix.lisp b/src/property/postfix.lisp new file mode 100644 index 0000000..a33bbbd --- /dev/null +++ b/src/property/postfix.lisp @@ -0,0 +1,57 @@ +;;; 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.postfix) +(named-readtables:in-readtable :consfigurator) + +(defproplist installed :posix () + (:desc "Postfix installed") + (os:etypecase + (debianlike (apt:installed "postfix")))) + +(defproplist reloaded :posix () + (:desc "Postfix reloaded") + (service:reloaded "postfix")) + +(defprop main-configured :posix (&rest pairs) + "Set key--value pairs in /etc/postfix/main.cf." + (:desc (format nil "Postfix main.cf configured ~{~A=~A~^, ~}" pairs)) + (:apply + (if (eql :no-change + (apply #'file:contains-conf-equals "/etc/postfix/main.cf" pairs)) + :no-change + (reloaded)))) + +(define-function-property-combinator mapped-file + (propapp &optional (file (car (propappargs propapp)))) + "Apply PROPAPP, and if it makes a change, run postmap(1) on FILE, which +defaults to the first argument to PROPAPP." + (:retprop :type (propapptype propapp) + :desc (get (car propapp) 'desc) + :check (get (car propapp) 'check) + :hostattrs (get (car propapp) 'hostattrs) + :apply (lambda (&rest args) + (when-let ((f (get (car propapp) 'papply))) + (if (eql :no-change (apply f args)) + :no-change + (mrun "postmap" file)))) + :unapply + (lambda (&rest args) + (when-let ((f (get (car propapp) 'punapply))) + (apply f args)) + (file:does-not-exist (strcat (unix-namestring file) ".db"))) + :args (cdr propapp))) diff --git a/src/property/reboot.lisp b/src/property/reboot.lisp new file mode 100644 index 0000000..5728e0a --- /dev/null +++ b/src/property/reboot.lisp @@ -0,0 +1,33 @@ +;;; 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.reboot) +(named-readtables:in-readtable :consfigurator) + +(defprop %rebooted-at-end :posix () + (:apply (at-end + (lambda (result) + (declare (ignore result)) + (mrun "shutdown" "-r" "+1") + (inform t "*** SYSTEM REBOOT SCHEDULED, one minute delay ***"))))) + +(defproplist rebooted-at-end :posix () + "Schedule a reboot for the end of the current (sub)deployment. +The reboot is scheduled with a one minute delay to allow remote Lisp images to +return correct exit statuses to the root Lisp, for the root Lisp to have time +to download their output, etc." + (container:when-contained (:reboot) (%rebooted-at-end))) diff --git a/src/property/sbuild.lisp b/src/property/sbuild.lisp new file mode 100644 index 0000000..1dc464a --- /dev/null +++ b/src/property/sbuild.lisp @@ -0,0 +1,196 @@ +;;; Consfigurator -- Lisp declarative configuration management system + +;;; Copyright (C) 2016, 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.sbuild) +(named-readtables:in-readtable :consfigurator) + +(defproplist installed :posix () + "Ensure that sbuild and associated utilities are installed." + (:desc "sbuild and associated utilities installed") + (os:etypecase + (debianlike (apt:installed "piuparts" "autopkgtest" "lintian" "sbuild")))) + +(defproplist usable-by :posix (username) + "Add a user to the sbuild group in order to use sbuild." + (:desc #?"sbuild usable by ${username}") + (installed) + (user:has-groups username "sbuild")) + +(defproplist %sbuild-ccache-has-some-limits :posix () + "Set a default limit on the sbuild ccache, only if the ccache does not already +exist, so that the user can easily override this default." + (:desc #?"Default limits on sbuild ccache") + (:check (remote-exists-p "/var/cache/ccache-sbuild")) + (ccache:has-limits "/var/cache/ccache-sbuild" :max-size "2Gi")) + +(defpropspec built :lisp + (options properties + &aux (host + (make-child-host + :propspec + (append-propspecs + properties + (make-propspec + :systems nil + :propspec + '(desc "Build packages installed into chroot" + (os:etypecase + (debianlike (apt:installed "eatmydata" "ccache")))))))) + (os (get-hostattrs-car :os host)) + (suite (os:debian-suite os)) + (arch (os:debian-architecture os))) + "Build and configure a schroot for use with sbuild. +For convenience we set up several enhancements, such as ccache and eatmydata. +In the case of Debian, we assume you are building for Debian stretch or newer, +and we assume that you have sbuild 0.71.0 or later and, if overlays are +enabled, Linux 3.18 or newer. + +OPTIONS is a plist of keyword parameters: + + - :USE-CCACHE -- whether builds using the schroot should use ccache. ccache + is generally useful but breaks building some packages; this option allows + you to toggle it on and off for particular schroots. Defaults to t. + + - :CHROOT-OPTIONS -- passed on to CHROOT:OS-BOOTSTRAPPED-FOR, which see. + +PROPERTIES should specify, at a minimum, the operating system for the schroot. + +Example usage: + + (os:debian-stable \"bullseye\" :amd64) + (apt:uses-local-cacher) + (apt:mirror \"...\") + (sbuild:usable-by \"spwhitton\") + (schroot:overlays-in-tmpfs) + (sbuild:built. nil + (os:debian-unstable :amd64) + (sbuild:standard-debian-schroot) + (apt:uses-parent-proxy) + (apt:uses-parent-mirrors)) + +To take advantage of the piuparts and autopkgtest support, add to your +~/.sbuildrc: + + $piuparts_opts = [ + '--no-eatmydata', + '--schroot', + '%r-%a-sbuild', + '--log-level=info', + ]; + + $autopkgtest_root_args = \"\"; + $autopkgtest_opts = [\"--\", \"schroot\", \"%r-%a-sbuild\"];" + (:desc (format nil "Built sbuild schroot for ~A/~A" suite arch)) + (destructuring-bind + (&key (use-ccache t) chroot-options + &aux + (chroot-options (if (member :variant chroot-options) + chroot-options + (list* :variant "buildd" chroot-options))) + (chroot + (ensure-pathname + (format nil "~A-~A" suite arch) + :ensure-directory t :ensure-absolute t :defaults #P"/srv/chroot/")) + (desc (format nil "~A/~A autobuilder" suite arch)) + (conf (ensure-pathname + (format nil "~A-~A-sbuild-consfigurator" suite arch) + :ensure-absolute t :defaults #P"/etc/schroot/chroot.d/"))) + options + `(with-unapply + (installed) + + ;; ccache + ,@(and use-ccache '((%sbuild-ccache-has-some-limits) + (ccache:group-cache "sbuild"))) + (desc + "ccache mounted in sbuild schroots" + (file:contains-lines "/etc/schroot/sbuild/fstab" + "/var/cache/ccache-sbuild /var/cache/ccache-sbuild none rw,bind 0 0")) + ;; Script from <https://wiki.debian.org/sbuild>. + (file:has-content "/var/cache/ccache-sbuild/sbuild-setup" +#>EOF>#!/bin/sh + +export CCACHE_DIR=/var/cache/ccache-sbuild +export CCACHE_UMASK=002 +export CCACHE_COMPRESS=1 +unset CCACHE_HARDLINK +export PATH="/usr/lib/ccache:$PATH" + +exec "$@" +EOF :mode #o755) + + ;; schroot + (chroot:os-bootstrapped-for ,chroot-options ,chroot ,host) + (desc + ,(strcat "schroot configuration for " desc) + (file:contains-ini-settings + ,conf + ,@(mapcar + (curry #'cons (format nil "~A-~A-sbuild" suite arch)) + `(("description" ,desc) + ("groups" "root,sbuild") + ("root-groups" "root,sbuild") + ("profile" "sbuild") + ("type" "directory") + ("directory" ,(drop-trailing-slash (unix-namestring chroot))) + ,@(and (get-hostattrs-car 'schroot:uses-overlays) + `(("union-type" "overlay"))) + + ;; If we're building a sid chroot, add useful aliases. In order + ;; to avoid more than one schroot getting the same aliases, we + ;; only do this if the arch of the chroot equals the host arch. + ,@(and (string= suite "unstable") + (string= arch (os:debian-architecture + (get-hostattrs-car :os))) + `(("aliases" + ,(format + nil "~@{~A~^,~}" + "sid" + ;; If the user wants to build for experimental, they + ;; would use their sid chroot and sbuild's + ;; --extra-repository option to enable experimental. + "rc-buggy" + "experimental" + ;; We assume that building for UNRELEASED means + ;; building for unstable. + "UNRELEASED" + ;; The following is for dgit compatibility. + (strcat "UNRELEASED-" + (os:debian-architecture os) + "-sbuild"))))) + + ("command-prefix" + ,(if use-ccache + "/var/cache/ccache-sbuild/sbuild-setup,eatmydata" + "eatmydata")))))) + + ;; TODO We should kill any sessions still using the chroot before + ;; destroying it (as suggested by sbuild-destroychroot(8)). + :unapply + (unapply (chroot:os-bootstrapped-for ,chroot-options ,chroot ,host)) + (file:does-not-exist ,conf)))) + +;; Here we combine Propellor's Sbuild.osDebianStandard and Sbuild.update. +(defpropspec standard-debian-schroot :posix (&optional (period :weekly)) + "Properties that will be wanted in almost any Debian sbuild schroot, but not +in sbuild schroots for other operating systems. + +Includes replacing use of sbuild-update(1)." + (:desc "Standard Debian sbuild properties") + `(eseqprops (apt:standard-sources.list) + (periodic:at-most ,period "sbuild schroot updated" + (apt:updated) (apt:upgraded) (apt:autoremoved)))) diff --git a/src/property/schroot.lisp b/src/property/schroot.lisp new file mode 100644 index 0000000..2e6cb40 --- /dev/null +++ b/src/property/schroot.lisp @@ -0,0 +1,65 @@ +;;; Consfigurator -- Lisp declarative configuration management system + +;;; Copyright (C) 2016, 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.schroot) +(named-readtables:in-readtable :consfigurator) + +(defproplist installed :posix () + "Ensure that schroot(1) is installed." + (:desc "schroot(1) installed") + (os:etypecase + (debianlike (apt:installed "schroot")))) + +(defprop uses-overlays :posix () + "Indicate that schroots on a host should use 'union-type=overlay'. + +Adding this property does not actually ensure that the line +'union-type=overlay' is present in any schroot config files. See SBUILD:BUILT +for example usage, via SCHROOT:OVERLAYS-IN-TMPFS." + (:desc "schroots on host use union-type=overlay") + (:hostattrs (push-hostattrs 'uses-overlays t))) + +(defprop overlays-in-tmpfs :posix () + "Configure schroot(1) such that all schroots with 'union-type=overlay' in +their configuration will run their overlays in a tmpfs. Unapplicable, so if +the package you are working on FTBFS when overlays are in tmpfs, you can +toggle this off for a host, and then toggle it back on again later. + +Implicitly sets SCHROOT:USES-OVERLAYS. + +Shell script from <https://wiki.debian.org/sbuild>." + (:desc "schroot overlays in tmpfs") + (:hostattrs (push-hostattrs 'uses-overlays t)) + (:apply (file:has-content "/etc/schroot/setup.d/04tmpfs" +#>EOF>#!/bin/sh + +set -e + +. "$SETUP_DATA_DIR/common-data" +. "$SETUP_DATA_DIR/common-functions" +. "$SETUP_DATA_DIR/common-config" + + +if [ $STAGE = "setup-start" ]; then + mount -t tmpfs overlay /var/lib/schroot/union/overlay +elif [ $STAGE = "setup-recover" ]; then + mount -t tmpfs overlay /var/lib/schroot/union/overlay +elif [ $STAGE = "setup-stop" ]; then + umount -f /var/lib/schroot/union/overlay +fi +EOF :mode #o755)) + (:unapply (file:does-not-exist "/etc/schroot/setup.d/04tmpfs"))) diff --git a/src/property/service.lisp b/src/property/service.lisp index f88f9fd..bf6900c 100644 --- a/src/property/service.lisp +++ b/src/property/service.lisp @@ -48,6 +48,10 @@ not affect you." (os:etypecase (debianlike (%policy-rc.d)))) +(defun service (service action) + (unless (get-hostattrs-car :no-services) + (run :may-fail "service" service action))) + (defprop running :posix (service) "Attempt to start service using service(1). Assumes that if service(1) returns nonzero, it means the service was already @@ -55,11 +59,18 @@ running. If something more robust is required, use init system-specific properties." (:desc #?"Attempt to start ${service} has been made") (:apply - (unless (get-hostattrs-car :no-services) - (run :may-fail "service" service "start")) + (service service "start") ;; assume it was already running :no-change)) +(defprop restarted :posix (service) + (:desc #?"Attempt to restart ${service}") + (:apply (service service "restart"))) + +(defprop reloaded :posix (service) + (:desc #?"Attempt to reload ${service}") + (:apply (service service "reload"))) + (define-function-property-combinator without-starting-services (&rest propapps) "Apply PROPAPPS with SERVICE:NO-SERVICES temporarily in effect." (let ((propapp (if (cdr propapps) (apply #'eseqprops propapps) (car propapps)))) @@ -77,10 +88,9 @@ properties." ;; past. (SLEEP 1) is only approximately one second so ;; check that it's actually been a second. (loop do (sleep 1) until (> (get-universal-time) before)) - (unwind-protect-in-parent - (with-preserve-hostattrs - (push-hostattrs :no-services t) - (propappapply propapp)) + (unwind-protect (with-preserve-hostattrs + (push-hostattrs :no-services t) + (propappapply propapp)) (if already-exists ;; Check whether some property we applied set the ;; contents of /usr/sbin/policy-rc.d, in which case diff --git a/src/property/ssh.lisp b/src/property/ssh.lisp index df014c3..33d2088 100644 --- a/src/property/ssh.lisp +++ b/src/property/ssh.lisp @@ -28,21 +28,43 @@ (:unapply (apply #'file:lacks-lines ".ssh/authorized_keys" keys))) -(defprop %update-known-hosts :posix (file host &key short-hostname) +(defpropspec has-user-key :posix (dest public-key &key iden1) + "Installs an SSH keypair to DEST and DEST.pub." + ;; The original version of this property took a key type argument and + ;; defaulted DEST to ~/.ssh/id_TYPE, but FILE:HOST-SECRET-UPLOADED requires + ;; an absolute path because the remote HOME is not known at :HOSTATTRS time, + ;; and the same applies here, so the caller must supply DEST. In the + ;; FILE:SECRET-UPLOADED branch we could use a relative path, but we should + ;; not use an identical relative path for both IDEN2 and the destination + ;; when IDEN1 is a hostname, which it might be. + `(eseqprops (file:exists-with-content + ,(strcat (unix-namestring dest) ".pub") ,public-key) + ,(if iden1 + `(file:secret-uploaded ,iden1 ,dest ,dest) + `(file:host-secret-uploaded ,dest)))) + +(defprop %update-known-hosts :posix + (file host &key short-hostname (aliases t) (ips t) additional-names) (:apply (file:map-file-lines file (lambda (lines) - (loop with (identifier . keys) - = (sshd:get-host-public-keys host :short-hostname short-hostname) + (loop with host = (preprocess-host host) + with (identifier . keys) + = (sshd:get-host-public-keys + host :aliases aliases :short-hostname short-hostname + :ips ips :additional-names additional-names) + and hostname = (get-hostname host) 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=)) + for comma = (position #\, line) and space = (position #\Space line) + for index = (if comma (min comma space) space) + for line-hostname = (subseq line 0 index) + and line-key = (subseq line (1+ space)) + unless (string= line-hostname hostname) collect line into accum - and do (deletef keys line-key :test #'string=) + else if (member line-key keys :test #'string=) + collect (format nil "~A ~A" identifier line-key) into accum + and do (deletef keys line-key :test #'string=) finally (return (nconc accum @@ -50,34 +72,44 @@ collect (format nil "~A ~A" identifier key)))))))) (:unapply (destructuring-bind (identifier . keys) - (sshd:get-host-public-keys host :short-hostname short-hostname) + (sshd:get-host-public-keys + host :aliases aliases :short-hostname short-hostname + :ips ips :additional-names additional-names) (file:lacks-lines file (loop for key in keys collect (format nil "~A ~A" identifier key)))))) -(defproplist known-host :posix (host &key short-hostname) +(defproplist known-host :posix (host &key short-hostname (aliases t) + (ips t) additional-names) "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)) + (%update-known-hosts ".ssh/known_hosts" host + :aliases aliases :short-hostname short-hostname + :ips ips :additional-names additional-names)) -(defproplist globally-known-host :posix (host &key short-hostname) +(defproplist globally-known-host :posix (host &key short-hostname (aliases t) + (ips t) additional-names) "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)) + "/etc/ssh/ssh_known_hosts" host + :aliases aliases :short-hostname short-hostname + :ips ips :additional-names additional-names)) -(defproplist parent-is-globally-known-host :posix (&key short-hostname) +(defproplist parent-is-globally-known-host :posix + (&key short-hostname (aliases t) (ips t) additional-names) "Ensures that the SSH host keys of the parent host are stored in /etc/ssh/ssh_known_hosts; SHORT-HOSTNAME is as for SSH:GLOBALLY-KNOWN-HOST." (:desc "Parent host is globally known host to ssh client") (%update-known-hosts "/etc/ssh/ssh_known_hosts" (make-host :hostattrs (get-hostattrs :parent-hostattrs)) - :short-hostname short-hostname)) + :short-hostname short-hostname + :aliases aliases :ips ips :additional-names additional-names)) diff --git a/src/property/sshd.lisp b/src/property/sshd.lisp index b55dd0f..e4c1061 100644 --- a/src/property/sshd.lisp +++ b/src/property/sshd.lisp @@ -30,7 +30,10 @@ "Set key--value pairs in /etc/ssh/sshd_config." (:desc (format nil "sshd configured ~{~A ~A~^, ~}" pairs)) (:apply - (apply #'file:contains-conf-space "/etc/ssh/sshd_config" pairs))) + (if (eql :no-change + (apply #'file:contains-conf-space "/etc/ssh/sshd_config" pairs)) + :no-change + (service:reloaded "sshd")))) (defprop no-passwords :posix () "Configure SSH to disallow password logins. @@ -42,7 +45,7 @@ refuses to proceed if root has no authorized_keys." (unless (and (remote-exists-p ".ssh/authorized_keys") (plusp (length (readfile ".ssh/authorized_keys")))) (failed-change "root has no authorized_keys")) - (configured "PermitRootLogin" "without-password" + (configured "PermitRootLogin" "prohibit-password" "PasswordAuthentication" "no"))) @@ -64,10 +67,14 @@ The private key is obtained as an item of prerequisite data." (file:host-secret-uploaded (merge-pathnames (strcat "ssh_host_" type "_key") #P"/etc/ssh/"))) -(defun get-host-public-keys (host &key short-hostname) +(defun get-host-public-keys (host &key short-hostname (aliases t) + (ips t) additional-names) (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 "."))) + (hostname (get-hostname host)) + (short (and short-hostname (list (get-short-hostname host)))) + (aliases (and aliases (get-hostattrs :aliases host))) + (ips (and ips (append (get-hostattrs :ipv6 host) + (get-hostattrs :ipv4 host))))) + (cons (format nil "~{~A~^,~}" + (cons hostname (append aliases short ips additional-names))) (mapcar #'cdr (get-hostattrs 'host-public-key host))))) diff --git a/src/property/swap.lisp b/src/property/swap.lisp new file mode 100644 index 0000000..b3ab9c9 --- /dev/null +++ b/src/property/swap.lisp @@ -0,0 +1,42 @@ +;;; 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.swap) +(named-readtables:in-readtable :consfigurator) + +(defprop %swapfile-exists :posix (size location) + (:check + (declare (ignore size)) + (remote-exists-p location)) + (:apply + (mrun #?"umask 077; fallocate -l ${size} ${(unix-namestring location)}") + (mrun "mkswap" location)) + (:unapply + (declare (ignore size)) + (mrun :may-fail "swapoff" location) + (delete-remote-trees location))) + +(defproplist has-swap-file :posix + (size &optional (location #P"/var/lib/swapfile")) + "Add a swap file. SIZE is the -l argument to fallocate(1). +Current implementation assumes a non-CoW filesystem; see NOTES in swapon(8)." + (:desc #?"Has swapfile of size ${size}") + (:hostattrs (os:required 'os:linux)) + (on-apply-change (%swapfile-exists size location) + (cmd:single "swapon" location)) + (fstab:entries + (strcat (unix-namestring location) " swap swap defaults 0 0"))) diff --git a/src/property/systemd.lisp b/src/property/systemd.lisp new file mode 100644 index 0000000..b38ed5d --- /dev/null +++ b/src/property/systemd.lisp @@ -0,0 +1,52 @@ +;;; 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.systemd) +(named-readtables:in-readtable :consfigurator) + +(defprop started :posix (service) + (:desc #?"systemd service ${service} started") + (:check (zerop (mrun :for-exit "systemctl" "is-active" service))) + (:apply (mrun "systemctl" "start" service))) + +(defprop stopped :posix (service) + (:desc #?"systemd service ${service} stopped") + (:check (plusp (mrun :for-exit "systemctl" "is-active" service))) + (:apply (mrun "systemctl" "stop" service))) + +(defprop enabled :posix (service) + (:desc #?"systemd service ${service} enabled") + (:check (zerop (mrun :for-exit "systemctl" "is-enabled" service))) + (:apply (mrun "systemctl" "enable" service))) + +(defprop disabled :posix (service) + (:desc #?"systemd service ${service} disabled") + (:check + (let ((status (stripln (run :may-fail "systemctl" "is-enabled" service)))) + (or (string-prefix-p "linked" status) + (string-prefix-p "masked" status) + (memstring= + status + '("static" "disabled" "generated" "transient" "indirect"))))) + (:apply (mrun "systemctl" "disable" service))) + +(defprop masked :posix (service) + (:desc #?"systemd service ${service} masked") + (:check (string-prefix-p "masked" + (run :may-fail "systemctl" "is-enabled" service))) + (:apply (mrun "systemctl" "mask" service)) + (:unapply (mrun "systemctl" "unmask" service))) diff --git a/src/property/timezone.lisp b/src/property/timezone.lisp new file mode 100644 index 0000000..6474b3d --- /dev/null +++ b/src/property/timezone.lisp @@ -0,0 +1,37 @@ +;;; 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.timezone) +(named-readtables:in-readtable :consfigurator) + +(defproplist configured :posix (timezone) + "Set the system timezone. TIMEZONE is a relative path under /usr/share/zoneinfo, +e.g. \"Europe/London\"." + (:hostattrs (push-hostattrs 'timezone timezone)) + (os:etypecase + (linux + (file:symlinked :from "/etc/localtime" + :to (merge-pathnames timezone #P"/usr/share/zoneinfo/")))) + (os:typecase + (os:debianlike + (on-change (file:has-content "/etc/timezone" (list timezone)) + (apt:reconfigured "tzdata"))))) + +(defproplist configured-from-parent :posix () + "Sets the system timezone to match the parent host's." + (configured (or (get-parent-hostattrs-car 'timezone) + (failed-change "Parent has no known timezone")))) diff --git a/src/property/user.lisp b/src/property/user.lisp index 9f7f13b..be7ca36 100644 --- a/src/property/user.lisp +++ b/src/property/user.lisp @@ -41,6 +41,25 @@ Note that this uses getent(1) and so is not strictly POSIX-compatible." (assert-euid-root) (mrun "usermod" "-a" "-G" groups* username))) +(defparameter *desktop-groups* + '("audio" "cdrom" "dip" "floppy" "video" "plugdev" "netdev" "scanner" + "bluetooth" "debian-tor" "lpadmin") + "See the debconf template passwd/user-default-groups for package user-setup.") + +(defprop has-desktop-groups :posix (username) + "Add user to the secondary groups to which the OS installer normally adds the +default account it creates. Skips over groups which do not exist yet, pending +the installation of other software." + (:desc #?"${username} is in standard desktop groups") + (:hostattrs (os:required 'os:debianlike)) + (:apply + (let ((existing-groups + (loop for line in (lines (readfile "/etc/group")) + collect (car (split-string line :separator ":"))))) + (apply #'has-groups username (loop for group in *desktop-groups* + when (memstring= group existing-groups) + collect group))))) + (defprop has-login-shell :posix (username shell) "Ensures that USERNAME has login shell SHELL. Note that this uses getent(1) and so is not strictly POSIX-compatible." diff --git a/src/propspec.lisp b/src/propspec.lisp index 92a73e8..e1607af 100644 --- a/src/propspec.lisp +++ b/src/propspec.lisp @@ -20,32 +20,31 @@ ;;;; Property application specifications -(define-condition ambiguous-propspec (undefined-function) ()) - -(define-condition invalid-or-ambiguous-propspec (error) - ((original-error :initarg :error :reader original-error) - (broken-propspec :initarg :propspec :reader broken-propspec)) +(define-condition ambiguous-propspec (undefined-function) () (:report (lambda (condition stream) (format stream -"MACROEXPAND-ALL could not process the following propspec. This can happen -because the propspec is invalid, or because it contains references to -properties whose definitions have not been loaded. + "The function, property or property combinator ~A is undefined. Ensure that all functions, properties and property combinators used in a -propspec are defined before that propspec is processed by Consfigurator. +propspec are defined before that propspec is processed by Consfigurator." + (cell-error-name condition))))) -~S" (broken-propspec condition)) +(define-condition invalid-propspec (error) + ((original-error :initarg :error :reader original-error) + (broken-propspec :initarg :propspec :reader broken-propspec)) + (:report + (lambda (condition stream) + (format + stream + "The code walker could not process the following propspec.~%~%~S" + (broken-propspec condition)) (when (slot-boundp condition 'original-error) (format stream "~&~%The error from the code walker was:~%~%~A" (original-error condition)))))) -(defvar *replaced-propapps* nil - "Internal dynamic variable used in MAP-PROPSPEC-PROPAPPS.") - -(defun map-propspec-propapps - (function propspec &optional reconstruct env &aux *replaced-propapps*) +(defun map-propspec-propapps (function propspec &optional reconstruct env) "Map FUNCTION over each propapp occurring in PROPSPEC after macroexpansion. FUNCTION designates a pure function from propapps to propapps. PROPSPEC is a property application specification expression. @@ -54,87 +53,59 @@ RECONSTRUCT is a boolean flag indicating whether to return code which will evaluate to the resultant propspec rather than that propspec itself; if t, FUNCTION too should return code which will evaluate to propapps rather than propapps themselves. This is useful for when this function is called by -macros. ENV is the ENV argument to be passed along to MACROEXPAND-ALL. - -Note that this implementation will fail to map propapps appearing within the -arguments to properties in propapps, but that should not be needed." - ;; The work of this function cannot be implemented fully portably. See - ;; - ;; Michael Raskin. 2017. Writing a best-effort portable code walker in - ;; Common Lisp. In Proceedings of 10th European Lisp Symposium, Vrije - ;; Universiteit Brussel, Belgium, April 2017 (ELS2017). - ;; DOI: 10.5281/zenodo.3254669 - ;; - ;; for why. However, it can be implemented in terms of MACROEXPAND-ALL, - ;; whose semantics are conventionally well-understood and which is available - ;; in most implementations of Common Lisp (we use the - ;; trivial-macroexpand-all library to get at these implementations). - (labels - ((macrolet-and-expand (macrolets form) - (multiple-value-bind (expanded supported env-supported) - (trivial-macroexpand-all:macroexpand-all - `(macrolet ,macrolets ,form) env) - (unless supported - (error "Don't know how to MACROEXPAND-ALL in this Lisp.")) - (when (and env (not env-supported)) - (error "Don't know how to MACROEXPAND-ALL with env in this Lisp.")) - ;; At least SB-CLTL2:MACROEXPAND-ALL leaves the MACROLET in, so use - ;; CADDR to remove it again -- if that turns out to be - ;; implementation-specific, we can look for what we added and - ;; remove it. - ;; - ;; This is not just to avoid leaking our implementation to our - ;; callers -- if we call this function more than once with old - ;; calls to MACROLET left in, we can get stuck in infinite macro - ;; expansion loops. - (caddr expanded))) - (walk (tree) - (if (atom tree) - (if-let ((propapp (gethash tree *replaced-propapps*))) - (funcall function propapp) - (if (and reconstruct (symbolp tree)) `',tree tree)) - (let ((walked (mapcar #'walk tree))) - (if reconstruct (cons 'list walked) walked))))) - ;; First we need to find all the propapps, after macro expansion. - ;; Propapps contain the arguments to be passed to properties rather than - ;; expressions which will evaluate to those arguments, and some of these - ;; might be lists, which will look like invalid function calls to the code - ;; walker. So we macrolet every known property so that the code walker - ;; does not assume these arguments are to be evaluated as arguments to - ;; ordinary functions are. - ;; - ;; We can't just set up the macrolets to map FUNCTION over the propapp and - ;; return the result because if FUNCTION returns a propapp whose car is - ;; the same (as indeed it often will be) then we would get stuck in an - ;; infinite macro expansion. So we substitute back and forth for gensyms. - (let ((expanded - (handler-case - (macrolet-and-expand *known-property-macrolets* propspec) - (error (condition) - (error 'invalid-or-ambiguous-propspec :error condition - :propspec propspec))))) - ;; Now we use a dummy macro expansion pass to find any symbols without - ;; function or property definitions occurring in function call - ;; positions. These could potentially be properties whose definitions - ;; have not been loaded -- especially since we get called at compile - ;; time by PROPS -- and if so, we would return an incorrect result - ;; because the previous step will not have identified all the propapps - ;; in the propspec. So error out if we detect that situation. - (macrolet-and-expand - (loop for leaf in (delete-duplicates (flatten expanded)) - if (and (symbolp leaf) (not (isprop leaf))) - collect `(,leaf (&rest args) - (unless (or (fboundp ',leaf) (isprop ',leaf)) - (error 'ambiguous-propspec :name ',leaf)) - ;; return something which looks like an - ;; ordinary function call to the code walker, - ;; so that it will recurse into ARGS - (cons (gensym) args))) - expanded) - ;; Finally, substitute the mapped propapps back in to the propspec. - (let ((*replaced-propapps* - (alist-hash-table *replaced-propapps* :test 'eq))) - (walk expanded))))) +macros. ENV is passed along to AGNOSTIC-LIZARD:WALK-FORM. + +This implementation will fail to map propapps appearing within the arguments +to properties in propapps, but that should not be needed. It can very +occasionally give incorrect results due to limitations of the Common Lisp +standard with respect to code walking; see \"Pitfalls\" in the Consfigurator +manual." + (let* (replaced-propapps + ;; First we need to find all the propapps, after macro expansion. + ;; Propapps contain the arguments to be passed to properties rather + ;; than expressions which will evaluate to those arguments, and some + ;; of these might be lists, which will look like invalid function + ;; calls to the code walker. So we replace every known property so + ;; that the code walker does not assume these arguments are to be + ;; evaluated as arguments to ordinary functions are. + (expanded + (handler-case + (agnostic-lizard:walk-form + propspec env + :on-macroexpanded-form + (lambda (form env &aux (c (and (listp form) (car form)))) + (declare (ignore env)) + (cond ((and c (isprop c)) + (let ((gensym (gensym))) + (push (cons gensym form) replaced-propapps) + gensym)) + ;; We also look for any symbols without function or + ;; property definitions occurring in function call + ;; positions. These could potentially be properties + ;; whose definitions have not been loaded -- + ;; especially since we get called at compile time by + ;; PROPS -- and if so, we would return an incorrect + ;; result because the previous branch will not have + ;; identified all the propapps in the propspec. So + ;; error out if we detect that situation. + ((and c (not (fboundp c))) + (error 'ambiguous-propspec :name c)) + (t + form)))) + (ambiguous-propspec (c) (error c)) + (error (condition) + (error 'invalid-propspec :error condition :propspec propspec)))) + (replaced-propapps + (alist-hash-table replaced-propapps :test 'eq))) + ;; Finally, substitute the mapped propapps back in to the propspec. + (labels ((walk (tree) + (if (atom tree) + (if-let ((propapp (gethash tree replaced-propapps))) + (funcall function propapp) + (if (and reconstruct (symbolp tree)) `',tree tree)) + (let ((walked (mapcar #'walk tree))) + (if reconstruct (cons 'list walked) walked))))) + (walk expanded)))) (defmacro in-consfig (systems) "Sets the variable *CONSFIG* in the current package to SYSTEMS, or (SYSTEMS) @@ -207,7 +178,7 @@ PRINT-OBJECT.")) "Convert a property application specification expression into a property application specification proper by associating it with a list of ASDF systems." - (if (or systems-supplied-p (not propspec)) + (if systems-supplied-p (make-instance 'unpreprocessed-propspec :systems systems :propspec propspec) (make-instance 'unpreprocessed-propspec :propspec propspec))) diff --git a/src/util.lisp b/src/util.lisp index 8c45b30..f498352 100644 --- a/src/util.lisp +++ b/src/util.lisp @@ -41,7 +41,30 @@ (values)) (defun lines (text) - (split-string (stripln text) :separator '(#\Newline #\Return))) + (with-input-from-string (stream text) + (let (bolp buffer) + (flet ((reset () + (setq bolp t + buffer (make-array 0 :fill-pointer 0 + :element-type 'character)))) + ;; Split on either <CR>, <LF> or <CR><LF>; <LF><CR> would mean split + ;; with a blank line in between. Drop a single trailing blank line. + (loop initially (reset) + for char = (read-char stream nil nil) + if char + if (member char '(#\Return #\Newline) :test #'char=) + collect buffer + and do (reset) + (when (char= char #\Return) + (when-let ((next (peek-char nil stream nil nil))) + (when (char= next #\Newline) + (read-char stream)))) + else do (setq bolp nil) + (vector-push-extend char buffer) + end + else + unless bolp collect buffer end + and do (loop-finish)))))) (defun unlines (lines) (format nil "~{~A~%~}" lines)) @@ -165,13 +188,34 @@ one solution is to convert your property to a :LISP property." "Like PATHNAME-NAME but include any file extension." (and (pathname-name pathname) (namestring - (enough-pathname pathname (pathname-directory-pathname pathname))))) + (if (pathname-directory pathname) + (enough-pathname pathname (pathname-directory-pathname pathname)) + pathname)))) + +(defun directory-contents (pathname) + "Return the immediate contents of PATHNAME, a directory, without resolving +symlinks. Not suitable for use by :POSIX properties." + ;; On SBCL on Debian UIOP:*WILD-FILE-FOR-DIRECTORY* is #P"*.*". + (uiop:directory* + (merge-pathnames uiop:*wild-file-for-directory* + (ensure-directory-pathname pathname)))) + +(defun ensure-trailing-slash (namestring) + (if (string-suffix-p namestring "/") + namestring + (strcat namestring "/"))) (defun drop-trailing-slash (namestring) (if (string-suffix-p namestring "/") (subseq namestring 0 (1- (length namestring))) namestring)) +(defun reinit-structlike (class &rest slots) + (loop with object = (allocate-instance (find-class class)) + for (slot-name slot-value) on slots by #'cddr + do (setf (slot-value object slot-name) slot-value) + finally (return (reinitialize-instance object)))) + (defmacro quote-nonselfeval (x) (once-only (x) `(if (member (type-of ,x) '(cons symbol)) @@ -181,17 +225,16 @@ one solution is to convert your property to a :LISP property." "Define an implementation of PRINT-OBJECT for objects which are simple one-dimensional collections of values." `(defmethod print-object ((object ,class) stream) - (if *print-readably* + (if (and *print-readably* *read-eval*) (format stream "#.~S" - `(make-instance + `(reinit-structlike ',(type-of object) ;; Call CLASS-OF so that subclasses of CLASS are handled too. ,@(loop for slot in (closer-mop:class-slots (class-of object)) - for initargs = (closer-mop:slot-definition-initargs slot) - and slot-name = (closer-mop:slot-definition-name slot) + for slot-name = (closer-mop:slot-definition-name slot) when (slot-boundp object slot-name) - collect (car initargs) + collect `',slot-name and collect (quote-nonselfeval (slot-value object slot-name))))) (call-next-method)) @@ -209,9 +252,9 @@ one-dimensional collections of values." "Like UIOP:ESCAPE-SH-TOKEN, but also escape the empty string." (if (string= token "") (format s "\"\"") (uiop:escape-sh-token token s))) -(defun escape-sh-command (token &optional s) +(defun escape-sh-command (command &optional s) "Like UIOP:ESCAPE-SH-COMMAND, but also escape the empty string." - (uiop:escape-command token s 'escape-sh-token)) + (uiop:escape-command command s 'escape-sh-token)) (defun parse-username-from-id (output) "Where OUTPUT is the output of the id(1) command, extract the username." @@ -252,6 +295,107 @@ expansion as a starting point for your own DEFPACKAGE form for your consfig." ;; (push '(:use '#:cl '#:consfigurator) forms)) `(defpackage ,name ,@forms))) +(defmacro lambda-ignoring-args (&body body) + (multiple-value-bind (forms declarations) (parse-body body) + (with-gensyms (ignore) + `(lambda (&rest ,ignore) + (declare (ignore ,ignore) ,@declarations) + ,@forms)))) + +(defun parse-cidr (address-with-suffix) + (destructuring-bind (address cidr) + (split-string address-with-suffix :separator "/") + (unless cidr + (simple-program-error "~A is not in CIDR notation." + address-with-suffix)) + (values + address + (loop with cidr = (parse-integer cidr) + with type = (if (or (> cidr 32) (find #\: address)) 6 4) + with block-digits = (if (= type 4) 8 16) + repeat (if (= type 4) 4 8) + for digits = (min cidr block-digits) + do (decf cidr digits) + collect (parse-integer + (with-output-to-string (s) + (loop repeat digits do (princ #\1 s)) + (loop repeat (- block-digits digits) do (princ #\0 s))) + :radix 2) + into accum + finally (return (if (= type 4) + (format nil "~{~D~^.~}" accum) + (with-output-to-string (s) + (loop for blocks on accum + if (> (car blocks) 0) + do (format s "~X" (car blocks)) + and if (cdr blocks) do (princ #\: s) + end + else do (princ #\: s) + (loop-finish))))))))) + +(defun system (&rest args) + "Simple wrapper around system(3)." + (foreign-funcall + "system" :string (if (cdr args) + (escape-sh-command + (loop for arg in args + if (pathnamep arg) + collect (unix-namestring arg) + else collect arg)) + (car args)) + :int)) + +(define-constant +alphanum+ + "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" + :test #'string=) + +(defun mkfifo () + "Use mkfifo(3) to create a named pipe with a mkstemp(3)-like name." + (let* ((dir (drop-trailing-slash (or (getenv "TMPDIR") "/tmp"))) + (dir-ls (run-program + `("env" "LANG=C" "ls" "-lnd" ,dir) :output :string)) + (prefix (strcat dir "/tmp."))) + (unless (and (char= #\d (char dir-ls 0)) + (char-equal #\t (char dir-ls 9)) + (zerop (parse-integer (caddr (words dir-ls))))) + (error "~A is not a root-owned dir with the sticky bit set." dir)) + (flet ((mktemp () + ;; We need to generate a temporary name. We don't have to worry + ;; about race conditions as mkfifo(3) will fail if the file + ;; already exists. + (loop with result = (make-string (+ 6 (length prefix))) + initially (setf (subseq result 0 (length prefix)) prefix) + for i from (length prefix) below (length result) + do (setf (char result i) + (char +alphanum+ (random #.(length +alphanum+)))) + finally (return result))) + (mkfifo (temp) + (handler-case + (progn + #+sbcl (sb-posix:mkfifo temp #o600) + #-(or sbcl) + (unless (zerop + (foreign-funcall + "mkfifo" :string temp :unsigned-int #o600 :int)) + (error "mkfifo(3) failed!")) + t) + (serious-condition (c) + (if (or (file-exists-p temp) (directory-exists-p temp)) + nil + (signal c)))))) + (loop with *random-state* = (make-random-state t) + repeat 3 for temp = (mktemp) + when (mkfifo temp) return (pathname temp))))) + +(defmacro with-mkfifos ((&rest mkfifos) &body forms) + `(let ,(loop for mkfifo in mkfifos collect `(,mkfifo (mkfifo))) + (unwind-protect (progn ,@forms) + ,@(loop for mkfifo in mkfifos collect `(delete-file ,mkfifo))))) + +(defun write-to-mkfifo (object fifo) + (with-standard-io-syntax + (write object :stream fifo) (terpri fifo) (finish-output fifo))) + ;;;; Progress & debug printing @@ -363,29 +507,95 @@ previous output." ;;;; Forking utilities -(define-condition in-child-process () ()) - -(defmacro unwind-protect-in-parent (protected &body cleanup) - "Like UNWIND-PROTECT, but with a mechanism to cancel the execution of CLEANUP -in child processes resulting from calls to fork(2) during the execution of -PROTECTED. This means that CLEANUP won't get executed on both sides of the -fork, but only in the parent. - -For this to work, after fork(2), the child process must call -CANCEL-UNWIND-PROTECT-IN-PARENT-CLEANUP, which will affect all enclosing uses -of this macro." - (with-gensyms (cancelled) - `(let (,cancelled) - (unwind-protect - (handler-bind ((in-child-process - (lambda (c) (setq ,cancelled t) (signal c)))) - ,protected) - (unless ,cancelled ,@cleanup))))) - -(defun cancel-unwind-protect-in-parent-cleanup () - "Cancel the CLEANUP forms in all enclosing uses of UNWIND-PROTECT-IN-PARENT. -Should be called soon after fork(2) in child processes." - (signal 'in-child-process)) +;;; Use only implementation-specific fork, waitpid etc. calls to avoid thread +;;; woes. Things like chroot(2) and setuid(2), however, should be okay. + +(defun fork () + ;; Normalise any other implementations such that we signal an error if + ;; fork(2) returns -1, so caller doesn't have to check for that. + #+sbcl (sb-posix:fork)) + +(defun waitpid (pid options) + ;; Normalise any other implementations such that we always return (values + ;; PID EXIT-STATUS), as SB-POSIX:WAITPID does. + #+sbcl (sb-posix:waitpid pid options)) + +(defun wifexited (status) + #+sbcl (sb-posix:wifexited status)) + +(defun wexitstatus (status) + #+sbcl (sb-posix:wexitstatus status)) + +(defun setsid () + #+sbcl (sb-posix:setsid)) + +(defun umask (mode) + #+sbcl (sb-posix:umask mode)) + +(defmacro forked-progn (child-pid child-form &body parent-forms) + (with-gensyms (retval) + `(progn + #-(or sbcl) (error "Don't know how to safely fork(2) in this Lisp.") + (mapc-open-output-streams + #'force-output + *standard-output* *error-output* *debug-io* *terminal-io*) + (let ((,retval (fork))) + (if (zerop ,retval) + ;; We leave it to the caller to appropriately call CLOSE or + ;; CLEAR-INPUT on input streams shared with the parent, because + ;; at least SBCL's CLEAR-INPUT clears the OS buffer as well as + ;; Lisp's, potentially denying data to both sides of the fork. + ,child-form + (let ((,child-pid ,retval)) ,@parent-forms)))))) + +(define-condition skipped-properties () () + (:documentation + "There were failed changes, but instead of aborting, that particular property +application was instead skipped over, either due to the semantics of a +property combinator, or because the user elected to skip the property in the +interactive debugger.")) + +(defmacro with-deployment-report (&body forms) + (with-gensyms (failures) + `(let* (,failures + (result (handler-bind ((skipped-properties (lambda (c) + (declare (ignore c)) + (setq ,failures t)))) + ,@forms))) + (inform + t + (cond + ((eql :no-change result) + "No changes were made.") + (,failures + "There were failures while attempting to apply some properties.") + (t + "Changes were made without any reported failures.")))))) + +(defmacro with-backtrace-and-exit-code (&body forms) + (with-gensyms (failures) + `(let* (,failures + (result (handler-bind ((serious-condition + (lambda (c) + (trivial-backtrace:print-backtrace + c :output *error-output*) + (uiop:quit 3))) + (skipped-properties (lambda (c) + (declare (ignore c)) + (setq ,failures t)))) + ,@forms))) + (uiop:quit (cond ((eql :no-change result) 0) + (,failures 2) + (t 1)))))) + +(defmacro return-exit (exit &key on-failure) + `(values + nil + (case ,exit + (0 :no-change) + (1 nil) + (2 (signal 'skipped-properties) nil) + (t ,on-failure)))) (defun posix-login-environment (logname home) "Reset the environment after switching UID, or similar, in a :LISP connection. @@ -418,8 +628,37 @@ Does not currently establish a PAM session." `(let* ((,before (and (file-exists-p ,file) (read-file-string ,file))) (,data (and ,before (plusp (length ,before)) (safe-read-from-string ,before)))) - (unwind-protect-in-parent (progn ,@forms) + (unwind-protect (progn ,@forms) (with-open-file (stream ,file :direction :output :if-exists :supersede) (with-standard-io-syntax (prin1 ,data stream))))))) + + +;;;; Streams + +(defun stream->input-stream (stream) + (etypecase stream + (synonym-stream (stream->input-stream + (symbol-value (synonym-stream-symbol stream)))) + (two-way-stream (two-way-stream-input-stream stream)) + (stream (and (input-stream-p stream) stream)))) + +(defun mapc-open-input-streams (function &rest streams) + (dolist (stream streams streams) + (when-let ((input-stream (stream->input-stream stream))) + (when (open-stream-p input-stream) + (funcall function input-stream))))) + +(defun stream->output-stream (stream) + (etypecase stream + (synonym-stream (stream->output-stream + (symbol-value (synonym-stream-symbol stream)))) + (two-way-stream (two-way-stream-output-stream stream)) + (stream (and (output-stream-p stream) stream)))) + +(defun mapc-open-output-streams (function &rest streams) + (dolist (stream streams streams) + (when-let ((output-stream (stream->output-stream stream))) + (when (open-stream-p output-stream) + (funcall function output-stream))))) |