From 5f69000e489b3840e07925a5b2f21ce3bc8adbd6 Mon Sep 17 00:00:00 2001
From: Sean Whitton <spwhitton@spwhitton.name>
Date: Tue, 20 Jul 2021 14:30:15 -0700
Subject: add IMAGE-DUMPED and CRON:RUNS-CONSFIGURATOR

Signed-off-by: Sean Whitton <spwhitton@spwhitton.name>
---
 src/image.lisp         | 33 +++++++++++++++++++++++++++++++++
 src/package.lisp       |  6 +++++-
 src/property/cron.lisp | 29 +++++++++++++++++++++++++++++
 3 files changed, 67 insertions(+), 1 deletion(-)

(limited to 'src')

diff --git a/src/image.lisp b/src/image.lisp
index 70781a0..e5ce8f5 100644
--- a/src/image.lisp
+++ b/src/image.lisp
@@ -119,6 +119,39 @@ directory containing FILENAME is locked down."
     (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
diff --git a/src/package.lisp b/src/package.lisp
index 668b9e1..32056c4 100644
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -19,6 +19,7 @@
                           #:unix-namestring
                           #:pathname-directory-pathname
                           #:pathname-parent-directory-pathname
+                          #:resolve-symlinks
                           #:with-temporary-file
                           #:ensure-directory-pathname
                           #:ensure-pathname
@@ -55,6 +56,7 @@
            #:unix-namestring
            #:pathname-directory-pathname
            #:pathname-parent-directory-pathname
+           #:resolve-symlinks
            #:with-temporary-file
            #:ensure-directory-pathname
            #:ensure-pathname
@@ -292,6 +294,7 @@
            ;; image.lisp
            #:eval-in-grandchild
            #:dump-consfigurator-in-grandchild
+           #:image-dumped
            #:asdf-requirements-for-host-and-features
            #:request-asdf-requirements
            #:continue-deploy*-program))
@@ -723,7 +726,8 @@
                     (#:os        #:consfigurator.property.os)
                     (#:file      #:consfigurator.property.file))
   (:export #:system-job
-           #:nice-system-job))
+           #:nice-system-job
+           #:runs-consfigurator))
 
 (defpackage :consfigurator.property.lets-encrypt
   (:use #:cl #:alexandria #:consfigurator)
diff --git a/src/property/cron.lisp b/src/property/cron.lisp
index d486ed9..3076967 100644
--- a/src/property/cron.lisp
+++ b/src/property/cron.lisp
@@ -76,3 +76,32 @@ The output of the cronjob will be mailed only if the job exits nonzero."
   (: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"))
-- 
cgit v1.2.3