{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
module Propellor.Property.Atomic (
atomicDirUpdate,
atomicDirSync,
atomicUpdate,
AtomicResourcePair(..),
flipAtomicResourcePair,
SwapAtomicResourcePair,
CheckAtomicResourcePair,
) 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
data AtomicResourcePair a = AtomicResourcePair
{ activeAtomicResource :: a
, inactiveAtomicResource :: a
}
flipAtomicResourcePair :: AtomicResourcePair a -> AtomicResourcePair a
flipAtomicResourcePair a = AtomicResourcePair
{ activeAtomicResource = inactiveAtomicResource a
, inactiveAtomicResource = activeAtomicResource a
}
type SwapAtomicResourcePair a = AtomicResourcePair a -> Propellor Bool
type CheckAtomicResourcePair a = AtomicResourcePair a -> Propellor (AtomicResourcePair a)
atomicUpdate
:: ( 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
ok <- rswap r
if ok
then return res
else return FailedChange
where
d = getDesc $ mkp $ activeAtomicResource rbase
atomicDirUpdate
:: ( 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 $ do
v <- tryIO $ createSymbolicLink (inactiveLinkTarget rp)
`viaStableTmp` d
case v of
Right () -> return True
Left e -> do
warningMessage $ "Unable to update symlink at " ++ d ++ " (" ++ show e ++ ")"
return False
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
atomicDirSync :: FilePath -> Property (DebianLike + ArchLinux)
atomicDirSync d = syncDir (activeAtomicResource rp) (inactiveAtomicResource rp)
where
rp = mkDirLink d