From 053e6d7495c3b44051074472713206ed0d3ce816 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 11 Feb 2018 14:35:58 -0400 Subject: add Propellor.Property.Atomic Added Propellor.Property.Atomic, which can make a non-atomic property that operates on a directory into an atomic property. Also has a generic version that could be used for things other than directories that can be updated atomically. (Inspired by Vaibhav Sagar's talk on Functional Devops in a Dysfunctional World at LCA 2018.) This commit was sponsored by Fernando Jimenez on Patreon. --- debian/changelog | 4 ++ propellor.cabal | 1 + src/Propellor/EnsureProperty.hs | 1 + src/Propellor/Property/Atomic.hs | 142 +++++++++++++++++++++++++++++++++++++++ 4 files changed, 148 insertions(+) create mode 100644 src/Propellor/Property/Atomic.hs diff --git a/debian/changelog b/debian/changelog index 178aabdb..d613401b 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,5 +1,9 @@ propellor (5.3.2) UNRELEASED; urgency=medium + * Added Propellor.Property.Atomic, which can make a non-atomic property + that operates on a directory into an atomic property. + (Inspired by Vaibhav Sagar's talk on Functional Devops in a + Dysfunctional World at LCA 2018.) * Added Git.pulled. -- Joey Hess Sun, 11 Feb 2018 11:58:04 -0400 diff --git a/propellor.cabal b/propellor.cabal index 4f90c49c..48d34b47 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -89,6 +89,7 @@ Library Propellor.Property.Apache Propellor.Property.Apt Propellor.Property.Apt.PPA + Propellor.Property.Atomic Propellor.Property.Attic Propellor.Property.Bootstrap Propellor.Property.Borg diff --git a/src/Propellor/EnsureProperty.hs b/src/Propellor/EnsureProperty.hs index ad74bfa8..5a07107c 100644 --- a/src/Propellor/EnsureProperty.hs +++ b/src/Propellor/EnsureProperty.hs @@ -8,6 +8,7 @@ module Propellor.EnsureProperty ( ensureProperty , property' , OuterMetaTypesWitness(..) + , Cannot_ensureProperty_WithInfo ) where import Propellor.Types diff --git a/src/Propellor/Property/Atomic.hs b/src/Propellor/Property/Atomic.hs new file mode 100644 index 00000000..096e51cb --- /dev/null +++ b/src/Propellor/Property/Atomic.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} + +module Propellor.Property.Atomic ( + atomicDirUpdate, + atomicUpdate, + atomicDirSync +) where + +import Propellor.Base +import Propellor.Types.Core +import Propellor.Types.MetaTypes +import Propellor.EnsureProperty +import Propellor.Property.File +import Propellor.Property.Rsync (syncDir) + +import System.Posix.Files + +-- | A pair of resources, one active and one inactive, which can swap +-- positions atomically. +data AtomicResourcePair a = AtomicResourcePair + { activeAtomicResource :: a + , inactiveAtomicResource :: a + } + +flipAtomicResourcePair :: AtomicResourcePair a -> AtomicResourcePair a +flipAtomicResourcePair a = AtomicResourcePair + { activeAtomicResource = inactiveAtomicResource a + , inactiveAtomicResource = activeAtomicResource a + } + +-- | Action that activates the inactiveAtomicResource, and deactivates +-- the activeAtomicResource. This action must be fully atomic. +type SwapAtomicResourcePair a = AtomicResourcePair a -> Propellor () + +-- | Checks which of the pair of resources is currently active and +-- which is inactive, and puts them in the correct poisition in +-- the AtomicResourcePair. +type CheckAtomicResourcePair a = AtomicResourcePair a -> Propellor (AtomicResourcePair a) + +-- | Makes a non-atomic Property be atomic, by applying it to the +-- inactiveAtomicResource, and if it was successful, +-- atomically activating that resource. +atomicUpdate + -- Constriaints inherited from ensureProperty. + :: ( Cannot_ensureProperty_WithInfo t ~ 'True + , (Targets t `NotSuperset` Targets t) ~ 'CanCombine + ) + => SingI t + => AtomicResourcePair a + -> CheckAtomicResourcePair a + -> SwapAtomicResourcePair a + -> (a -> Property (MetaTypes t)) + -> Property (MetaTypes t) +atomicUpdate rbase rcheck rswap mkp = property' d $ \w -> do + r <- rcheck rbase + res <- ensureProperty w $ mkp $ inactiveAtomicResource r + case res of + FailedChange -> return FailedChange + NoChange -> return NoChange + MadeChange -> do + rswap r + return res + where + d = getDesc $ mkp $ activeAtomicResource rbase + +-- | Applies a Property to a directory such that the directory is updated +-- fully atomically; there is no point in time in which the directory will +-- be in an inconsistent state. +-- +-- For example, git repositories are not usually updated atomically, +-- and so while the repository is being updated, the files in it can be a +-- mixture of two different versions, which could cause unexpected +-- behavior to consumers. To avoid such problems: +-- +-- > & atomicDirUpdate "/srv/web/example.com" +-- > (\d -> Git.pulled "joey" "http://.." d Nothing) +-- +-- This operates by making a second copy of the directory, and passing it +-- to the Property, which can make whatever changes it needs to that copy, +-- non-atomically. After the Property successfully makes a change, the +-- copy is swapped into place, fully atomically. +-- +-- This necessarily uses double the disk space of the directory, since its +-- copy is preserved. Note that the directory must not already exist, +-- or symlink creation will fail. +-- +-- The parent directory will actually contain three children, a symlink +-- with the name of the directory itself, and two copies of the directory, +-- with names suffixed with ".1" and ".2" +atomicDirUpdate + -- Constriaints inherited from ensureProperty. + :: ( Cannot_ensureProperty_WithInfo t ~ 'True + , (Targets t `NotSuperset` Targets t) ~ 'CanCombine + ) + => SingI t + => FilePath + -> (FilePath -> Property (MetaTypes t)) + -> Property (MetaTypes t) +atomicDirUpdate d = atomicUpdate (mkDirLink d) (checkDirLink d) (swapDirLink d) + +mkDirLink :: FilePath -> AtomicResourcePair FilePath +mkDirLink d = AtomicResourcePair + { activeAtomicResource = addext ".1" + , inactiveAtomicResource = addext ".2" + } + where + addext = addExtension (dropTrailingPathSeparator d) + +inactiveLinkTarget :: AtomicResourcePair FilePath -> FilePath +inactiveLinkTarget = takeFileName . inactiveAtomicResource + +swapDirLink :: FilePath -> SwapAtomicResourcePair FilePath +swapDirLink d rp = liftIO $ createSymbolicLink (inactiveLinkTarget rp) + `viaStableTmp` d + +checkDirLink :: FilePath -> CheckAtomicResourcePair FilePath +checkDirLink d rp = liftIO $ do + v <- tryIO $ readSymbolicLink d + return $ case v of + Right t | t == inactiveLinkTarget rp -> + flipAtomicResourcePair rp + _ -> rp + +-- | This can optionally be used after atomicDirUpdate to rsync the changes +-- that were made over to the other copy of the directory. It's not +-- necessary to use this, but it can improve efficiency. +-- +-- For example: +-- +-- > & atomicDirUpdate "/srv/web/example.com" +-- > (\d -> Git.pulled "joey" "http://.." d Nothing) +-- > `onChange` atomicDirSync "/srv/web/example.com" +-- +-- Using atomicDirSync in the above example lets git only download +-- the changes once, rather than the same changes being downloaded a second +-- time to update the other copy of the directory the next time propellor +-- runs. +atomicDirSync :: FilePath -> Property (DebianLike + ArchLinux) +atomicDirSync d = syncDir (activeAtomicResource rp) (inactiveAtomicResource rp) + where + rp = mkDirLink d -- cgit v1.2.3