summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--propellor.cabal1
-rw-r--r--src/Propellor/Base.hs12
-rw-r--r--src/Propellor/EnsureProperty.hs66
-rw-r--r--src/Propellor/Property.hs12
-rw-r--r--src/Propellor/Property/File.hs9
-rw-r--r--src/Propellor/Types.hs4
-rw-r--r--src/Propellor/Types/MetaTypes.hs71
7 files changed, 94 insertions, 81 deletions
diff --git a/propellor.cabal b/propellor.cabal
index 0a7746ed..a13ebcb5 100644
--- a/propellor.cabal
+++ b/propellor.cabal
@@ -143,6 +143,7 @@ Library
Propellor.Debug
Propellor.PrivData
Propellor.Engine
+ Propellor.EnsureProperty
Propellor.Exception
Propellor.Types
Propellor.Types.Chroot
diff --git a/src/Propellor/Base.hs b/src/Propellor/Base.hs
index 2a0f5cbc..e50adf10 100644
--- a/src/Propellor/Base.hs
+++ b/src/Propellor/Base.hs
@@ -7,12 +7,12 @@ module Propellor.Base (
module Propellor.Types
, module Propellor.Property
, module Propellor.Property.Cmd
- , module Propellor.Property.List
+ --, module Propellor.Property.List
, module Propellor.Types.PrivData
- , module Propellor.PropAccum
+ --, module Propellor.PropAccum
, module Propellor.Info
, module Propellor.PrivData
- , module Propellor.Engine
+ --, module Propellor.Engine
, module Propellor.Exception
, module Propellor.Message
, module Propellor.Debug
@@ -34,8 +34,8 @@ module Propellor.Base (
import Propellor.Types
import Propellor.Property
-import Propellor.Engine
-import Propellor.Property.List
+--import Propellor.Engine
+--import Propellor.Property.List
import Propellor.Property.Cmd
import Propellor.PrivData
import Propellor.Types.PrivData
@@ -43,7 +43,7 @@ import Propellor.Message
import Propellor.Debug
import Propellor.Exception
import Propellor.Info
-import Propellor.PropAccum
+--import Propellor.PropAccum
import Propellor.Location
import Propellor.Utilities
diff --git a/src/Propellor/EnsureProperty.hs b/src/Propellor/EnsureProperty.hs
new file mode 100644
index 00000000..c72f7ecd
--- /dev/null
+++ b/src/Propellor/EnsureProperty.hs
@@ -0,0 +1,66 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Propellor.EnsureProperty
+ ( ensureProperty
+ , property'
+ , OuterMetaTypes
+ ) where
+
+import Propellor.Types
+import Propellor.Types.MetaTypes
+import Propellor.Exception
+
+-- | For when code running in the Propellor monad needs to ensure a
+-- Property.
+--
+-- Use `property'` to get the `OuterMetaTypes`. For example:
+--
+-- > foo = Property Debian
+-- > foo = property' $ \o -> do
+-- > ensureProperty o (aptInstall "foo")
+--
+-- The type checker will prevent using ensureProperty with a property
+-- that does not support the target OSes needed by the OuterMetaTypes.
+-- In the example above, aptInstall must support Debian, since foo
+-- is supposed to support Debian.
+--
+-- The type checker will also prevent using ensureProperty with a property
+-- with HasInfo in its MetaTypes. Doing so would cause the `Info` associated
+-- with the property to be lost.
+ensureProperty
+ ::
+ ( (Targets inner `NotSuperset` Targets outer) ~ 'CanCombineTargets
+ , CannotUseEnsurePropertyWithInfo inner ~ 'True
+ )
+ => OuterMetaTypes outer
+ -> Property (Sing inner)
+ -> Propellor Result
+ensureProperty _ = catchPropellor . propertySatisfy
+
+-- The name of this was chosen to make type errors a more understandable.
+type family CannotUseEnsurePropertyWithInfo (l :: [a]) :: Bool
+type instance CannotUseEnsurePropertyWithInfo '[] = 'True
+type instance CannotUseEnsurePropertyWithInfo (t ': ts) =
+ Not (t `EqT` 'WithInfo) && CannotUseEnsurePropertyWithInfo ts
+
+-- | Constructs a property, like `property`, but provides its
+-- `OuterMetaTypes`.
+property'
+ :: SingI metatypes
+ => Desc
+ -> (OuterMetaTypes metatypes -> Propellor Result)
+ -> Property (Sing metatypes)
+property' d a =
+ let p = Property sing d (a (outerMetaTypes p)) mempty mempty
+ in p
+
+-- | Used to provide the metatypes of a Property to calls to
+-- 'ensureProperty` within it.
+newtype OuterMetaTypes metatypes = OuterMetaTypes (Sing metatypes)
+
+outerMetaTypes :: Property (Sing l) -> OuterMetaTypes l
+outerMetaTypes (Property metatypes _ _ _ _) = OuterMetaTypes metatypes
diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs
index e5ccf9b1..27d17135 100644
--- a/src/Propellor/Property.hs
+++ b/src/Propellor/Property.hs
@@ -18,7 +18,8 @@ module Propellor.Property (
-- * Constructing properties
, Propellor
, property
- --, ensureProperty
+ , property'
+ , ensureProperty
--, withOS
, unsupportedOS
, makeChange
@@ -49,8 +50,10 @@ import Prelude
import Propellor.Types
import Propellor.Types.ResultCheck
+import Propellor.Types.MetaTypes
import Propellor.Info
import Propellor.Exception
+import Propellor.EnsureProperty
import Utility.Exception
import Utility.Monad
import Utility.Misc
@@ -159,13 +162,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
diff --git a/src/Propellor/Property/File.hs b/src/Propellor/Property/File.hs
index 1f66dda2..2a74b5ed 100644
--- a/src/Propellor/Property/File.hs
+++ b/src/Propellor/Property/File.hs
@@ -46,8 +46,8 @@ hasPrivContentExposedFrom = hasPrivContent' writeFile
hasPrivContent' :: (IsContext c, IsPrivDataSource s) => (FilePath -> String -> IO ()) -> s -> FilePath -> c -> Property HasInfo
hasPrivContent' writer source f context =
withPrivData source context $ \getcontent ->
- property desc $ getcontent $ \privcontent ->
- ensureProperty $ fileProperty' writer desc
+ property' desc $ \o -> getcontent $ \privcontent ->
+ ensureProperty o $ fileProperty' writer desc
(\_oldcontent -> privDataLines privcontent) f
where
desc = "privcontent " ++ f
@@ -72,10 +72,11 @@ f `lacksLines` ls = fileProperty (f ++ " remove: " ++ show [ls]) (filter (`notEl
-- | Replaces the content of a file with the transformed content of another file
basedOn :: FilePath -> (FilePath, [Line] -> [Line]) -> Property UnixLike
-f `basedOn` (f', a) = property desc $ go =<< (liftIO $ readFile f')
+f `basedOn` (f', a) = property' desc $ \o -> do
+ tmpl <- liftIO $ readFile f'
+ ensureProperty o $ fileProperty desc (\_ -> a $ lines $ tmpl) f
where
desc = "replace " ++ f
- go tmpl = ensureProperty $ fileProperty desc (\_ -> a $ lines $ tmpl) f
-- | Removes a file. Does not remove symlinks or non-plain-files.
notPresent :: FilePath -> Property UnixLike
diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs
index 866e8090..d30a39f3 100644
--- a/src/Propellor/Types.hs
+++ b/src/Propellor/Types.hs
@@ -13,9 +13,9 @@
module Propellor.Types
( Host(..)
, Property(..)
+ , property
, Info
, Desc
- , property
, MetaType(..)
, OS(..)
, UnixLike
@@ -172,7 +172,7 @@ ignoreInfo =
-- | Gets the action that can be run to satisfy a Property.
-- You should never run this action directly. Use
--- 'Propellor.Engine.ensureProperty` instead.
+-- 'Propellor.EnsureProperty.ensureProperty` instead.
propertySatisfy :: Property metatypes -> Propellor Result
propertySatisfy (Property _ _ a _ _) = a
diff --git a/src/Propellor/Types/MetaTypes.hs b/src/Propellor/Types/MetaTypes.hs
index 7f7dae13..3d178641 100644
--- a/src/Propellor/Types/MetaTypes.hs
+++ b/src/Propellor/Types/MetaTypes.hs
@@ -9,46 +9,19 @@ module Propellor.Types.MetaTypes (
FreeBSD,
HasInfo,
type (+),
- OuterMetaTypes,
- ensureProperty,
- tightenTargets,
- pickOS,
Sing,
sing,
SingI,
Union,
IncludesInfo,
+ Targets,
+ NotSuperset,
+ CheckCombineTargets(..),
+ type (&&),
+ Not,
+ EqT,
) where
------ DEMO ----------
-
-foo :: Property (HasInfo + FreeBSD)
-foo = mkProperty' $ \t -> do
- ensureProperty t jail
-
-bar :: Property (Debian + FreeBSD)
-bar = aptinstall `pickOS` jail
-
-aptinstall :: Property Debian
-aptinstall = mkProperty $ do
- return ()
-
-jail :: Property FreeBSD
-jail = mkProperty $ do
- return ()
-
------ END DEMO ----------
-
-data Property metatypes = Property metatypes (IO ())
-
-mkProperty :: SingI l => IO () -> Property (Sing l)
-mkProperty = mkProperty' . const
-
-mkProperty' :: SingI l => (OuterMetaTypes l -> IO ()) -> Property (Sing l)
-mkProperty' a =
- let p = Property sing (a (outerMetaTypes p))
- in p
-
data MetaType
= Targeting OS -- ^ A target OS of a Property
| WithInfo -- ^ Indicates that a Property has associated Info
@@ -112,39 +85,13 @@ type instance Concat (a ': as) bs = a ': (Concat as bs)
type family IncludesInfo t :: Bool
type instance IncludesInfo (Sing l) = Elem 'WithInfo l
-newtype OuterMetaTypes l = OuterMetaTypes (Sing l)
-
-outerMetaTypes :: Property (Sing l) -> OuterMetaTypes l
-outerMetaTypes (Property metatypes _) = OuterMetaTypes metatypes
-
--- | Use `mkProperty''` to get the `OuterMetaTypes`. For example:
---
--- > foo = Property Debian
--- > foo = mkProperty' $ \t -> do
--- > ensureProperty t (aptInstall "foo")
---
--- The type checker will prevent using ensureProperty with a property
--- that does not support the target OSes needed by the OuterMetaTypes.
--- In the example above, aptInstall must support Debian.
---
--- The type checker will also prevent using ensureProperty with a property
--- with HasInfo in its MetaTypes. Doing so would cause the info associated
--- with the property to be lost.
-ensureProperty
- ::
- ( (Targets inner `NotSuperset` Targets outer) ~ 'CanCombineTargets
- , CannotUseEnsurePropertyWithInfo inner ~ 'True
- )
- => OuterMetaTypes outer
- -> Property (Sing inner)
- -> IO ()
-ensureProperty (OuterMetaTypes outermetatypes) (Property innermetatypes a) = a
-
-- The name of this was chosen to make type errors a more understandable.
type family CannotUseEnsurePropertyWithInfo (l :: [a]) :: Bool
type instance CannotUseEnsurePropertyWithInfo '[] = 'True
type instance CannotUseEnsurePropertyWithInfo (t ': ts) = Not (t `EqT` 'WithInfo) && CannotUseEnsurePropertyWithInfo ts
+{-
+
-- | Tightens the MetaType list of a Property, to contain fewer targets.
--
-- Anything else in the MetaType list is passed through unchanged.
@@ -178,6 +125,8 @@ pickOS a@(Property ta ioa) b@(Property tb iob) = Property sing io
-- system being run on.
io = undefined
+-}
+
data CheckCombineTargets = CannotCombineTargets | CanCombineTargets
-- | Detect intersection of two lists that don't have any common targets.