summaryrefslogtreecommitdiff
path: root/src/Propellor/Property.hs
diff options
context:
space:
mode:
authorJoey Hess2016-03-28 05:53:38 -0400
committerJoey Hess2016-03-28 05:55:48 -0400
commita1655d24bbb1db9caccdf93eae8110d746389ae2 (patch)
tree66b6890d852c19daec2306920fecf9108e055273 /src/Propellor/Property.hs
parentebf30061d8f8a251330070e69c2710fe4a8fd9da (diff)
type safe targets for properties
* Property types have been improved to indicate what systems they target. This prevents using eg, Property FreeBSD on a Debian system. Transition guide for this sweeping API change: - Change "host name & foo & bar" to "host name $ props & foo & bar" - Similarly, `propertyList` and `combineProperties` need `props` to be used to combine together properties; they no longer accept lists of properties. (If you have such a list, use `toProps`.) - And similarly, Chroot, Docker, and Systemd container need `props` to be used to combine together the properies used inside them. - The `os` property is removed. Instead use `osDebian`, `osBuntish`, or `osFreeBSD`. These tell the type checker the target OS of a host. - Change "Property NoInfo" to "Property UnixLike" - Change "Property HasInfo" to "Property (HasInfo + UnixLike)" - Change "RevertableProperty NoInfo" to "RevertableProperty UnixLike UnixLike" - Change "RevertableProperty HasInfo" to "RevertableProperty (HasInfo + UnixLike) UnixLike" - GHC needs {-# LANGUAGE TypeOperators #-} to use these fancy types. This is enabled by default for all modules in propellor.cabal. But if you are using propellor as a library, you may need to enable it manually. - If you know a property only works on a particular OS, like Debian or FreeBSD, use that instead of "UnixLike". For example: "Property Debian" - It's also possible make a property support a set of OS's, for example: "Property (Debian + FreeBSD)" - Removed `infoProperty` and `simpleProperty` constructors, instead use `property` to construct a Property. - Due to the polymorphic type returned by `property`, additional type signatures tend to be needed when using it. For example, this will fail to type check, because the type checker cannot guess what type you intend the intermediate property "go" to have: foo :: Property UnixLike foo = go `requires` bar where go = property "foo" (return NoChange) To fix, specify the type of go: go :: Property UnixLike - `ensureProperty` now needs to be passed a witness to the type of the property it's used in. change this: foo = property desc $ ... ensureProperty bar to this: foo = property' desc $ \w -> ... ensureProperty w bar - General purpose properties like cmdProperty have type "Property UnixLike". When using that to run a command only available on Debian, you can tighten the type to only the OS that your more specific property works on. For example: upgraded :: Property Debian upgraded = tightenTargets (cmdProperty "apt-get" ["upgrade"]) - Several utility functions have been renamed: getInfo to fromInfo propertyInfo to getInfo propertyDesc to getDesc propertyChildren to getChildren * The new `pickOS` property combinator can be used to combine different properties, supporting different OS's, into one Property that chooses which to use based on the Host's OS. * Re-enabled -O0 in propellor.cabal to reign in ghc's memory use handling these complex new types. * Added dependency on concurrent-output; removed embedded copy.
Diffstat (limited to 'src/Propellor/Property.hs')
-rw-r--r--src/Propellor/Property.hs126
1 files changed, 97 insertions, 29 deletions
diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs
index b6b8dc0d..55c39ee2 100644
--- a/src/Propellor/Property.hs
+++ b/src/Propellor/Property.hs
@@ -1,5 +1,9 @@
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE PolyKinds #-}
module Propellor.Property (
-- * Property combinators
@@ -18,9 +22,13 @@ module Propellor.Property (
-- * Constructing properties
, Propellor
, property
+ , property'
+ , OuterMetaTypesWitness
, ensureProperty
+ , pickOS
, withOS
, unsupportedOS
+ , unsupportedOS'
, makeChange
, noChange
, doNothing
@@ -44,22 +52,21 @@ import Control.Monad.IfElse
import "mtl" Control.Monad.RWS.Strict
import System.Posix.Files
import qualified Data.Hash.MD5 as MD5
+import Data.List
import Control.Applicative
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.Exception
+import Propellor.EnsureProperty
import Utility.Exception
import Utility.Monad
import Utility.Misc
--- | Constructs a Property, from a description and an action to run to
--- ensure the Property is met.
-property :: Desc -> Propellor Result -> Property NoInfo
-property d s = simpleProperty d s mempty
-
-- | Makes a perhaps non-idempotent Property be idempotent by using a flag
-- file to indicate whether it has run before.
-- Use with caution.
@@ -164,13 +171,6 @@ describe = setDesc
(==>) = flip describe
infixl 1 ==>
--- | For when code running in the Propellor monad needs to ensure a
--- Property.
---
--- This can only be used on a Property that has NoInfo.
-ensureProperty :: Property NoInfo -> Propellor Result
-ensureProperty = catchPropellor . propertySatisfy
-
-- | Tries the first property, but if it fails to work, instead uses
-- the second.
fallback :: (Combines p1 p2) => p1 -> p2 -> CombinedType p1 p2
@@ -249,28 +249,96 @@ isNewerThan x y = do
where
mtime f = catchMaybeIO $ modificationTimeHiRes <$> getFileStatus f
--- | Makes a property that is satisfied differently depending on the host's
--- operating system.
+-- | 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.
--
--- Note that the operating system may not be declared for all hosts.
+-- 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.
--
--- > myproperty = withOS "foo installed" $ \o -> case o of
--- > (Just (System (Debian suite) arch)) -> ...
--- > (Just (System (Buntish release) arch)) -> ...
--- > Nothing -> unsupportedOS
-withOS :: Desc -> (Maybe System -> Propellor Result) -> Property NoInfo
-withOS desc a = property desc $ a =<< getOS
+-- For example:
+--
+-- > upgraded :: UnixLike
+-- > 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
+ ::
+ ( 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 a b = c `addChildren` [toChildProperty a, toChildProperty b]
+ where
+ -- This use of getSatisfy is safe, because both a and b
+ -- are added as children, so their info will propigate.
+ c = withOS (getDesc a) $ \_ o ->
+ if matching o a
+ then getSatisfy a
+ else if matching o b
+ then getSatisfy b
+ else unsupportedOS'
+ matching Nothing _ = False
+ matching (Just o) p =
+ Targeting (systemToTargetOS o)
+ `elem`
+ fromSing (proptype p)
+ proptype (Property t _ _ _ _) = 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 (Stable release)) arch)) -> ensureProperty w ...
+-- > (Just (System (Debian 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 '[] -> Maybe System -> Propellor Result)
+ -> Property (MetaTypes metatypes)
+withOS desc a = property desc $ a dummyoutermetatypes =<< getOS
+ where
+ -- Using this dummy value allows ensureProperty to be used
+ -- even though the inner property probably doesn't target everything
+ -- that the outer withOS property targets.
+ dummyoutermetatypes :: OuterMetaTypesWitness ('[])
+ dummyoutermetatypes = OuterMetaTypesWitness sing
+
+-- | A property that always fails with an unsupported OS error.
+unsupportedOS :: Property UnixLike
+unsupportedOS = property "unsupportedOS" unsupportedOS'
-- | Throws an error, for use in `withOS` when a property is lacking
-- support for an OS.
-unsupportedOS :: Propellor a
-unsupportedOS = go =<< getOS
- where
- go Nothing = error "Unknown host OS is not supported by this property."
- go (Just o) = error $ "This property is not implemented for " ++ show o
+unsupportedOS' :: Propellor Result
+unsupportedOS' = go =<< getOS
+ where
+ go Nothing = error "Unknown host OS is not supported by this property."
+ go (Just o) = error $ "This property is not implemented for " ++ show o
-- | Undoes the effect of a RevertableProperty.
-revert :: RevertableProperty i -> RevertableProperty i
+revert :: RevertableProperty setup undo -> RevertableProperty undo setup
revert (RevertableProperty p1 p2) = RevertableProperty p2 p1
makeChange :: IO () -> Propellor Result
@@ -279,7 +347,7 @@ makeChange a = liftIO a >> return MadeChange
noChange :: Propellor Result
noChange = return NoChange
-doNothing :: Property NoInfo
+doNothing :: SingI t => Property (MetaTypes t)
doNothing = property "noop property" noChange
-- | Registers an action that should be run at the very end, after