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

-- | 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 :: 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

-- | 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 :: 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

-- | 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 :: 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