Atomic.hs

{-# 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
	{ activeAtomicResource :: a
	, inactiveAtomicResource :: a
	}

flipAtomicResourcePair :: AtomicResourcePair a -> AtomicResourcePair a
flipAtomicResourcePair a = AtomicResourcePair
	{ activeAtomicResource = inactiveAtomicResource a
	, inactiveAtomicResource = activeAtomicResource 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
	-- Constriaints inherited from ensureProperty.
	:: ( 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

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

-- | 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 d = syncDir (activeAtomicResource rp) (inactiveAtomicResource rp)
  where
	rp = mkDirLink d