summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--debian/changelog4
-rw-r--r--propellor.cabal1
-rw-r--r--src/Propellor/EnsureProperty.hs1
-rw-r--r--src/Propellor/Property/Atomic.hs142
4 files changed, 148 insertions, 0 deletions
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 <id@joeyh.name> 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