{-# 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
{ forall a. AtomicResourcePair a -> a
activeAtomicResource :: a
, forall a. AtomicResourcePair a -> a
inactiveAtomicResource :: a
}
flipAtomicResourcePair :: AtomicResourcePair a -> AtomicResourcePair a
flipAtomicResourcePair :: forall a. AtomicResourcePair a -> AtomicResourcePair a
flipAtomicResourcePair AtomicResourcePair a
a = AtomicResourcePair
{ activeAtomicResource :: a
activeAtomicResource = forall a. AtomicResourcePair a -> a
inactiveAtomicResource AtomicResourcePair a
a
, inactiveAtomicResource :: a
inactiveAtomicResource = forall a. AtomicResourcePair a -> a
activeAtomicResource AtomicResourcePair a
a
}
type SwapAtomicResourcePair a = AtomicResourcePair a -> Propellor Bool
type CheckAtomicResourcePair a = AtomicResourcePair a -> Propellor (AtomicResourcePair a)
atomicUpdate
:: EnsurePropertyAllowed t t
=> SingI t
=> AtomicResourcePair a
-> CheckAtomicResourcePair a
-> SwapAtomicResourcePair a
-> (a -> Property (MetaTypes t))
-> Property (MetaTypes t)
atomicUpdate :: forall (t :: [MetaType]) a.
(EnsurePropertyAllowed t t, SingI t) =>
AtomicResourcePair a
-> CheckAtomicResourcePair a
-> SwapAtomicResourcePair a
-> (a -> Property (MetaTypes t))
-> Property (MetaTypes t)
atomicUpdate AtomicResourcePair a
rbase CheckAtomicResourcePair a
rcheck SwapAtomicResourcePair a
rswap a -> Property (MetaTypes t)
mkp = forall {k} (metatypes :: k).
SingI metatypes =>
FilePath
-> (OuterMetaTypesWitness metatypes -> Propellor Result)
-> Property (MetaTypes metatypes)
property' FilePath
d forall a b. (a -> b) -> a -> b
$ \OuterMetaTypesWitness t
w -> do
AtomicResourcePair a
r <- CheckAtomicResourcePair a
rcheck AtomicResourcePair a
rbase
Result
res <- forall (inner :: [MetaType]) (outer :: [MetaType]).
EnsurePropertyAllowed inner outer =>
OuterMetaTypesWitness outer
-> Property (MetaTypes inner) -> Propellor Result
ensureProperty OuterMetaTypesWitness t
w forall a b. (a -> b) -> a -> b
$ a -> Property (MetaTypes t)
mkp forall a b. (a -> b) -> a -> b
$ forall a. AtomicResourcePair a -> a
inactiveAtomicResource AtomicResourcePair a
r
case Result
res of
Result
FailedChange -> forall (m :: * -> *) a. Monad m => a -> m a
return Result
FailedChange
Result
NoChange -> forall (m :: * -> *) a. Monad m => a -> m a
return Result
NoChange
Result
MadeChange -> do
Bool
ok <- SwapAtomicResourcePair a
rswap AtomicResourcePair a
r
if Bool
ok
then forall (m :: * -> *) a. Monad m => a -> m a
return Result
res
else forall (m :: * -> *) a. Monad m => a -> m a
return Result
FailedChange
where
d :: FilePath
d = forall p. IsProp p => p -> FilePath
getDesc forall a b. (a -> b) -> a -> b
$ a -> Property (MetaTypes t)
mkp forall a b. (a -> b) -> a -> b
$ forall a. AtomicResourcePair a -> a
activeAtomicResource AtomicResourcePair a
rbase
atomicDirUpdate
:: EnsurePropertyAllowed t t
=> SingI t
=> FilePath
-> (FilePath -> Property (MetaTypes t))
-> Property (MetaTypes t)
atomicDirUpdate :: forall (t :: [MetaType]).
(EnsurePropertyAllowed t t, SingI t) =>
FilePath
-> (FilePath -> Property (MetaTypes t)) -> Property (MetaTypes t)
atomicDirUpdate FilePath
d = forall (t :: [MetaType]) a.
(EnsurePropertyAllowed t t, SingI t) =>
AtomicResourcePair a
-> CheckAtomicResourcePair a
-> SwapAtomicResourcePair a
-> (a -> Property (MetaTypes t))
-> Property (MetaTypes t)
atomicUpdate (FilePath -> AtomicResourcePair FilePath
mkDirLink FilePath
d) (FilePath -> CheckAtomicResourcePair FilePath
checkDirLink FilePath
d) (FilePath -> SwapAtomicResourcePair FilePath
swapDirLink FilePath
d)
mkDirLink :: FilePath -> AtomicResourcePair FilePath
mkDirLink :: FilePath -> AtomicResourcePair FilePath
mkDirLink FilePath
d = AtomicResourcePair
{ activeAtomicResource :: FilePath
activeAtomicResource = FilePath -> FilePath
addext FilePath
".1"
, inactiveAtomicResource :: FilePath
inactiveAtomicResource = FilePath -> FilePath
addext FilePath
".2"
}
where
addext :: FilePath -> FilePath
addext = FilePath -> FilePath -> FilePath
addExtension (FilePath -> FilePath
dropTrailingPathSeparator FilePath
d)
inactiveLinkTarget :: AtomicResourcePair FilePath -> FilePath
inactiveLinkTarget :: AtomicResourcePair FilePath -> FilePath
inactiveLinkTarget = FilePath -> FilePath
takeFileName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. AtomicResourcePair a -> a
inactiveAtomicResource
swapDirLink :: FilePath -> SwapAtomicResourcePair FilePath
swapDirLink :: FilePath -> SwapAtomicResourcePair FilePath
swapDirLink FilePath
d AtomicResourcePair FilePath
rp = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
Either IOException ()
v <- forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either IOException a)
tryIO forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ()
createSymbolicLink (AtomicResourcePair FilePath -> FilePath
inactiveLinkTarget AtomicResourcePair FilePath
rp)
forall (m :: * -> *).
(MonadMask m, MonadIO m) =>
(FilePath -> m ()) -> FilePath -> m ()
`viaStableTmp` FilePath
d
case Either IOException ()
v of
Right () -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
Left IOException
e -> do
forall (m :: * -> *). MonadIO m => FilePath -> m ()
warningMessage forall a b. (a -> b) -> a -> b
$ FilePath
"Unable to update symlink at " forall a. [a] -> [a] -> [a]
++ FilePath
d forall a. [a] -> [a] -> [a]
++ FilePath
" (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show IOException
e forall a. [a] -> [a] -> [a]
++ FilePath
")"
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
checkDirLink :: FilePath -> CheckAtomicResourcePair FilePath
checkDirLink :: FilePath -> CheckAtomicResourcePair FilePath
checkDirLink FilePath
d AtomicResourcePair FilePath
rp = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
Either IOException FilePath
v <- forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either IOException a)
tryIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
readSymbolicLink FilePath
d
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Either IOException FilePath
v of
Right FilePath
t | FilePath
t forall a. Eq a => a -> a -> Bool
== AtomicResourcePair FilePath -> FilePath
inactiveLinkTarget AtomicResourcePair FilePath
rp ->
forall a. AtomicResourcePair a -> AtomicResourcePair a
flipAtomicResourcePair AtomicResourcePair FilePath
rp
Either IOException FilePath
_ -> AtomicResourcePair FilePath
rp
atomicDirSync :: FilePath -> Property (DebianLike + ArchLinux)
atomicDirSync :: FilePath -> Property (DebianLike + ArchLinux)
atomicDirSync FilePath
d = FilePath -> FilePath -> Property (DebianLike + ArchLinux)
syncDir (forall a. AtomicResourcePair a -> a
activeAtomicResource AtomicResourcePair FilePath
rp) (forall a. AtomicResourcePair a -> a
inactiveAtomicResource AtomicResourcePair FilePath
rp)
where
rp :: AtomicResourcePair FilePath
rp = FilePath -> AtomicResourcePair FilePath
mkDirLink FilePath
d