add REAPPLIED and PERIODIC:REAPPLIED-AT-MOST property combinators

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

5 files changed, 37 insertions, 8 deletions

diff --git a/doc/news.rst b/doc/news.rst
index c49b4a2..c70afa9 100644
--- a/doc/news.rst
+++ b/doc/news.rst
@@ -23,6 +23,11 @@ In summary, you should always be able to upgrade to a release which only
 increments ``patch``, but if either of the other two components have changed,
 you should review this document and see if your consfig needs updating.
 
+1.3.1 (unreleased)
+------------------
+
+- Add REAPPLIED and PERIODIC:REAPPLIED-AT-MOST property combinators.
+
 1.3.0 (2023-03-17)
 ------------------
 
diff --git a/src/combinator.lisp b/src/combinator.lisp
index 0b51bd7..b720b67 100644
--- a/src/combinator.lisp
+++ b/src/combinator.lisp
@@ -261,6 +261,16 @@ property instead of applying it."
               :unapply (get psym 'papply)
               :args args)))
 
+(define-function-property-combinator reapplied (propapp)
+  (:retprop :type (proptype (car propapp))
+            :lambda (proplambda (car propapp))
+            :desc (lambda-ignoring-args
+                    (strcat "Reapplied: " (propapp-desc propapp)))
+            :hostattrs (lambda-ignoring-args (propapp-attrs propapp))
+            :apply (lambda-ignoring-args
+                     (unapply-propapp propapp)
+                     (apply-propapp propapp))))
+
 (define-function-property-combinator desc (desc propapp)
   (:retprop :type (propapp-type propapp)
             :desc (lambda () desc)
diff --git a/src/package.lisp b/src/package.lisp
index 8b8228d..360961e 100644
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -262,6 +262,7 @@
            #:silent-seqprops
            #:unapply
            #:unapplied
+           #:reapplied
            #:desc
            #:on-change
            #:on-apply-change
@@ -495,7 +496,8 @@
 
   (package :consfigurator.property.periodic
            (:local-nicknames (#:file  #:consfigurator.property.file))
-           (:export #:at-most))
+           (:export #:at-most
+                    #:reapplied-at-most))
 
   (package :consfigurator.property.mount
            (:local-nicknames (#:os    #:consfigurator.property.os)
diff --git a/src/property/periodic.lisp b/src/property/periodic.lisp
index 03b0b6b..0bf7851 100644
--- a/src/property/periodic.lisp
+++ b/src/property/periodic.lisp
@@ -67,3 +67,16 @@ user."
                            (file:containing-directory-exists flagfile)
                            (mrun "touch" flagfile)))
                 :args args))))
+
+(defmacro reapplied-at-most (period desc &body propapps)
+  "Apply PROPAPPS; only every PERIOD, also unapply them before applying them.
+
+This is useful to periodically redo the application of PROPAPPS.
+For example, you can use this to occasionally completely rebuild a
+CHROOT:OS-BOOTSTRAPPED chroot instead of only ever updating its contents.
+
+PERIOD and DESC are as for PERIODIC:AT-MOST, which see."
+  (let ((propapp (if (cdr propapps) `(eseqprops ,@propapps) (car propapps))))
+    `(eseqprops (desc ,(format nil "Unapplied ~(~A~): ~A" period desc)
+                      (at-most* ,period ,desc (unapplied ,propapp)))
+                (desc ,desc ,propapp))))
diff --git a/src/property/sbuild.lisp b/src/property/sbuild.lisp
index 9a0eca6..90f6823 100644
--- a/src/property/sbuild.lisp
+++ b/src/property/sbuild.lisp
@@ -76,13 +76,12 @@ Example usage:
     (apt:mirrors \"...\")
     (sbuild:usable-by \"spwhitton\")
     (schroot:overlays-in-tmpfs)
-    (periodic:at-most :monthly \"sbuild sid schroot rebuilt\"
-      (unapplied (sbuild:built. nil (os:debian-unstable :amd64))))
-    (sbuild:built. nil
-      (os:debian-unstable :amd64)
-      (sbuild:standard-debian-schroot)
-      (apt:uses-parent-proxy)
-      (apt:uses-parent-mirrors))
+    (periodic:reapplied-at-most :monthly \"sbuild sid schroot (re)built\"
+      (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: