{-# LANGUAGE PackageImports #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE PolyKinds #-}

module Propellor.Property (
	-- * Property combinators
	  requires
	, before
	, onChange
	, onChangeFlagOnFail
	, flagFile
	, flagFile'
	, check
	, fallback
	, revert
	-- * Property descriptions
	, describe
	, (==>)
	-- * Constructing properties
	, Propellor
	, property
	, property'
	, OuterMetaTypesWitness
	, ensureProperty
	, pickOS
	, withOS
	, unsupportedOS
	, unsupportedOS'
	, makeChange
	, noChange
	, doNothing
	, impossible
	, endAction
	-- * Property result checking
	, UncheckedProperty
	, unchecked
	, changesFile
	, changesFileContent
	, isNewerThan
	, checkResult
	, Checkable
	, assume
) where

import System.FilePath
import Control.Monad
import Data.Monoid
import Control.Monad.IfElse
import "mtl" Control.Monad.RWS.Strict
import System.Posix.Files
import Data.Maybe
import Data.List
import Data.Hashable
import Control.Applicative
import GHC.Stack
import Prelude

import Propellor.Types
import Propellor.Types.Core
import Propellor.Types.ResultCheck
import Propellor.Types.MetaTypes
import Propellor.Types.Singletons
import Propellor.Info
import Propellor.Message
import Propellor.EnsureProperty
import Utility.Exception
import Utility.Monad
import Utility.Directory
import Utility.Misc

-- | Makes a perhaps non-idempotent Property be idempotent by using a flag
-- file to indicate whether it has run before.
-- Use with caution.
flagFile :: Property i -> FilePath -> Property i
flagFile :: Property i -> FilePath -> Property i
flagFile Property i
p = Property i -> IO FilePath -> Property i
forall i. Property i -> IO FilePath -> Property i
flagFile' Property i
p (IO FilePath -> Property i)
-> (FilePath -> IO FilePath) -> FilePath -> Property i
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return

flagFile' :: Property i -> IO FilePath -> Property i
flagFile' :: Property i -> IO FilePath -> Property i
flagFile' Property i
p IO FilePath
getflagfile = Property i -> (Propellor Result -> Propellor Result) -> Property i
forall metatypes.
Property metatypes
-> (Propellor Result -> Propellor Result) -> Property metatypes
adjustPropertySatisfy Property i
p ((Propellor Result -> Propellor Result) -> Property i)
-> (Propellor Result -> Propellor Result) -> Property i
forall a b. (a -> b) -> a -> b
$ \Propellor Result
satisfy -> do
	FilePath
flagfile <- IO FilePath -> Propellor FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO FilePath
getflagfile
	Propellor Result -> FilePath -> Bool -> Propellor Result
forall (m :: * -> *).
MonadIO m =>
m Result -> FilePath -> Bool -> m Result
go Propellor Result
satisfy FilePath
flagfile (Bool -> Propellor Result) -> Propellor Bool -> Propellor Result
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO Bool -> Propellor Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO Bool
doesFileExist FilePath
flagfile)
  where
	go :: m Result -> FilePath -> Bool -> m Result
go m Result
_ FilePath
_ Bool
True = Result -> m Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
NoChange
	go m Result
satisfy FilePath
flagfile Bool
False = do
		Result
r <- m Result
satisfy
		Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Result
r Result -> Result -> Bool
forall a. Eq a => a -> a -> Bool
== Result
MadeChange) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
			IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (FilePath -> IO Bool
doesFileExist FilePath
flagfile) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
				Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> FilePath
takeDirectory FilePath
flagfile)
				FilePath -> FilePath -> IO ()
writeFile FilePath
flagfile FilePath
""
		Result -> m Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
r

