From 83cd812ab5ac787769b34f59d1763f3c8648f06a Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 24 Mar 2016 17:25:58 -0400 Subject: convert ensureProperty Moved to its own module to keep everything related in one place. --- src/Propellor/Base.hs | 12 +++---- src/Propellor/EnsureProperty.hs | 66 +++++++++++++++++++++++++++++++++++++ src/Propellor/Property.hs | 12 +++---- src/Propellor/Property/File.hs | 9 ++--- src/Propellor/Types.hs | 4 +-- src/Propellor/Types/MetaTypes.hs | 71 ++++++---------------------------------- 6 files changed, 93 insertions(+), 81 deletions(-) create mode 100644 src/Propellor/EnsureProperty.hs (limited to 'src/Propellor') 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. -- cgit v1.2.3