    {-# 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 a :: 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 rbase :: AtomicResourcePair a
    rbase rcheck :: CheckAtomicResourcePair a
    rcheck rswap :: SwapAtomicResourcePair a
    rswap mkp :: 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
    $ \w :: 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
    		FailedChange -> Result -> Propellor Result
    forall (m :: * -> *) a. Monad m => a -> m a
    return Result
    FailedChange
    		NoChange -> Result -> Propellor Result
    forall (m :: * -> *) a. Monad m => a -> m a
    return Result
    NoChange
    		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 d :: 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 d :: Desc
    d = AtomicResourcePair :: forall a. a -> a -> AtomicResourcePair a
    AtomicResourcePair
    	{ activeAtomicResource :: Desc
    activeAtomicResource = Desc -> Desc
    addext ".1"
    	, inactiveAtomicResource :: Desc
    inactiveAtomicResource = Desc -> Desc
    addext ".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 d :: Desc
    d rp :: 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 e :: IOException
    e -> do
    			Desc -> IO ()
    forall (m :: * -> *). MonadIO m => Desc -> m ()
    warningMessage (Desc -> IO ()) -> Desc -> IO ()
    forall a b. (a -> b) -> a -> b
    $ "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
    forall a. [a] -> [a] -> [a]
    ++ IOException -> Desc
    forall a. Show a => a -> Desc
    show IOException
    e Desc -> Desc -> Desc
    forall a. [a] -> [a] -> [a]
    ++ ")"
    			Bool -> IO Bool
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    False

    checkDirLink :: FilePath -> CheckAtomicResourcePair FilePath
    checkDirLink :: Desc -> CheckAtomicResourcePair Desc
    checkDirLink d :: Desc
    d rp :: 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 t :: 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
    		_ -> 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 d :: 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