-- | Indicates that the first property depends on the second,
-- so before the first is ensured, the second must be ensured.
--
-- The combined property uses the description of the first property.
requires :: Combines x y => x -> y -> CombinedType x y
requires :: x -> y -> CombinedType x y
requires = ResultCombiner -> ResultCombiner -> x -> y -> CombinedType x y
forall x y.
Combines x y =>
ResultCombiner -> ResultCombiner -> x -> y -> CombinedType x y
combineWith
	-- Run action of y, then x
	(ResultCombiner -> ResultCombiner
forall a b c. (a -> b -> c) -> b -> a -> c
flip ResultCombiner
forall a. Semigroup a => a -> a -> a
(<>))
	-- When reverting, run in reverse order.
	ResultCombiner
forall a. Semigroup a => a -> a -> a
(<>)

-- | Combines together two properties, resulting in one property
-- that ensures the first, and if the first succeeds, ensures the second.
--
-- The combined property uses the description of the first property.
before :: Combines x y => x -> y -> CombinedType x y
before :: x -> y -> CombinedType x y
before = ResultCombiner -> ResultCombiner -> x -> y -> CombinedType x y
forall x y.
Combines x y =>
ResultCombiner -> ResultCombiner -> x -> y -> CombinedType x y
combineWith
	-- Run action of x, then y
	ResultCombiner
forall a. Semigroup a => a -> a -> a
(<>)
	-- When reverting, run in reverse order.
	(ResultCombiner -> ResultCombiner
forall a b c. (a -> b -> c) -> b -> a -> c
flip ResultCombiner
forall a. Semigroup a => a -> a -> a
(<>))

-- | Whenever a change has to be made for a Property, causes a hook
-- Property to also be run, but not otherwise.
onChange
	:: (Combines x y)
	=> x
        -> y
        -> CombinedType x y
onChange :: x -> y -> CombinedType x y
onChange = ResultCombiner -> ResultCombiner -> x -> y -> CombinedType x y
forall x y.
Combines x y =>
ResultCombiner -> ResultCombiner -> x -> y -> CombinedType x y
combineWith ResultCombiner
forall (m :: * -> *).
Monad m =>
Maybe (m Result) -> Maybe (m Result) -> Maybe (m Result)
combiner ResultCombiner
revertcombiner
  where
	combiner :: Maybe (m Result) -> Maybe (m Result) -> Maybe (m Result)
combiner (Just m Result
p) (Just m Result
hook) = m Result -> Maybe (m Result)
forall a. a -> Maybe a
Just (m Result -> Maybe (m Result)) -> m Result -> Maybe (m Result)
forall a b. (a -> b) -> a -> b
$ do
		Result
r <- m Result
p
		case Result
r of
			Result
MadeChange -> do
				Result
r' <- m Result
hook
				Result -> m Result
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> m Result) -> Result -> m Result
forall a b. (a -> b) -> a -> b
$ Result
r Result -> Result -> Result
forall a. Semigroup a => a -> a -> a
<> Result
r'
			Result
_ -> Result -> m Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
r
	combiner (Just m Result
p) Maybe (m Result)
Nothing = m Result -> Maybe (m Result)
forall a. a -> Maybe a
Just m Result
p
	combiner Maybe (m Result)
Nothing Maybe (m Result)
_ = Maybe (m Result)
forall a. Maybe a
Nothing
	revertcombiner :: ResultCombiner
revertcombiner = ResultCombiner
forall a. Semigroup a => a -> a -> a
(<>)

-- | Same as `onChange` except that if property y fails, a flag file
-- is generated. On next run, if the flag file is present, property y
-- is executed even if property x doesn't change.
--
-- With `onChange`, if y fails, the property x `onChange` y returns
-- `FailedChange`. But if this property is applied again, it returns
-- `NoChange`. This behavior can cause trouble...
onChangeFlagOnFail
	:: (Combines x y)
	=> FilePath
        -> x
        -> y
        -> CombinedType x y
onChangeFlagOnFail :: FilePath -> x -> y -> CombinedType x y
onChangeFlagOnFail FilePath
flagfile = ResultCombiner -> ResultCombiner -> x -> y -> CombinedType x y
forall x y.
Combines x y =>
ResultCombiner -> ResultCombiner -> x -> y -> CombinedType x y
combineWith ResultCombiner
combiner ResultCombiner
revertcombiner
  where
	combiner :: ResultCombiner
combiner (Just Propellor Result
s1) Maybe (Propellor Result)
s2 = Propellor Result -> Maybe (Propellor Result)
forall a. a -> Maybe a
Just (Propellor Result -> Maybe (Propellor Result))
-> Propellor Result -> Maybe (Propellor Result)
forall a b. (a -> b) -> a -> b
$ do
		Result
r1 <- Propellor Result
s1
		case Result
r1 of
			Result
MadeChange -> Maybe (Propellor Result) -> Propellor Result
flagFailed Maybe (Propellor Result)
s2
			Result
_ -> Propellor Bool
-> (Propellor Result, Propellor Result) -> Propellor Result
forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
ifM (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
$ FilePath -> IO Bool
doesFileExist FilePath
flagfile)
				( Maybe (Propellor Result) -> Propellor Result
flagFailed Maybe (Propellor Result)
s2
				, Result -> Propellor Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
r1
				)
	combiner Maybe (Propellor Result)
Nothing Maybe (Propellor Result)
_ = Maybe (Propellor Result)
forall a. Maybe a
Nothing

	revertcombiner :: ResultCombiner
revertcombiner = ResultCombiner
forall a. Semigroup a => a -> a -> a
(<>)

	flagFailed :: Maybe (Propellor Result) -> Propellor Result
flagFailed (Just Propellor Result
s) = do
		Result
r <- Propellor Result
s
		IO () -> Propellor ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Propellor ()) -> IO () -> Propellor ()
forall a b. (a -> b) -> a -> b
$ case Result
r of
			Result
FailedChange -> IO ()
createFlagFile
			Result
_ -> IO ()
removeFlagFile
		Result -> Propellor Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
r
	flagFailed Maybe (Propellor Result)
Nothing = Result -> Propellor Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
NoChange

	createFlagFile :: IO ()
createFlagFile = IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (FilePath -> IO Bool
doesFileExist FilePath
flagfile) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
		Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> FilePath
takeDirectory FilePath
flagfile)
		FilePath -> FilePath -> IO ()
writeFile FilePath
flagfile FilePath
""
	
	removeFlagFile :: IO ()
removeFlagFile = IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (FilePath -> IO Bool
doesFileExist FilePath
flagfile) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
removeFile FilePath
flagfile

-- | Changes the description of a property.
describe :: IsProp p => p -> Desc -> p
describe :: p -> FilePath -> p
describe = p -> FilePath -> p
forall p. IsProp p => p -> FilePath -> p
setDesc

-- | Alias for @flip describe@
(==>) :: IsProp (Property i) => Desc -> Property i -> Property i
==> :: FilePath -> Property i -> Property i
(==>) = (Property i -> FilePath -> Property i)
-> FilePath -> Property i -> Property i
forall a b c. (a -> b -> c) -> b -> a -> c
flip Property i -> FilePath -> Property i
forall p. IsProp p => p -> FilePath -> p
describe
infixl 1 ==>

-- | Tries the first property, but if it fails to work, instead uses
-- the second.
fallback :: (Combines p1 p2) => p1 -> p2 -> CombinedType p1 p2
fallback :: p1 -> p2 -> CombinedType p1 p2
fallback = ResultCombiner -> ResultCombiner -> p1 -> p2 -> CombinedType p1 p2
forall x y.
Combines x y =>
ResultCombiner -> ResultCombiner -> x -> y -> CombinedType x y
combineWith ResultCombiner
forall (m :: * -> *).
Monad m =>
Maybe (m Result) -> Maybe (m Result) -> Maybe (m Result)
combiner ResultCombiner
revertcombiner
  where
	combiner :: Maybe (m Result) -> Maybe (m Result) -> Maybe (m Result)
combiner (Just m Result
a1) (Just m Result
a2) = m Result -> Maybe (m Result)
forall a. a -> Maybe a
Just (m Result -> Maybe (m Result)) -> m Result -> Maybe (m Result)
forall a b. (a -> b) -> a -> b
$ do
		Result
r <- m Result
a1
		if Result
r Result -> Result -> Bool
forall a. Eq a => a -> a -> Bool
== Result
FailedChange
			then m Result
a2
			else Result -> m Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
r
	combiner (Just m Result
a1) Maybe (m Result)
Nothing = m Result -> Maybe (m Result)
forall a. a -> Maybe a
Just m Result
a1
	combiner Maybe (m Result)
Nothing Maybe (m Result)
_ = Maybe (m Result)
forall a. Maybe a
Nothing
	revertcombiner :: ResultCombiner
revertcombiner = ResultCombiner
forall a. Semigroup a => a -> a -> a
(<>)

-- | Indicates that a Property may change a particular file. When the file
-- is modified in any way (including changing its permissions or mtime),
-- the property will return MadeChange instead of NoChange.
changesFile :: Checkable p i => p i -> FilePath -> Property i
changesFile :: p i -> FilePath -> Property i
changesFile p i
p FilePath
f = IO (Maybe FileStatus)
-> (Maybe FileStatus -> IO Result) -> p i -> Property i
forall (p :: * -> *) i (m :: * -> *) a.
(Checkable p i, LiftPropellor m) =>
m a -> (a -> m Result) -> p i -> Property i
checkResult IO (Maybe FileStatus)
getstat Maybe FileStatus -> IO Result
comparestat p i
p
  where
	getstat :: IO (Maybe FileStatus)
getstat = IO FileStatus -> IO (Maybe FileStatus)
forall (m :: * -> *) a. MonadCatch m => m a -> m (Maybe a)
catchMaybeIO (IO FileStatus -> IO (Maybe FileStatus))
-> IO FileStatus -> IO (Maybe FileStatus)
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FileStatus
getSymbolicLinkStatus FilePath
f
	comparestat :: Maybe FileStatus -> IO Result
comparestat Maybe FileStatus
oldstat = do
		Maybe FileStatus
newstat <- IO (Maybe FileStatus)
getstat
		Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ if Maybe FileStatus -> Maybe FileStatus -> Bool
samestat Maybe FileStatus
oldstat Maybe FileStatus
newstat then Result
NoChange else Result
MadeChange
	samestat :: Maybe FileStatus -> Maybe FileStatus -> Bool
samestat Maybe FileStatus
Nothing Maybe FileStatus
Nothing = Bool
True
	samestat (Just FileStatus
a) (Just FileStatus
b) = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and
		-- everything except for atime
		[ FileStatus -> DeviceID
deviceID FileStatus
a DeviceID -> DeviceID -> Bool
forall a. Eq a => a -> a -> Bool
== FileStatus -> DeviceID
deviceID FileStatus
b
		, FileStatus -> FileID
fileID FileStatus
a FileID -> FileID -> Bool
forall a. Eq a => a -> a -> Bool
== FileStatus -> FileID
fileID FileStatus
b
		, FileStatus -> FileMode
fileMode FileStatus
a FileMode -> FileMode -> Bool
forall a. Eq a => a -> a -> Bool
== FileStatus -> FileMode
fileMode FileStatus
b
		, FileStatus -> UserID
fileOwner FileStatus
a UserID -> UserID -> Bool
forall a. Eq a => a -> a -> Bool
== FileStatus -> UserID
fileOwner FileStatus
b
		, FileStatus -> GroupID
fileGroup FileStatus
a GroupID -> GroupID -> Bool
forall a. Eq a => a -> a -> Bool
== FileStatus -> GroupID
fileGroup FileStatus
b
		, FileStatus -> DeviceID
specialDeviceID FileStatus
a DeviceID -> DeviceID -> Bool
forall a. Eq a => a -> a -> Bool
== FileStatus -> DeviceID
specialDeviceID FileStatus
b
		, FileStatus -> FileOffset
fileSize FileStatus
a FileOffset -> FileOffset -> Bool
forall a. Eq a => a -> a -> Bool
== FileStatus -> FileOffset
fileSize FileStatus
b
		, FileStatus -> POSIXTime
modificationTimeHiRes FileStatus
a POSIXTime -> POSIXTime -> Bool
forall a. Eq a => a -> a -> Bool
== FileStatus -> POSIXTime
modificationTimeHiRes FileStatus
b
		, FileStatus -> Bool
isBlockDevice FileStatus
a Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== FileStatus -> Bool
isBlockDevice FileStatus
b
		, FileStatus -> Bool
isCharacterDevice FileStatus
a Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== FileStatus -> Bool
isCharacterDevice FileStatus
b
		, FileStatus -> Bool
isNamedPipe FileStatus
a Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== FileStatus -> Bool
isNamedPipe FileStatus
b
		, FileStatus -> Bool
isRegularFile FileStatus
a Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== FileStatus -> Bool
isRegularFile FileStatus
b
		, FileStatus -> Bool
isDirectory FileStatus
a Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== FileStatus -> Bool
isDirectory FileStatus
b
		, FileStatus -> Bool
isSymbolicLink FileStatus
a Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== FileStatus -> Bool
isSymbolicLink FileStatus
b
		, FileStatus -> Bool
isSocket FileStatus
a Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== FileStatus -> Bool
isSocket FileStatus
b
		]
	samestat Maybe FileStatus
