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