Merge branch 'joeyconfig'

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