_ Maybe FileStatus
_ = Bool
False

-- | Like `changesFile`, but compares the content of the file.
-- Changes to mtime etc that do not change file content are treated as
-- NoChange.
changesFileContent :: Checkable p i => p i -> FilePath -> Property i
changesFileContent :: p i -> FilePath -> Property i
changesFileContent p i
p FilePath
f = IO (Maybe Int) -> (Maybe Int -> IO Result) -> p i -> Property i
forall (p :: * -> *) i (m :: * -> *) a.
(Checkable p i, LiftPropellor m) =>
m a -> (a -> m Result) -> p i -> Property i
checkResult IO (Maybe Int)
gethash Maybe Int -> IO Result
comparehash p i
p
  where
	gethash :: IO (Maybe Int)
gethash = IO Int -> IO (Maybe Int)
forall (m :: * -> *) a. MonadCatch m => m a -> m (Maybe a)
catchMaybeIO (IO Int -> IO (Maybe Int)) -> IO Int -> IO (Maybe Int)
forall a b. (a -> b) -> a -> b
$ FilePath -> Int
forall a. Hashable a => a -> Int
hash (FilePath -> Int) -> IO FilePath -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO FilePath
readFileStrict FilePath
f
	comparehash :: Maybe Int -> IO Result
comparehash Maybe Int
oldhash = do
		Maybe Int
newhash <- IO (Maybe Int)
gethash
		Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ if Maybe Int
oldhash Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Int
newhash then Result
NoChange else Result
MadeChange

-- | Determines if the first file is newer than the second file.
--
-- This can be used with `check` to only run a command when a file
-- has changed.
--
-- > check ("/etc/aliases" `isNewerThan` "/etc/aliases.db")
-- > 	(cmdProperty "newaliases" [] `assume` MadeChange) -- updates aliases.db
--
-- Or it can be used with `checkResult` to test if a command made a change.
--
-- > checkResult (return ())
-- > 	(\_ -> "/etc/aliases.db" `isNewerThan` "/etc/aliases")
-- > 	(cmdProperty "newaliases" [])
--
-- (If one of the files does not exist, the file that does exist is
-- considered to be the newer of the two.)
isNewerThan :: FilePath -> FilePath -> IO Bool
isNewerThan :: FilePath -> FilePath -> IO Bool
isNewerThan FilePath
x FilePath
y = do
	Maybe POSIXTime
mx <- FilePath -> IO (Maybe POSIXTime)
mtime FilePath
x
	Maybe POSIXTime
