propellor/Propellor/Property.hs

164 lines
4.9 KiB
Haskell
Raw Normal View History

{-# LANGUAGE PackageImports #-}
2014-03-31 03:37:54 +00:00
module Propellor.Property where
import System.Directory
import Control.Monad
2014-03-31 14:36:45 +00:00
import Data.Monoid
import Data.List
2014-04-10 15:02:29 +00:00
import Control.Monad.IfElse
import "mtl" Control.Monad.Reader
2014-03-31 03:37:54 +00:00
import Propellor.Types
2014-04-11 01:09:20 +00:00
import Propellor.Types.Attr
import Propellor.Attr
2014-03-31 05:06:44 +00:00
import Propellor.Engine
2014-03-30 05:13:53 +00:00
import Utility.Monad
2014-04-13 01:34:25 +00:00
import System.FilePath
-- Constructs a Property.
property :: Desc -> Propellor Result -> Property
property d s = Property d s id
2014-03-31 14:36:45 +00:00
-- | Combines a list of properties, resulting in a single property
-- that when run will run each property in the list in turn,
-- and print out the description of each as it's run. Does not stop
-- on failure; does propigate overall success/failure.
2014-03-30 06:26:23 +00:00
propertyList :: Desc -> [Property] -> Property
propertyList desc ps = Property desc (ensureProperties ps) (combineSetAttrs ps)
2014-03-30 06:26:23 +00:00
2014-03-31 14:36:45 +00:00
-- | Combines a list of properties, resulting in one property that
-- ensures each in turn, stopping on failure.
2014-04-01 21:32:37 +00:00
combineProperties :: Desc -> [Property] -> Property
combineProperties desc ps = Property desc (go ps NoChange) (combineSetAttrs ps)
where
go [] rs = return rs
go (l:ls) rs = do
r <- ensureProperty l
case r of
FailedChange -> return FailedChange
2014-03-31 14:36:45 +00:00
_ -> go ls (r <> rs)
2014-04-08 22:41:30 +00:00
-- | Combines together two properties, resulting in one property
-- that ensures the first, and if the first succeeds, ensures the second.
-- The property uses the description of the first property.
before :: Property -> Property -> Property
p1 `before` p2 = p2 `requires` p1
`describe` (propertyDesc p1)
2014-04-08 22:41:30 +00:00
2014-03-31 14:36:45 +00:00
-- | Makes a perhaps non-idempotent Property be idempotent by using a flag
-- file to indicate whether it has run before.
-- Use with caution.
2014-03-30 19:31:57 +00:00
flagFile :: Property -> FilePath -> Property
flagFile p = flagFile' p . return
2014-04-13 01:34:25 +00:00
flagFile' :: Property -> IO FilePath -> Property
flagFile' p getflagfile = adjustProperty p $ \satisfy -> do
2014-04-13 01:34:25 +00:00
flagfile <- liftIO getflagfile
go satisfy flagfile =<< liftIO (doesFileExist flagfile)
where
go _ _ True = return NoChange
go satisfy flagfile False = do
r <- satisfy
when (r == MadeChange) $ liftIO $
2014-04-13 01:34:25 +00:00
unlessM (doesFileExist flagfile) $ do
createDirectoryIfMissing True (takeDirectory flagfile)
2014-04-10 15:02:29 +00:00
writeFile flagfile ""
2014-03-30 19:31:57 +00:00
return r
2014-03-31 14:36:45 +00:00
--- | Whenever a change has to be made for a Property, causes a hook
-- Property to also be run, but not otherwise.
2014-03-30 19:31:57 +00:00
onChange :: Property -> Property -> Property
p `onChange` hook = Property (propertyDesc p) satisfy (combineSetAttr p hook)
where
satisfy = do
r <- ensureProperty p
case r of
MadeChange -> do
r' <- ensureProperty hook
return $ r <> r'
_ -> return r
2014-03-30 19:31:57 +00:00
2014-03-30 20:49:59 +00:00
(==>) :: Desc -> Property -> Property
(==>) = flip describe
infixl 1 ==>
-- | Makes a Property only need to do anything when a test succeeds.
2014-03-30 19:31:57 +00:00
check :: IO Bool -> Property -> Property
check c p = adjustProperty p $ \satisfy -> ifM (liftIO c)
( satisfy
2014-03-30 19:31:57 +00:00
, return NoChange
)
2014-04-02 16:13:39 +00:00
2014-04-14 18:09:41 +00:00
-- | Marks a Property as trivial. It can only return FailedChange or
-- NoChange.
--
-- Useful when it's just as expensive to check if a change needs
-- to be made as it is to just idempotently assure the property is
-- satisfied. For example, chmodding a file.
trivial :: Property -> Property
trivial p = adjustProperty p $ \satisfy -> do
r <- satisfy
2014-04-14 18:09:41 +00:00
if r == MadeChange
then return NoChange
else return r
-- | Makes a property that is satisfied differently depending on the host's
-- operating system.
--
-- Note that the operating system may not be declared for some hosts.
withOS :: Desc -> (Maybe System -> Propellor Result) -> Property
withOS desc a = property desc $ a =<< getOS
2014-04-03 00:56:02 +00:00
boolProperty :: Desc -> IO Bool -> Property
boolProperty desc a = property desc $ ifM (liftIO a)
2014-04-03 00:56:02 +00:00
( return MadeChange
, return FailedChange
)
2014-04-02 16:13:39 +00:00
-- | Undoes the effect of a property.
revert :: RevertableProperty -> RevertableProperty
revert (RevertableProperty p1 p2) = RevertableProperty p2 p1
2014-04-11 01:09:20 +00:00
-- | Starts accumulating the properties of a Host.
--
-- > host "example.com"
-- > & someproperty
-- > ! oldproperty
-- > & otherproperty
host :: HostName -> Host
host hn = Host [] (\_ -> newAttr hn)
-- | Adds a property to a Host
2014-04-11 06:03:51 +00:00
--
-- Can add Properties and RevertableProperties
2014-04-11 01:09:20 +00:00
(&) :: IsProp p => Host -> p -> Host
(Host ps as) & p = Host (ps ++ [toProp p]) (setAttr p . as)
2014-04-02 16:13:39 +00:00
infixl 1 &
2014-04-03 03:01:40 +00:00
2014-04-11 01:09:20 +00:00
-- | Adds a property to the Host in reverted form.
(!) :: Host -> RevertableProperty -> Host
(Host ps as) ! p = Host (ps ++ [toProp q]) (setAttr q . as)
2014-04-11 01:09:20 +00:00
where
q = revert p
2014-04-03 03:01:40 +00:00
infixl 1 !
-- Changes the action that is performed to satisfy a property.
adjustProperty :: Property -> (Propellor Result -> Propellor Result) -> Property
adjustProperty p f = p { propertySatisfy = f (propertySatisfy p) }
-- Combines the Attr settings of two properties.
combineSetAttr :: (IsProp p, IsProp q) => p -> q -> SetAttr
combineSetAttr p q = setAttr p . setAttr q
combineSetAttrs :: IsProp p => [p] -> SetAttr
combineSetAttrs = foldl' (.) id . map setAttr
makeChange :: IO () -> Propellor Result
makeChange a = liftIO a >> return MadeChange
noChange :: Propellor Result
noChange = return NoChange