{-# 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

-- | A pair of resources, one active and one inactive, which can swap
-- positions atomically.
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
	}

-- | Action that activates the inactiveAtomicResource, and deactivates
-- the activeAtomicResource. This action must be fully atomic.
type SwapAtomicResourcePair a = AtomicResourcePair a -> Propellor Bool

-- | 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
	-- Constriaint inherited from ensureProperty.
	:: 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

-- | 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, since there are two copies
-- of the directory. 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
	-- Constriaint inherited from ensureProperty.
	:: 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

-- | 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.
--
-- Suppose that a web server program is run from the git repository,
-- and needs to be restarted after the pull. That restart should be done
-- after the atomicDirUpdate, but before the atomicDirSync. That way,
-- the old web server process will not have its files changed out from
-- under it.
--
-- >	& atomicDirUpdate "/srv/web/example.com"
-- >		(\d -> Git.pulled "joey" "http://.." d Nothing)
-- >		`onChange` (webServerRestart `before` atomicDirSync "/srv/web/example.com")
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