my <- FilePath -> IO (Maybe POSIXTime)
mtime FilePath
y
	Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe POSIXTime
mx Maybe POSIXTime -> Maybe POSIXTime -> Bool
forall a. Ord a => a -> a -> Bool
> Maybe POSIXTime
my)
  where
	mtime :: FilePath -> IO (Maybe POSIXTime)
mtime FilePath
f = IO POSIXTime -> IO (Maybe POSIXTime)
forall (m :: * -> *) a. MonadCatch m => m a -> m (Maybe a)
catchMaybeIO (IO POSIXTime -> IO (Maybe POSIXTime))
-> IO POSIXTime -> IO (Maybe POSIXTime)
forall a b. (a -> b) -> a -> b
$ FileStatus -> POSIXTime
modificationTimeHiRes (FileStatus -> POSIXTime) -> IO FileStatus -> IO POSIXTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO FileStatus
getFileStatus FilePath
f

-- | Picks one of the two input properties to use,
-- depending on the targeted OS.
--
-- If both input properties support the targeted OS, then the
-- first will be used.
--
-- The resulting property will use the description of the first property
-- no matter which property is used in the end. So, it's often a good
-- idea to change the description to something clearer.
--
-- For example:
--
-- > upgraded :: Property (DebianLike + FreeBSD)
-- > upgraded = (Apt.upgraded `pickOS` Pkg.upgraded)
-- > 	`describe` "OS upgraded"
--
-- If neither input property supports the targeted OS, calls
-- `unsupportedOS`. Using the example above on a Fedora system would
-- fail that way.
pickOS
	::
		HasCallStack =>
		( SingKind ('KProxy :: KProxy ka)
		, SingKind ('KProxy :: KProxy kb)
		, DemoteRep ('KProxy :: KProxy ka) ~ [MetaType]
		, DemoteRep ('KProxy :: KProxy kb) ~ [MetaType]
		, SingI c
		-- Would be nice to have this constraint, but
		-- union will not generate metatypes lists with the same
		-- order of OS's as is used everywhere else. So,
		-- would need a type-level sort.
		--, Union a b ~ c
		)
	=> Property (MetaTypes (a :: ka))
	-> Property (MetaTypes (b :: kb))
	-> Property (MetaTypes c)
pickOS :: Property (MetaTypes a)
-> Property (MetaTypes b) -> Property (MetaTypes c)
pickOS Property (MetaTypes a)
a Property (MetaTypes b)
b = Property (MetaTypes c)
c Property (MetaTypes c) -> [ChildProperty] -> Property (MetaTypes c)
forall p. IsProp p => p -> [ChildProperty] -> p
`addChildren` [Property (MetaTypes a) -> ChildProperty
forall p. IsProp p => p -> ChildProperty
toChildProperty Property (MetaTypes a)
a, Property (MetaTypes b) -> ChildProperty
forall p. IsProp p => p -> ChildProperty
toChildProperty Property (MetaTypes b)
b]
  where
	-- This use of getSatisfy is safe, because both a and b
	-- are added as children, so their info will propigate.
	c :: Property (MetaTypes c)
c = FilePath -> Propellor Result -> Property (MetaTypes c)
forall k (metatypes :: k).
SingI metatypes =>
FilePath -> Propellor Result -> Property (MetaTypes metatypes)
property (Property (MetaTypes a) -> FilePath
forall p. IsProp p => p -> FilePath
getDesc Property (MetaTypes a)
a) (Propellor Result -> Property (MetaTypes c))
-> Propellor Result -> Property (MetaTypes c)
forall a b. (a -> b) -> a -> b
$ do
		Maybe System
o <- Propellor (Maybe System)
getOS
		if Maybe System -> Property (MetaTypes a) -> Bool
forall k (t :: * -> *) (a :: k).
(Foldable t, SingKind 'KProxy, DemoteRep 'KProxy ~ t MetaType) =>
Maybe System -> Property (Sing a) -> Bool
matching Maybe System
o Property (MetaTypes a)
a
			then Propellor Result
-> (Propellor Result -> Propellor Result)
-> Maybe (Propellor Result)
-> Propellor Result
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Result -> Propellor Result
forall (f :: * -> *) a. Applicative f => a -> f a
pure Result
NoChange) Propellor Result -> Propellor Result
forall a. a -> a
id (Property (MetaTypes a) -> Maybe (Propellor Result)
forall p. IsProp p => p -> Maybe (Propellor Result)
getSatisfy Property (MetaTypes a)
a)
			else if Maybe System -> Property (MetaTypes b) -> Bool
forall k (t :: * -> *) (a :: k).
(Foldable t, SingKind 'KProxy, DemoteRep 'KProxy ~ t MetaType) =>
Maybe System -> Property (Sing a) -> Bool
matching Maybe System
o Property (MetaTypes b)
b
				then Propellor Result
-> (Propellor Result -> Propellor Result)
-> Maybe (Propellor Result)
-> Propellor Result
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Result -> Propellor Result
forall (f :: * -> *) a. Applicative f => a -> f a
pure Result
NoChange) Propellor Result -> Propellor Result
forall a. a -> a
id (Property (MetaTypes b) -> Maybe (Propellor Result)
forall p. IsProp p => p -> Maybe (Propellor Result)
getSatisfy Property (MetaTypes b)
b)
				else Propellor Result
HasCallStack => Propellor Result
unsupportedOS'
	matching :: Maybe System -> Property (Sing a) -> Bool
matching Maybe System
Nothing Property (Sing a)
_ = Bool
False
	matching (Just System
o) Property (Sing a)
p =
		TargetOS -> MetaType
Targeting (System -> TargetOS
systemToTargetOS System
o)
			MetaType -> t MetaType -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`
		Sing a -> DemoteRep 'KProxy
forall k (kparam :: KProxy k) (a :: k).
SingKind kparam =>
Sing a -> DemoteRep kparam
fromSing (Property (Sing a) -> Sing a
forall metatypes. Property metatypes -> metatypes
proptype Property (Sing a)
p)
	proptype :: Property metatypes -> metatypes
proptype (Property metatypes
t FilePath
_ Maybe (Propellor Result)
_ Info
_ [ChildProperty]
_) = metatypes
t

-- | Makes a property that is satisfied differently depending on specifics
-- of the host's operating system.
--
-- > myproperty :: Property Debian
-- > myproperty = withOS "foo installed" $ \w o -> case o of
-- > 	(Just (System (Debian kernel (Stable release)) arch)) -> ensureProperty w ...
-- > 	(Just (System (Debian kernel suite) arch)) -> ensureProperty w ...
-- >	_ -> unsupportedOS'
--
-- Note that the operating system specifics may not be declared for all hosts,
-- which is where Nothing comes in.
withOS
	:: (SingI metatypes)
	=> Desc
	-> (OuterMetaTypesWitness metatypes -> Maybe System -> Propellor Result)
	-> Property (MetaTypes metatypes)
withOS :: FilePath
-> (OuterMetaTypesWitness metatypes
    -> Maybe System -> Propellor Result)
-> Property (MetaTypes metatypes)
withOS FilePath
desc OuterMetaTypesWitness metatypes -> Maybe System -> Propellor Result
a = FilePath
-> (OuterMetaTypesWitness metatypes -> Propellor Result)
-> Property (MetaTypes metatypes)
forall k (metatypes :: k).
SingI metatypes =>
FilePath
-> (OuterMetaTypesWitness metatypes -> Propellor Result)
-> Property (MetaTypes metatypes)
property' FilePath
desc ((OuterMetaTypesWitness metatypes -> Propellor Result)
 -> Property (MetaTypes metatypes))
-> (OuterMetaTypesWitness metatypes -> Propellor Result)
-> Property (MetaTypes metatypes)
forall a b. (a -> b) -> a -> b
$ \OuterMetaTypesWitness metatypes
w -> OuterMetaTypesWitness metatypes -> Maybe System -> Propellor Result
a OuterMetaTypesWitness metatypes
w (Maybe System -> Propellor Result)
-> Propellor (Maybe System) -> Propellor Result
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Propellor (Maybe System)
getOS

-- | A property that always fails with an unsupported OS error.
unsupportedOS :: Property UnixLike
unsupportedOS :: Property UnixLike
unsupportedOS = FilePath -> Propellor Result -> Property UnixLike
forall k (metatypes :: k).
SingI metatypes =>
FilePath -> Propellor Result -> Property (MetaTypes metatypes)
property FilePath
"unsupportedOS" Propellor Result
HasCallStack => Propellor Result
unsupportedOS'

-- | Throws an error, for use in `withOS` when a property is lacking
-- support for an OS.
unsupportedOS' :: HasCallStack => Propellor Result
unsupportedOS' :: Propellor Result
unsupportedOS' = Maybe System -> Propellor Result
forall a p. Show a => Maybe a -> p
go (Maybe System -> Propellor Result)
-> Propellor (Maybe System) -> Propellor Result
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Propellor (Maybe System)
getOS
	  where
		go :: Maybe a -> p
go Maybe a
Nothing = FilePath -> p
forall a. HasCallStack => FilePath -> a
error FilePath
"Unknown host OS is not supported by this property."
		go (Just a
o) = FilePath -> p
forall a. HasCallStack => FilePath -> a
error (FilePath -> p) -> FilePath -> p
forall a b. (a -> b) -> a -> b
$ FilePath
"This property is not implemented for " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ a -> FilePath
forall a. Show a => a -> FilePath
show a
o

-- | Undoes the effect of a RevertableProperty.
revert :: RevertableProperty setup undo -> RevertableProperty undo setup
revert :: RevertableProperty setup undo -> RevertableProperty undo setup
revert (RevertableProperty Property setup
p1 Property undo
p2) = Property undo -> Property setup -> RevertableProperty undo setup
forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
RevertableProperty Property undo
p2 Property setup
p1

makeChange :: IO () -> Propellor Result
makeChange :: IO () -> Propellor Result
makeChange IO ()
a = IO () -> Propellor ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
a Propellor () -> Propellor Result -> Propellor Result
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Result -> Propellor Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
MadeChange

noChange :: Propellor Result
noChange :: Propellor Result
noChange = Result -> Propellor Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
NoChange

-- | A no-op property.
--
-- This is the same as `mempty` from the `Monoid` instance.
doNothing :: SingI t => Property (MetaTypes t)
doNothing :: Property (MetaTypes t)
doNothing = Property (MetaTypes t)
forall a. Monoid a => a
mempty

-- | In situations where it's not possible to provide a property that
-- works, this can be used to make a property that always fails with an
-- error message you provide.
impossible :: SingI t => String -> Property (MetaTypes t)
impossible :: FilePath -> Property (MetaTypes t)
impossible FilePath
msg = FilePath -> Propellor Result -> Property (MetaTypes t)
forall k (metatypes :: k).
SingI metatypes =>
FilePath -> Propellor Result -> Property (MetaTypes metatypes)
property FilePath
"impossible" (Propellor Result -> Property (MetaTypes t))
-> Propellor Result -> Property (MetaTypes t)
forall a b. (a -> b) -> a -> b
$ FilePath -> Propellor Result
forall (m :: * -> *) a. MonadIO m => FilePath -> m a
errorMessage FilePath
msg

-- | Registers an action that should be run at the very end, after
-- propellor has checks all the properties of a host.
endAction :: Desc -> (Result -> Propellor Result) -> Propellor ()
endAction :: FilePath -> (Result -> Propellor Result) -> Propellor ()
endAction FilePath
desc Result -> Propellor Result
a = [EndAction] -> Propellor ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [FilePath -> (Result -> Propellor Result) -> EndAction
EndAction FilePath
desc Result -> Propellor Result
a]