diff options
| -rw-r--r-- | consfigurator.asd | 1 | ||||
| -rw-r--r-- | src/connection.lisp | 19 | ||||
| -rw-r--r-- | src/data.lisp | 5 | ||||
| -rw-r--r-- | src/package.lisp | 7 | ||||
| -rw-r--r-- | src/property/periodic.lisp | 68 |
5 files changed, 96 insertions, 4 deletions
diff --git a/consfigurator.asd b/consfigurator.asd index 87f4951..8baa2c0 100644 --- a/consfigurator.asd +++ b/consfigurator.asd @@ -32,6 +32,7 @@ (: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") diff --git a/src/connection.lisp b/src/connection.lisp index fc4575f..1920bda 100644 --- a/src/connection.lisp +++ b/src/connection.lisp @@ -500,6 +500,25 @@ specification of POSIX ls(1))." (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 *connection* diff --git a/src/data.lisp b/src/data.lisp index 814396b..173f7d0 100644 --- a/src/data.lisp +++ b/src/data.lisp @@ -434,10 +434,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 diff --git a/src/package.lisp b/src/package.lisp index 27a5a90..bdb3693 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -128,6 +128,8 @@ #:test #:remote-exists-p #:remote-file-stats + #:remote-last-reboot + #:remote-consfigurator-cache-pathname #:delete-remote-trees #:readfile #:writefile @@ -326,6 +328,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) 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)))) |