From 70b77dd31c4538361a844ef049bed9ad2f273a3b Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 16 Mar 2016 14:40:14 -0400 Subject: wip --- propellor.cabal | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'propellor.cabal') diff --git a/propellor.cabal b/propellor.cabal index 4e0e1db2..4db210d0 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -144,6 +144,7 @@ Library Propellor.Exception Propellor.Types Propellor.Types.Chroot + Propellor.Types.CmdLine Propellor.Types.Container Propellor.Types.Docker Propellor.Types.Dns @@ -153,7 +154,7 @@ Library Propellor.Types.PrivData Propellor.Types.Result Propellor.Types.ResultCheck - Propellor.Types.CmdLine + Propellor.Types.Target Propellor.Types.ZFS Other-Modules: Propellor.Bootstrap -- cgit v1.3-2-g0d8e From 719286cb036d2623ce0604bd10584f2e88c7e49e Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 20 Mar 2016 13:10:48 -0400 Subject: rename module --- propellor.cabal | 2 +- src/Propellor/Types/PropTypes.hs | 279 +++++++++++++++++++++++++++++++++++++++ src/Propellor/Types/Target.hs | 279 --------------------------------------- 3 files changed, 280 insertions(+), 280 deletions(-) create mode 100644 src/Propellor/Types/PropTypes.hs delete mode 100644 src/Propellor/Types/Target.hs (limited to 'propellor.cabal') diff --git a/propellor.cabal b/propellor.cabal index 4db210d0..f84403f2 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -152,9 +152,9 @@ Library Propellor.Types.Info Propellor.Types.OS Propellor.Types.PrivData + Propellor.Types.PropTypes Propellor.Types.Result Propellor.Types.ResultCheck - Propellor.Types.Target Propellor.Types.ZFS Other-Modules: Propellor.Bootstrap diff --git a/src/Propellor/Types/PropTypes.hs b/src/Propellor/Types/PropTypes.hs new file mode 100644 index 00000000..d3d04dca --- /dev/null +++ b/src/Propellor/Types/PropTypes.hs @@ -0,0 +1,279 @@ +{-# LANGUAGE TypeOperators, PolyKinds, DataKinds, TypeFamilies, UndecidableInstances, FlexibleInstances, GADTs #-} + +module Propellor.Types.PropTypes ( + Property(..), + mkProperty, + mkProperty', + OS(..), + PropType(..), + UnixLike, + Debian, + Buntish, + FreeBSD, + HasInfo, + (:+:), + OuterPropTypes, + ensureProperty, + tightenTargets, + pickOS, + Sing, + WithTypes, +) 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 proptypes = Property proptypes (IO ()) + +mkProperty :: Sing l => IO () -> Property (WithTypes l) +mkProperty = mkProperty' . const + +mkProperty' :: Sing l => (OuterPropTypes l -> IO ()) -> Property (WithTypes l) +mkProperty' a = + let p = Property sing (a (outerPropTypes p)) + in p + +data OS + = OSDebian + | OSBuntish -- ^ A well-known Debian derivative founded by a space tourist. The actual name of this distribution is not used in Propellor per + | OSFreeBSD + deriving (Show, Eq) + +data PropType + = Targeting OS -- ^ A target OS of a Property + | WithInfo -- ^ Indicates that a Property has associated Info + deriving (Show, Eq) + +-- | Any unix-like system +type UnixLike = WithTypes '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish, 'Targeting 'OSFreeBSD ] +type Debian = WithTypes '[ 'Targeting 'OSDebian ] +type Buntish = WithTypes '[ 'Targeting 'OSBuntish ] +type FreeBSD = WithTypes '[ 'Targeting 'OSFreeBSD ] + +-- | Used to indicate that a Property adds Info to the Host where it's used. +type HasInfo = WithTypes '[ 'WithInfo ] + +-- | A family of type-level lists of [`PropType`] +data family WithTypes (x :: k) + +-- | Singletons +class Sing t where + sing :: WithTypes t + +data instance WithTypes (x :: [k]) where + Nil :: WithTypes '[] + Cons :: WithTypes x -> WithTypes xs -> WithTypes (x ': xs) + +instance (Sing x, Sing xs) => Sing (x ': xs) where sing = Cons sing sing +instance Sing '[] where sing = Nil + +-- This boilerplatw would not be needed if the singletons library were +-- used. However, we're targeting too old a version of ghc to use it yet. +data instance WithTypes (x :: PropType) where + OSDebianS :: WithTypes ('Targeting 'OSDebian) + OSBuntishS :: WithTypes ('Targeting 'OSBuntish) + OSFreeBSDS :: WithTypes ('Targeting 'OSFreeBSD) + WithInfoS :: WithTypes 'WithInfo +instance Sing ('Targeting 'OSDebian) where sing = OSDebianS +instance Sing ('Targeting 'OSBuntish) where sing = OSBuntishS +instance Sing ('Targeting 'OSFreeBSD) where sing = OSFreeBSDS +instance Sing 'WithInfo where sing = WithInfoS + +-- | Convenience type operator to combine two `WithTypes` lists. +-- +-- For example: +-- +-- > HasInfo :+: Debian +-- +-- Which is shorthand for this type: +-- +-- > WithTypes '[WithInfo, Targeting OSDebian] +type family a :+: b :: ab +type instance (WithTypes a) :+: (WithTypes b) = WithTypes (Concat a b) + +type family Concat (list1 :: [a]) (list2 :: [a]) :: [a] +type instance Concat '[] bs = bs +type instance Concat (a ': as) bs = a ': (Concat as bs) + +newtype OuterPropTypes l = OuterPropTypes (WithTypes l) + +outerPropTypes :: Property (WithTypes l) -> OuterPropTypes l +outerPropTypes (Property proptypes _) = OuterPropTypes proptypes + +-- | Use `mkProperty''` to get the `OuterPropTypes`. 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 OuterPropTypes. +-- In the example above, aptInstall must support Debian. +-- +-- The type checker will also prevent using ensureProperty with a property +-- with HasInfo in its PropTypes. Doing so would cause the info associated +-- with the property to be lost. +ensureProperty + :: + ( (Targets inner `NotSuperset` Targets outer) ~ 'CanCombineTargets + , CannotUseEnsurePropertyWithInfo inner ~ 'True + ) + => OuterPropTypes outer + -> Property (WithTypes inner) + -> IO () +ensureProperty (OuterPropTypes outerproptypes) (Property innerproptypes 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 PropType list of a Property, to contain fewer targets. +-- +-- Anything else in the PropType list is passed through unchanged. +tightenTargets + :: + ( combined ~ Concat (NonTargets old) (Intersect (Targets old) (Targets new)) + , CannotCombineTargets old new combined ~ 'CanCombineTargets + , Sing combined + ) + => WithTypes new + -> Property (WithTypes old) + -> Property (WithTypes combined) +tightenTargets _ (Property old a) = Property sing a + +-- | 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. +pickOS + :: + ( combined ~ Union a b + , Sing combined + ) + => Property (WithTypes a) + -> Property (WithTypes b) + -> Property (WithTypes combined) +pickOS a@(Property ta ioa) b@(Property tb iob) = Property sing io + where + -- TODO pick with of ioa or iob to use based on final OS of + -- system being run on. + io = undefined + +data CheckCombineTargets = CannotCombineTargets | CanCombineTargets + +-- | Detect intersection of two lists that don't have any common targets. +-- +-- The name of this was chosen to make type errors a more understandable. +type family CannotCombineTargets (list1 :: [a]) (list2 :: [a]) (listr :: [a]) :: CheckCombineTargets +type instance CannotCombineTargets l1 l2 '[] = 'CannotCombineTargets +type instance CannotCombineTargets l1 l2 (a ': rest) = 'CanCombineTargets + +-- | Every item in the subset must be in the superset. +-- +-- The name of this was chosen to make type errors a more understandable. +type family NotSuperset (superset :: [a]) (subset :: [a]) :: CheckCombineTargets +type instance NotSuperset superset '[] = 'CanCombineTargets +type instance NotSuperset superset (s ': rest) = + If (Elem s superset) + (NotSuperset superset rest) + 'CannotCombineTargets + +type family IsTarget (a :: t) :: Bool +type instance IsTarget ('Targeting a) = 'True +type instance IsTarget 'WithInfo = 'False + +type family Targets (l :: [a]) :: [a] +type instance Targets '[] = '[] +type instance Targets (x ': xs) = + If (IsTarget x) + (x ': Targets xs) + (Targets xs) + +type family NonTargets (l :: [a]) :: [a] +type instance NonTargets '[] = '[] +type instance NonTargets (x ': xs) = + If (IsTarget x) + (Targets xs) + (x ': Targets xs) + +-- | Type level elem +type family Elem (a :: t) (list :: [t]) :: Bool +type instance Elem a '[] = 'False +type instance Elem a (b ': bs) = EqT a b || Elem a bs + +-- | Type level union. +type family Union (list1 :: [a]) (list2 :: [a]) :: [a] +type instance Union '[] list2 = list2 +type instance Union (a ': rest) list2 = + If (Elem a list2 || Elem a rest) + (Union rest list2) + (a ': Union rest list2) + +-- | Type level intersection. Duplicate list items are eliminated. +type family Intersect (list1 :: [a]) (list2 :: [a]) :: [a] +type instance Intersect '[] list2 = '[] +type instance Intersect (a ': rest) list2 = + If (Elem a list2 && Not (Elem a rest)) + (a ': Intersect rest list2) + (Intersect rest list2) + +-- | Type level equality +-- +-- This is a very clumsy implmentation, but it works back to ghc 7.6. +type family EqT (a :: t) (b :: t) :: Bool +type instance EqT ('Targeting a) ('Targeting b) = EqT a b +type instance EqT 'WithInfo 'WithInfo = 'True +type instance EqT 'WithInfo ('Targeting b) = 'False +type instance EqT ('Targeting a) 'WithInfo = 'False +type instance EqT 'OSDebian 'OSDebian = 'True +type instance EqT 'OSBuntish 'OSBuntish = 'True +type instance EqT 'OSFreeBSD 'OSFreeBSD = 'True +type instance EqT 'OSDebian 'OSBuntish = 'False +type instance EqT 'OSDebian 'OSFreeBSD = 'False +type instance EqT 'OSBuntish 'OSDebian = 'False +type instance EqT 'OSBuntish 'OSFreeBSD = 'False +type instance EqT 'OSFreeBSD 'OSDebian = 'False +type instance EqT 'OSFreeBSD 'OSBuntish = 'False +-- More modern version if the combinatiorial explosion gets too bad later: +-- +-- type family Eq (a :: PropType) (b :: PropType) where +-- Eq a a = True +-- Eq a b = False + +-- | An equivilant to the following is in Data.Type.Bool in +-- modern versions of ghc, but is included here to support ghc 7.6. +type family If (cond :: Bool) (tru :: a) (fls :: a) :: a +type instance If 'True tru fls = tru +type instance If 'False tru fls = fls +type family (a :: Bool) || (b :: Bool) :: Bool +type instance 'False || 'False = 'False +type instance 'True || 'True = 'True +type instance 'True || 'False = 'True +type instance 'False || 'True = 'True +type family (a :: Bool) && (b :: Bool) :: Bool +type instance 'False && 'False = 'False +type instance 'True && 'True = 'True +type instance 'True && 'False = 'False +type instance 'False && 'True = 'False +type family Not (a :: Bool) :: Bool +type instance Not 'False = 'True +type instance Not 'True = 'False + diff --git a/src/Propellor/Types/Target.hs b/src/Propellor/Types/Target.hs deleted file mode 100644 index 420c6ed2..00000000 --- a/src/Propellor/Types/Target.hs +++ /dev/null @@ -1,279 +0,0 @@ -{-# LANGUAGE TypeOperators, PolyKinds, DataKinds, TypeFamilies, UndecidableInstances, FlexibleInstances, GADTs #-} - -module Propellor.Types.Target ( - Property(..), - mkProperty, - mkProperty', - OS(..), - PropType(..), - UnixLike, - Debian, - Buntish, - FreeBSD, - HasInfo, - (:+:), - OuterPropTypes, - ensureProperty, - tightenTargets, - pickOS, - Sing, - WithTypes, -) 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 proptypes = Property proptypes (IO ()) - -mkProperty :: Sing l => IO () -> Property (WithTypes l) -mkProperty = mkProperty' . const - -mkProperty' :: Sing l => (OuterPropTypes l -> IO ()) -> Property (WithTypes l) -mkProperty' a = - let p = Property sing (a (outerPropTypes p)) - in p - -data OS - = OSDebian - | OSBuntish -- ^ A well-known Debian derivative founded by a space tourist. The actual name of this distribution is not used in Propellor per - | OSFreeBSD - deriving (Show, Eq) - -data PropType - = Targeting OS -- ^ A target OS of a Property - | WithInfo -- ^ Indicates that a Property has associated Info - deriving (Show, Eq) - --- | Any unix-like system -type UnixLike = WithTypes '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish, 'Targeting 'OSFreeBSD ] -type Debian = WithTypes '[ 'Targeting 'OSDebian ] -type Buntish = WithTypes '[ 'Targeting 'OSBuntish ] -type FreeBSD = WithTypes '[ 'Targeting 'OSFreeBSD ] - --- | Used to indicate that a Property adds Info to the Host where it's used. -type HasInfo = WithTypes '[ 'WithInfo ] - --- | A family of type-level lists of [`PropType`] -data family WithTypes (x :: k) - --- | Singletons -class Sing t where - sing :: WithTypes t - -data instance WithTypes (x :: [k]) where - Nil :: WithTypes '[] - Cons :: WithTypes x -> WithTypes xs -> WithTypes (x ': xs) - -instance (Sing x, Sing xs) => Sing (x ': xs) where sing = Cons sing sing -instance Sing '[] where sing = Nil - --- This boilerplatw would not be needed if the singletons library were --- used. However, we're targeting too old a version of ghc to use it yet. -data instance WithTypes (x :: PropType) where - OSDebianS :: WithTypes ('Targeting 'OSDebian) - OSBuntishS :: WithTypes ('Targeting 'OSBuntish) - OSFreeBSDS :: WithTypes ('Targeting 'OSFreeBSD) - WithInfoS :: WithTypes 'WithInfo -instance Sing ('Targeting 'OSDebian) where sing = OSDebianS -instance Sing ('Targeting 'OSBuntish) where sing = OSBuntishS -instance Sing ('Targeting 'OSFreeBSD) where sing = OSFreeBSDS -instance Sing 'WithInfo where sing = WithInfoS - --- | Convenience type operator to combine two `WithTypes` lists. --- --- For example: --- --- > HasInfo :+: Debian --- --- Which is shorthand for this type: --- --- > WithTypes '[WithInfo, Targeting OSDebian] -type family a :+: b :: ab -type instance (WithTypes a) :+: (WithTypes b) = WithTypes (Concat a b) - -type family Concat (list1 :: [a]) (list2 :: [a]) :: [a] -type instance Concat '[] bs = bs -type instance Concat (a ': as) bs = a ': (Concat as bs) - -newtype OuterPropTypes l = OuterPropTypes (WithTypes l) - -outerPropTypes :: Property (WithTypes l) -> OuterPropTypes l -outerPropTypes (Property proptypes _) = OuterPropTypes proptypes - --- | Use `mkProperty''` to get the `OuterPropTypes`. 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 OuterPropTypes. --- In the example above, aptInstall must support Debian. --- --- The type checker will also prevent using ensureProperty with a property --- with HasInfo in its PropTypes. Doing so would cause the info associated --- with the property to be lost. -ensureProperty - :: - ( (Targets inner `NotSuperset` Targets outer) ~ 'CanCombineTargets - , CannotUseEnsurePropertyWithInfo inner ~ 'True - ) - => OuterPropTypes outer - -> Property (WithTypes inner) - -> IO () -ensureProperty (OuterPropTypes outerproptypes) (Property innerproptypes 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 PropType list of a Property, to contain fewer targets. --- --- Anything else in the PropType list is passed through unchanged. -tightenTargets - :: - ( combined ~ Concat (NonTargets old) (Intersect (Targets old) (Targets new)) - , CannotCombineTargets old new combined ~ 'CanCombineTargets - , Sing combined - ) - => WithTypes new - -> Property (WithTypes old) - -> Property (WithTypes combined) -tightenTargets _ (Property old a) = Property sing a - --- | 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. -pickOS - :: - ( combined ~ Union a b - , Sing combined - ) - => Property (WithTypes a) - -> Property (WithTypes b) - -> Property (WithTypes combined) -pickOS a@(Property ta ioa) b@(Property tb iob) = Property sing io - where - -- TODO pick with of ioa or iob to use based on final OS of - -- system being run on. - io = undefined - -data CheckCombineTargets = CannotCombineTargets | CanCombineTargets - --- | Detect intersection of two lists that don't have any common targets. --- --- The name of this was chosen to make type errors a more understandable. -type family CannotCombineTargets (list1 :: [a]) (list2 :: [a]) (listr :: [a]) :: CheckCombineTargets -type instance CannotCombineTargets l1 l2 '[] = 'CannotCombineTargets -type instance CannotCombineTargets l1 l2 (a ': rest) = 'CanCombineTargets - --- | Every item in the subset must be in the superset. --- --- The name of this was chosen to make type errors a more understandable. -type family NotSuperset (superset :: [a]) (subset :: [a]) :: CheckCombineTargets -type instance NotSuperset superset '[] = 'CanCombineTargets -type instance NotSuperset superset (s ': rest) = - If (Elem s superset) - (NotSuperset superset rest) - 'CannotCombineTargets - -type family IsTarget (a :: t) :: Bool -type instance IsTarget ('Targeting a) = 'True -type instance IsTarget 'WithInfo = 'False - -type family Targets (l :: [a]) :: [a] -type instance Targets '[] = '[] -type instance Targets (x ': xs) = - If (IsTarget x) - (x ': Targets xs) - (Targets xs) - -type family NonTargets (l :: [a]) :: [a] -type instance NonTargets '[] = '[] -type instance NonTargets (x ': xs) = - If (IsTarget x) - (Targets xs) - (x ': Targets xs) - --- | Type level elem -type family Elem (a :: t) (list :: [t]) :: Bool -type instance Elem a '[] = 'False -type instance Elem a (b ': bs) = EqT a b || Elem a bs - --- | Type level union. -type family Union (list1 :: [a]) (list2 :: [a]) :: [a] -type instance Union '[] list2 = list2 -type instance Union (a ': rest) list2 = - If (Elem a list2 || Elem a rest) - (Union rest list2) - (a ': Union rest list2) - --- | Type level intersection. Duplicate list items are eliminated. -type family Intersect (list1 :: [a]) (list2 :: [a]) :: [a] -type instance Intersect '[] list2 = '[] -type instance Intersect (a ': rest) list2 = - If (Elem a list2 && Not (Elem a rest)) - (a ': Intersect rest list2) - (Intersect rest list2) - --- | Type level equality --- --- This is a very clumsy implmentation, but it works back to ghc 7.6. -type family EqT (a :: t) (b :: t) :: Bool -type instance EqT ('Targeting a) ('Targeting b) = EqT a b -type instance EqT 'WithInfo 'WithInfo = 'True -type instance EqT 'WithInfo ('Targeting b) = 'False -type instance EqT ('Targeting a) 'WithInfo = 'False -type instance EqT 'OSDebian 'OSDebian = 'True -type instance EqT 'OSBuntish 'OSBuntish = 'True -type instance EqT 'OSFreeBSD 'OSFreeBSD = 'True -type instance EqT 'OSDebian 'OSBuntish = 'False -type instance EqT 'OSDebian 'OSFreeBSD = 'False -type instance EqT 'OSBuntish 'OSDebian = 'False -type instance EqT 'OSBuntish 'OSFreeBSD = 'False -type instance EqT 'OSFreeBSD 'OSDebian = 'False -type instance EqT 'OSFreeBSD 'OSBuntish = 'False --- More modern version if the combinatiorial explosion gets too bad later: --- --- type family Eq (a :: PropType) (b :: PropType) where --- Eq a a = True --- Eq a b = False - --- | An equivilant to the following is in Data.Type.Bool in --- modern versions of ghc, but is included here to support ghc 7.6. -type family If (cond :: Bool) (tru :: a) (fls :: a) :: a -type instance If 'True tru fls = tru -type instance If 'False tru fls = fls -type family (a :: Bool) || (b :: Bool) :: Bool -type instance 'False || 'False = 'False -type instance 'True || 'True = 'True -type instance 'True || 'False = 'True -type instance 'False || 'True = 'True -type family (a :: Bool) && (b :: Bool) :: Bool -type instance 'False && 'False = 'False -type instance 'True && 'True = 'True -type instance 'True && 'False = 'False -type instance 'False && 'True = 'False -type family Not (a :: Bool) :: Bool -type instance Not 'False = 'True -type instance Not 'True = 'False - -- cgit v1.3-2-g0d8e From 3aca4c62203c9586f396f35cb780c4a79fa0c099 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 24 Mar 2016 14:39:17 -0400 Subject: 1st stage integrating MetaTypes --- propellor.cabal | 2 +- src/Propellor/Types.hs | 298 ++++++++++++++++----------------------- src/Propellor/Types/MetaTypes.hs | 8 +- 3 files changed, 125 insertions(+), 183 deletions(-) (limited to 'propellor.cabal') diff --git a/propellor.cabal b/propellor.cabal index c78b6d5f..fcad09e5 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -152,9 +152,9 @@ Library Propellor.Types.Dns Propellor.Types.Empty Propellor.Types.Info + Propellor.Types.MetaTypes Propellor.Types.OS Propellor.Types.PrivData - Propellor.Types.PropTypes Propellor.Types.Result Propellor.Types.ResultCheck Propellor.Types.ZFS diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs index 542a1f66..d1a93f47 100644 --- a/src/Propellor/Types.hs +++ b/src/Propellor/Types.hs @@ -7,23 +7,29 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE PolyKinds #-} module Propellor.Types ( Host(..) , Property , Info - , HasInfo - , NoInfo - , CInfo , Desc - , infoProperty - , simpleProperty + , mkProperty + , MetaType(..) + , OS(..) + , UnixLike + , Debian + , Buntish + , FreeBSD + , HasInfo + , type (+) + , addInfoProperty , adjustPropertySatisfy , propertyInfo , propertyDesc , propertyChildren , RevertableProperty(..) - , MkRevertableProperty(..) , IsProp(..) , Combines(..) , CombinedType @@ -36,7 +42,6 @@ module Propellor.Types , module Propellor.Types.Result , module Propellor.Types.ZFS , propertySatisfy - , ignoreInfo ) where import Data.Monoid @@ -50,13 +55,14 @@ import Propellor.Types.Info import Propellor.Types.OS import Propellor.Types.Dns import Propellor.Types.Result +import Propellor.Types.MetaTypes import Propellor.Types.ZFS -- | Everything Propellor knows about a system: Its hostname, -- properties and their collected info. data Host = Host { hostName :: HostName - , hostProperties :: [Property HasInfo] + , hostProperties :: [ChildProperty] , hostInfo :: Info } deriving (Show, Typeable) @@ -103,162 +109,158 @@ data EndAction = EndAction Desc (Result -> Propellor Result) type Desc = String -- | The core data type of Propellor, this represents a property --- that the system should have, and an action to ensure it has the --- property. +-- that the system should have, with a descrition, an action to ensure +-- it has the property, and perhaps some Info that can be added to Hosts +-- that have the property. -- --- A property can have associated `Info` or not. This is tracked at the --- type level with Property `NoInfo` and Property `HasInfo`. +-- A property has a list of `[MetaType]`, which is part of its type. -- -- There are many instances and type families, which are mostly used -- internally, so you needn't worry about them. -data Property i where - IProperty :: Desc -> Propellor Result -> Info -> [Property HasInfo] -> Property HasInfo - SProperty :: Desc -> Propellor Result -> [Property NoInfo] -> Property NoInfo - --- | Indicates that a Property has associated Info. -data HasInfo --- | Indicates that a Property does not have Info. -data NoInfo - --- | Type level calculation of the combination of HasInfo and/or NoInfo -type family CInfo x y -type instance CInfo HasInfo HasInfo = HasInfo -type instance CInfo HasInfo NoInfo = HasInfo -type instance CInfo NoInfo HasInfo = HasInfo -type instance CInfo NoInfo NoInfo = NoInfo - --- | Constructs a Property with associated Info. -infoProperty - :: Desc -- ^ description of the property - -> Propellor Result -- ^ action to run to satisfy the property (must be idempotent; may run repeatedly) - -> Info -- ^ info associated with the property - -> [Property i] -- ^ child properties - -> Property HasInfo -infoProperty d a i cs = IProperty d a i (map toIProperty cs) - --- | Constructs a Property with no Info. -simpleProperty :: Desc -> Propellor Result -> [Property NoInfo] -> Property NoInfo -simpleProperty = SProperty - -toIProperty :: Property i -> Property HasInfo -toIProperty p@(IProperty {}) = p -toIProperty (SProperty d s cs) = IProperty d s mempty (map toIProperty cs) - -toSProperty :: Property i -> Property NoInfo -toSProperty (IProperty d s _ cs) = SProperty d s (map toSProperty cs) -toSProperty p@(SProperty {}) = p +data Property metatypes = Property metatypes Desc (Propellor Result) Info [ChildProperty] + +-- | Since there are many different types of Properties, they cannot be put +-- into a list. The simplified ChildProperty can be put into a list. +data ChildProperty = ChildProperty Desc (Propellor Result) Info [ChildProperty] + +instance Show ChildProperty where + show (ChildProperty desc _ _ _) = desc + +-- | Constructs a Property. +-- +-- You can specify any metatypes that make sense to indicate what OS +-- the property targets, etc. +-- +-- For example: +-- +-- > foo :: Property Debian +-- > foo = mkProperty "foo" (...) +-- +-- Note that using this needs LANGUAGE PolyKinds. +mkProperty + :: SingI metatypes + => Desc + -> Propellor Result + -> Property (Sing metatypes) +mkProperty d a = Property sing d a mempty mempty + +-- | Adds info to a Property. +-- +-- The new Property will include HasInfo in its metatypes. +addInfoProperty + :: (metatypes' ~ (+) HasInfo metatypes, SingI metatypes') + => Property metatypes + -> Info + -> Property (Sing metatypes') +addInfoProperty (Property metatypes d a i c) newi = Property sing d a (i <> newi) c + +{- -- | Makes a version of a Proprty without its Info. -- Use with caution! -ignoreInfo :: Property i -> Property NoInfo -ignoreInfo = toSProperty +ignoreInfo + :: (metatypes' ~ + => Property metatypes + -> Property (Sing metatypes') +ignoreInfo = + +-} -- | Gets the action that can be run to satisfy a Property. -- You should never run this action directly. Use -- 'Propellor.Engine.ensureProperty` instead. -propertySatisfy :: Property i -> Propellor Result -propertySatisfy (IProperty _ a _ _) = a -propertySatisfy (SProperty _ a _) = a +propertySatisfy :: Property metatypes -> Propellor Result +propertySatisfy (Property _ _ a _ _) = a -- | Changes the action that is performed to satisfy a property. -adjustPropertySatisfy :: Property i -> (Propellor Result -> Propellor Result) -> Property i -adjustPropertySatisfy (IProperty d s i cs) f = IProperty d (f s) i cs -adjustPropertySatisfy (SProperty d s cs) f = SProperty d (f s) cs +adjustPropertySatisfy :: Property metatypes -> (Propellor Result -> Propellor Result) -> Property metatypes +adjustPropertySatisfy (Property t d s i c) f = Property t d (f s) i c -propertyInfo :: Property i -> Info -propertyInfo (IProperty _ _ i _) = i -propertyInfo (SProperty {}) = mempty +propertyInfo :: Property metatypes -> Info +propertyInfo (Property _ _ _ i _) = i -propertyDesc :: Property i -> Desc -propertyDesc (IProperty d _ _ _) = d -propertyDesc (SProperty d _ _) = d +propertyDesc :: Property metatypes -> Desc +propertyDesc (Property _ d _ _ _) = d -instance Show (Property i) where +instance Show (Property metatypes) where show p = "property " ++ show (propertyDesc p) -- | A Property can include a list of child properties that it also -- satisfies. This allows them to be introspected to collect their info, etc. -propertyChildren :: Property i -> [Property i] -propertyChildren (IProperty _ _ _ cs) = cs -propertyChildren (SProperty _ _ cs) = cs +propertyChildren :: Property metatypes -> [ChildProperty] +propertyChildren (Property _ _ _ _ c) = c -- | A property that can be reverted. The first Property is run -- normally and the second is run when it's reverted. -data RevertableProperty i = RevertableProperty - { setupRevertableProperty :: Property i - , undoRevertableProperty :: Property i +data RevertableProperty metatypes = RevertableProperty + { setupRevertableProperty :: Property metatypes + , undoRevertableProperty :: Property metatypes } -instance Show (RevertableProperty i) where +instance Show (RevertableProperty metatypes) where show (RevertableProperty p _) = show p -class MkRevertableProperty i1 i2 where - -- | Shorthand to construct a revertable property. - () :: Property i1 -> Property i2 -> RevertableProperty (CInfo i1 i2) - -instance MkRevertableProperty HasInfo HasInfo where - x y = RevertableProperty x y -instance MkRevertableProperty NoInfo NoInfo where - x y = RevertableProperty x y -instance MkRevertableProperty NoInfo HasInfo where - x y = RevertableProperty (toProp x) y -instance MkRevertableProperty HasInfo NoInfo where - x y = RevertableProperty x (toProp y) +-- | Shorthand to construct a revertable property from any two Properties +-- whose MetaTypes can be combined. +() + :: (metatypes ~ (+) metatypes1 metatypes2, SingI metatypes) + => Property metatypes1 + -> Property metatypes2 + -> RevertableProperty (Sing metatypes) +Property _ d1 s1 i1 c1 Property _ d2 s2 i2 c2 = RevertableProperty + (Property sing d1 s1 i1 c1) + (Property sing d2 s2 i2 c2) -- | Class of types that can be used as properties of a host. class IsProp p where setDesc :: p -> Desc -> p - toProp :: p -> Property HasInfo + -- toProp :: p -> Property HasInfo getDesc :: p -> Desc -- | Gets the info of the property, combined with all info -- of all children properties. getInfoRecursive :: p -> Info -instance IsProp (Property HasInfo) where - setDesc (IProperty _ a i cs) d = IProperty d a i cs - toProp = id +instance IsProp (Property metatypes) where + setDesc (Property t _ a i c) d = Property t d a i c + -- toProp = id getDesc = propertyDesc - getInfoRecursive (IProperty _ _ i cs) = - i <> mconcat (map getInfoRecursive cs) -instance IsProp (Property NoInfo) where - setDesc (SProperty _ a cs) d = SProperty d a cs - toProp = toIProperty - getDesc = propertyDesc - getInfoRecursive _ = mempty + getInfoRecursive (Property _ _ _ i c) = + i <> mconcat (map getInfoRecursive c) + +instance IsProp ChildProperty where + setDesc (ChildProperty _ a i c) d = ChildProperty d a i c + getDesc (ChildProperty d _ _ _) = d + getInfoRecursive (ChildProperty _ _ i c) = + i <> mconcat (map getInfoRecursive c) -instance IsProp (RevertableProperty HasInfo) where +instance IsProp (RevertableProperty metatypes) where setDesc = setDescR getDesc (RevertableProperty p1 _) = getDesc p1 - toProp (RevertableProperty p1 _) = p1 + -- toProp (RevertableProperty p1 _) = p1 -- | Return the Info of the currently active side. getInfoRecursive (RevertableProperty p1 _p2) = getInfoRecursive p1 -instance IsProp (RevertableProperty NoInfo) where - setDesc = setDescR - getDesc (RevertableProperty p1 _) = getDesc p1 - toProp (RevertableProperty p1 _) = toProp p1 - getInfoRecursive (RevertableProperty _ _) = mempty -- | Sets the description of both sides. -setDescR :: IsProp (Property i) => RevertableProperty i -> Desc -> RevertableProperty i +setDescR :: IsProp (Property metatypes) => RevertableProperty metatypes -> Desc -> RevertableProperty metatypes setDescR (RevertableProperty p1 p2) d = RevertableProperty (setDesc p1 d) (setDesc p2 ("not " ++ d)) -- | Type level calculation of the type that results from combining two -- types of properties. type family CombinedType x y -type instance CombinedType (Property x) (Property y) = Property (CInfo x y) -type instance CombinedType (RevertableProperty x) (RevertableProperty y) = RevertableProperty (CInfo x y) +type instance CombinedType (Property (Sing x)) (Property (Sing y)) = Property (Sing (Union x y)) +type instance CombinedType (RevertableProperty (Sing x)) (RevertableProperty (Sing y)) = RevertableProperty (Sing (Union x y)) -- When only one of the properties is revertable, the combined property is -- not fully revertable, so is not a RevertableProperty. -type instance CombinedType (RevertableProperty x) (Property y) = Property (CInfo x y) -type instance CombinedType (Property x) (RevertableProperty y) = Property (CInfo x y) +type instance CombinedType (RevertableProperty (Sing x)) (Property (Sing y)) = Property (Sing (Union x y)) +type instance CombinedType (Property (Sing x)) (RevertableProperty (Sing y)) = Property (Sing (Union x y)) type ResultCombiner = Propellor Result -> Propellor Result -> Propellor Result class Combines x y where -- | Combines together two properties, yielding a property that - -- has the description and info of the first, and that has the second - -- property as a child. + -- has the description and info of the first, and that has the + -- second property as a child property. combineWith :: ResultCombiner -- ^ How to combine the actions to satisfy the properties. @@ -269,73 +271,15 @@ class Combines x y where -> y -> CombinedType x y -instance Combines (Property HasInfo) (Property HasInfo) where - combineWith f _ (IProperty d1 a1 i1 cs1) y@(IProperty _d2 a2 _i2 _cs2) = - IProperty d1 (f a1 a2) i1 (y : cs1) - -instance Combines (Property HasInfo) (Property NoInfo) where - combineWith f _ (IProperty d1 a1 i1 cs1) y@(SProperty _d2 a2 _cs2) = - IProperty d1 (f a1 a2) i1 (toIProperty y : cs1) - -instance Combines (Property NoInfo) (Property HasInfo) where - combineWith f _ (SProperty d1 a1 cs1) y@(IProperty _d2 a2 _i2 _cs2) = - IProperty d1 (f a1 a2) mempty (y : map toIProperty cs1) - -instance Combines (Property NoInfo) (Property NoInfo) where - combineWith f _ (SProperty d1 a1 cs1) y@(SProperty _d2 a2 _cs2) = - SProperty d1 (f a1 a2) (y : cs1) - -instance Combines (RevertableProperty NoInfo) (RevertableProperty NoInfo) where - combineWith = combineWithRR -instance Combines (RevertableProperty HasInfo) (RevertableProperty HasInfo) where - combineWith = combineWithRR -instance Combines (RevertableProperty HasInfo) (RevertableProperty NoInfo) where - combineWith = combineWithRR -instance Combines (RevertableProperty NoInfo) (RevertableProperty HasInfo) where - combineWith = combineWithRR -instance Combines (RevertableProperty NoInfo) (Property HasInfo) where - combineWith = combineWithRP -instance Combines (RevertableProperty NoInfo) (Property NoInfo) where - combineWith = combineWithRP -instance Combines (RevertableProperty HasInfo) (Property HasInfo) where - combineWith = combineWithRP -instance Combines (RevertableProperty HasInfo) (Property NoInfo) where - combineWith = combineWithRP -instance Combines (Property HasInfo) (RevertableProperty NoInfo) where - combineWith = combineWithPR -instance Combines (Property NoInfo) (RevertableProperty NoInfo) where - combineWith = combineWithPR -instance Combines (Property HasInfo) (RevertableProperty HasInfo) where - combineWith = combineWithPR -instance Combines (Property NoInfo) (RevertableProperty HasInfo) where - combineWith = combineWithPR - -combineWithRR - :: Combines (Property x) (Property y) - => ResultCombiner - -> ResultCombiner - -> RevertableProperty x - -> RevertableProperty y - -> RevertableProperty (CInfo x y) -combineWithRR sf tf (RevertableProperty s1 t1) (RevertableProperty s2 t2) = - RevertableProperty - (combineWith sf tf s1 s2) - (combineWith tf sf t1 t2) - -combineWithRP - :: Combines (Property i) y - => (Propellor Result -> Propellor Result -> Propellor Result) - -> (Propellor Result -> Propellor Result -> Propellor Result) - -> RevertableProperty i - -> y - -> CombinedType (Property i) y -combineWithRP sf tf (RevertableProperty x _) y = combineWith sf tf x y - -combineWithPR - :: Combines x (Property i) - => (Propellor Result -> Propellor Result -> Propellor Result) - -> (Propellor Result -> Propellor Result -> Propellor Result) - -> x - -> RevertableProperty i - -> CombinedType x (Property i) -combineWithPR sf tf x (RevertableProperty y _) = combineWith sf tf x y +instance (CombinedType (Property (Sing x)) (Property (Sing y)) ~ Property (Sing (Union x y)), SingI (Union x y)) => Combines (Property (Sing x)) (Property (Sing y)) where + combineWith f _ (Property t1 d1 a1 i1 c1) (Property _t2 d2 a2 i2 c2) = + Property sing d1 (f a1 a2) i1 (ChildProperty d2 a2 i2 c2 : c1) +instance (CombinedType (RevertableProperty (Sing x)) (RevertableProperty (Sing y)) ~ RevertableProperty (Sing (Union x y)), SingI (Union x y)) => Combines (RevertableProperty (Sing x)) (RevertableProperty (Sing y)) where + combineWith sf tf (RevertableProperty s1 t1) (RevertableProperty s2 t2) = + RevertableProperty + (combineWith sf tf s1 s2) + (combineWith tf sf t1 t2) +instance (CombinedType (RevertableProperty (Sing x)) (Property (Sing y)) ~ Property (Sing (Union x y)), SingI (Union x y)) => Combines (RevertableProperty (Sing x)) (Property (Sing y)) where + combineWith sf tf (RevertableProperty x _) y = combineWith sf tf x y +instance (CombinedType (Property (Sing x)) (RevertableProperty (Sing y)) ~ Property (Sing (Union x y)), SingI (Union x y)) => Combines (Property (Sing x)) (RevertableProperty (Sing y)) where + combineWith sf tf x (RevertableProperty y _) = combineWith sf tf x y diff --git a/src/Propellor/Types/MetaTypes.hs b/src/Propellor/Types/MetaTypes.hs index de6ffea3..b6d72dcd 100644 --- a/src/Propellor/Types/MetaTypes.hs +++ b/src/Propellor/Types/MetaTypes.hs @@ -1,9 +1,6 @@ {-# LANGUAGE TypeOperators, PolyKinds, DataKinds, TypeFamilies, UndecidableInstances, FlexibleInstances, GADTs #-} module Propellor.Types.MetaTypes ( - Property(..), - mkProperty, - mkProperty', MetaType(..), OS(..), UnixLike, @@ -19,6 +16,7 @@ module Propellor.Types.MetaTypes ( Sing, sing, SingI, + Union, ) where ----- DEMO ---------- @@ -27,8 +25,8 @@ foo :: Property (HasInfo + FreeBSD) foo = mkProperty' $ \t -> do ensureProperty t jail --- bar :: Property (Debian + UsesPort 80 + FreeBSD) --- bar = aptinstall `pickOS` jail +bar :: Property (Debian + FreeBSD) +bar = aptinstall `pickOS` jail aptinstall :: Property Debian aptinstall = mkProperty $ do -- cgit v1.3-2-g0d8e From 7ee3157ab1922fd2f7158fd40927dca8a83ad4b0 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 24 Mar 2016 15:17:16 -0400 Subject: docs and enable PolyKinds globally --- debian/changelog | 32 ++++++++++++++++++++++++++++++-- propellor.cabal | 6 +++--- 2 files changed, 33 insertions(+), 5 deletions(-) (limited to 'propellor.cabal') diff --git a/debian/changelog b/debian/changelog index 2c2b2ea7..c9286fcf 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,31 @@ +propellor (3.0.0) UNRELEASED; urgency=medium + + * Property types have been improved to indicate what systems they target. + Transition guide: + - 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 PolyKinds #-} to use these new type signatures. + 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 (HasInfo + Debian)" + - It's also possible make a property support a set of OS's, for example: + "Property (HasInfo + Debian + FreeBSD)" + - The new `pickOS` property combinator can be used to combine different + properties, supporting different OS's, into one Property that chooses + what to do based on the Host's OS. + - `ensureProperty` now needs information about the metatypes of the + property it's used in to be passed to it. See the documentation + of `ensureProperty` for an example. + + -- Joey Hess Thu, 24 Mar 2016 15:02:33 -0400 + propellor (2.17.0) unstable; urgency=medium * Added initial support for FreeBSD. @@ -470,12 +498,12 @@ propellor (2.0.0) unstable; urgency=medium This was done to make sure that ensureProperty is only used on properties that do not have Info. Transition guide: - - Change all "Property" to "Property NoInfo" or "Property WithInfo" + - Change all "Property" to "Property NoInfo" or "Property HasInfo" (The compiler can tell you if you got it wrong!) - To construct a RevertableProperty, it is useful to use the new () operator - Constructing a list of properties can be problimatic, since - Property NoInto and Property WithInfo are different types and cannot + Property NoInto and Property HasInfo are different types and cannot appear in the same list. To deal with this, "props" has been added, and can built up a list of properties of different types, using the same (&) and (!) operators that are used to build diff --git a/propellor.cabal b/propellor.cabal index a631f262..1179ca23 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -36,7 +36,7 @@ Description: Executable propellor Main-Is: wrapper.hs - GHC-Options: -threaded -Wall -fno-warn-tabs + GHC-Options: -threaded -Wall -fno-warn-tabs -XPolyKinds Hs-Source-Dirs: src Build-Depends: -- propellor needs to support the ghc shipped in Debian stable @@ -47,7 +47,7 @@ Executable propellor Executable propellor-config Main-Is: config.hs - GHC-Options: -threaded -Wall -fno-warn-tabs + GHC-Options: -threaded -Wall -fno-warn-tabs -XPolyKinds Hs-Source-Dirs: src Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal, @@ -55,7 +55,7 @@ Executable propellor-config exceptions (>= 0.6), stm, text, unix Library - GHC-Options: -Wall -fno-warn-tabs + GHC-Options: -Wall -fno-warn-tabs -XPolyKinds Hs-Source-Dirs: src Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal, -- cgit v1.3-2-g0d8e From ab2204fc868f8f0e9fbc57a4b0b75996a38d934d Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 24 Mar 2016 15:41:30 -0400 Subject: TypeOperators, not PolyKinds is needed --- propellor.cabal | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'propellor.cabal') diff --git a/propellor.cabal b/propellor.cabal index 1179ca23..0a7746ed 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -36,7 +36,7 @@ Description: Executable propellor Main-Is: wrapper.hs - GHC-Options: -threaded -Wall -fno-warn-tabs -XPolyKinds + GHC-Options: -threaded -Wall -fno-warn-tabs -XTypeOperators Hs-Source-Dirs: src Build-Depends: -- propellor needs to support the ghc shipped in Debian stable @@ -47,7 +47,7 @@ Executable propellor Executable propellor-config Main-Is: config.hs - GHC-Options: -threaded -Wall -fno-warn-tabs -XPolyKinds + GHC-Options: -threaded -Wall -fno-warn-tabs -XTypeOperators Hs-Source-Dirs: src Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal, @@ -55,7 +55,7 @@ Executable propellor-config exceptions (>= 0.6), stm, text, unix Library - GHC-Options: -Wall -fno-warn-tabs -XPolyKinds + GHC-Options: -Wall -fno-warn-tabs -XTypeOperators Hs-Source-Dirs: src Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal, -- cgit v1.3-2-g0d8e 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. --- propellor.cabal | 1 + 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 ++++++---------------------------------- 7 files changed, 94 insertions(+), 81 deletions(-) create mode 100644 src/Propellor/EnsureProperty.hs (limited to 'propellor.cabal') 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. -- cgit v1.3-2-g0d8e From 63ed6dcd7b2e916f17514abe7860df9a135e1be9 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 24 Mar 2016 17:31:47 -0400 Subject: docs --- debian/changelog | 11 +++++++---- propellor.cabal | 2 +- 2 files changed, 8 insertions(+), 5 deletions(-) (limited to 'propellor.cabal') diff --git a/debian/changelog b/debian/changelog index f1138eb2..323394f9 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,7 +1,8 @@ propellor (3.0.0) UNRELEASED; urgency=medium * Property types have been improved to indicate what systems they target. - Transition guide: + This allows, eg, Property Debian to not be used on a FreeBSD system. + Transition guide for this sweeping API change: - Change "Property NoInfo" to "Property UnixLike" - Change "Property HasInfo" to "Property (HasInfo + UnixLike)" - Change "RevertableProperty NoInfo" to @@ -17,12 +18,14 @@ propellor (3.0.0) UNRELEASED; urgency=medium "Property (HasInfo + Debian)" - It's also possible make a property support a set of OS's, for example: "Property (HasInfo + Debian + FreeBSD)" + - `ensureProperty` now needs information about the metatypes of the + property it's used in to be passed to it. See the documentation + of `ensureProperty` for an example, but basically, change + this: foo = property desc $ ... ensureProperty bar + to this: foo = property' desc $ \o -> ... ensureProperty o bar - The new `pickOS` property combinator can be used to combine different properties, supporting different OS's, into one Property that chooses what to do based on the Host's OS. - - `ensureProperty` now needs information about the metatypes of the - property it's used in to be passed to it. See the documentation - of `ensureProperty` for an example. -- Joey Hess Thu, 24 Mar 2016 15:02:33 -0400 diff --git a/propellor.cabal b/propellor.cabal index a13ebcb5..c8c68e48 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -1,5 +1,5 @@ Name: propellor -Version: 2.17.0 +Version: 3.0.0 Cabal-Version: >= 1.8 License: BSD3 Maintainer: Joey Hess -- cgit v1.3-2-g0d8e From 57adcf0e445ae31cf9a9db66d3a7f4793c8399a6 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 25 Mar 2016 18:45:49 -0400 Subject: avoid cabal warning --- propellor.cabal | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) (limited to 'propellor.cabal') diff --git a/propellor.cabal b/propellor.cabal index c8c68e48..e47bb2e6 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -36,7 +36,8 @@ Description: Executable propellor Main-Is: wrapper.hs - GHC-Options: -threaded -Wall -fno-warn-tabs -XTypeOperators + GHC-Options: -threaded -Wall -fno-warn-tabs + Extensions: TypeOperators Hs-Source-Dirs: src Build-Depends: -- propellor needs to support the ghc shipped in Debian stable @@ -47,7 +48,8 @@ Executable propellor Executable propellor-config Main-Is: config.hs - GHC-Options: -threaded -Wall -fno-warn-tabs -XTypeOperators + GHC-Options: -threaded -Wall -fno-warn-tabs + Extensions: TypeOperators Hs-Source-Dirs: src Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal, @@ -55,7 +57,8 @@ Executable propellor-config exceptions (>= 0.6), stm, text, unix Library - GHC-Options: -Wall -fno-warn-tabs -XTypeOperators + GHC-Options: -Wall -fno-warn-tabs + Extensions: TypeOperators Hs-Source-Dirs: src Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal, -- cgit v1.3-2-g0d8e From 36e97137e538de401bd0340b469e10dca5f4b475 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 26 Mar 2016 19:31:23 -0400 Subject: ported propagateContainer Renamed several utility functions along the way. --- debian/changelog | 5 ++++ doc/todo/type_level_OS_requirements.mdwn | 7 ++--- propellor.cabal | 1 + src/Propellor/Container.hs | 46 ++++++++++++++++++++++++++++++ src/Propellor/Info.hs | 6 ++-- src/Propellor/PrivData.hs | 4 +-- src/Propellor/PropAccum.hs | 33 ---------------------- src/Propellor/Property/Chroot.hs | 43 +++++++++++++--------------- src/Propellor/Property/Concurrent.hs | 2 +- src/Propellor/Property/Conductor.hs | 8 +++--- src/Propellor/Property/Dns.hs | 10 +++---- src/Propellor/Property/Docker.hs | 10 +++---- src/Propellor/Property/List.hs | 4 +-- src/Propellor/Property/Partition.hs | 2 +- src/Propellor/Property/Postfix.hs | 2 +- src/Propellor/Property/Scheduled.hs | 6 ++-- src/Propellor/Property/Systemd.hs | 18 ++++++------ src/Propellor/Spin.hs | 4 +-- src/Propellor/Types.hs | 48 +++++++++++++------------------- src/Propellor/Types/Info.hs | 6 ++-- 20 files changed, 134 insertions(+), 131 deletions(-) create mode 100644 src/Propellor/Container.hs (limited to 'propellor.cabal') diff --git a/debian/changelog b/debian/changelog index df518753..8a5b67e4 100644 --- a/debian/changelog +++ b/debian/changelog @@ -49,6 +49,11 @@ propellor (3.0.0) UNRELEASED; urgency=medium 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 what to do based on the Host's OS. diff --git a/doc/todo/type_level_OS_requirements.mdwn b/doc/todo/type_level_OS_requirements.mdwn index 7c2fb78f..f1c3e59f 100644 --- a/doc/todo/type_level_OS_requirements.mdwn +++ b/doc/todo/type_level_OS_requirements.mdwn @@ -21,13 +21,12 @@ withOS. The `os` property would need to yield a `Property (os:[])`, where the type level list contains a type-level eqivilant of the value passed to the -property. Is that possible to do? reification or something? -(See: ) -Or, alternatively, could have less polymorphic `debian` etc +property. Is that possible to do? +Or, alternatively, could have less polymorphic `osDebian` etc properties replace the `os` property. If a Host's list of properties, when all combined together, -contains more than one element in its '[OS], that needs to be a type error, +contains more than one element in its '[OS], that could be a type error, the OS of the Host is indeterminite. Which would be fixed by using the `os` property to specify. diff --git a/propellor.cabal b/propellor.cabal index e47bb2e6..4a7739d3 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -141,6 +141,7 @@ Library Propellor.PropAccum Propellor.Utilities Propellor.CmdLine + Propellor.Container Propellor.Info Propellor.Message Propellor.Debug diff --git a/src/Propellor/Container.hs b/src/Propellor/Container.hs new file mode 100644 index 00000000..6e974efd --- /dev/null +++ b/src/Propellor/Container.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE DataKinds, TypeFamilies #-} + +module Propellor.Container where + +import Propellor.Types +import Propellor.Types.MetaTypes +import Propellor.Types.Info +import Propellor.PrivData + +class Container c where + containerProperties :: c -> [ChildProperty] + containerInfo :: c -> Info + +instance Container Host where + containerProperties = hostProperties + containerInfo = hostInfo + +-- | Adjust the provided Property, adding to its +-- propertyChidren the properties of the provided container. +-- +-- The Info of the propertyChildren is adjusted to only include +-- info that should be propagated out to the Property. +-- +-- Any PrivInfo that uses HostContext is adjusted to use the name +-- of the container as its context. +propagateContainer + :: + -- Since the children being added probably have info, + -- require the Property's metatypes to have info. + ( IncludesInfo metatypes ~ 'True + , Container c + ) + => String + -> c + -> Property metatypes + -> Property metatypes +propagateContainer containername c prop = prop + `addChildren` map convert (containerProperties c) + where + convert p = + let n = property (getDesc p) (getSatisfy p) :: Property UnixLike + n' = n + `addInfoProperty` mapInfo (forceHostContext containername) + (propagatableInfo (getInfo p)) + `addChildren` map convert (getChildren p) + in toChildProperty n' diff --git a/src/Propellor/Info.hs b/src/Propellor/Info.hs index 725a02ad..ff0b3b5e 100644 --- a/src/Propellor/Info.hs +++ b/src/Propellor/Info.hs @@ -42,7 +42,7 @@ pureInfoProperty' desc i = addInfoProperty p i -- | Gets a value from the host's Info. askInfo :: (IsInfo v) => Propellor v -askInfo = asks (getInfo . hostInfo) +askInfo = asks (fromInfo . hostInfo) -- | Specifies that a host's operating system is Debian, -- and further indicates the suite and architecture. @@ -129,7 +129,7 @@ hostMap l = M.fromList $ zip (map hostName l) l aliasMap :: [Host] -> M.Map HostName Host aliasMap = M.fromList . concat . - map (\h -> map (\aka -> (aka, h)) $ fromAliasesInfo $ getInfo $ hostInfo h) + map (\h -> map (\aka -> (aka, h)) $ fromAliasesInfo $ fromInfo $ hostInfo h) findHost :: [Host] -> HostName -> Maybe Host findHost l hn = (findHostNoAlias l hn) <|> (findAlias l hn) @@ -141,7 +141,7 @@ findAlias :: [Host] -> HostName -> Maybe Host findAlias l hn = M.lookup hn (aliasMap l) getAddresses :: Info -> [IPAddr] -getAddresses = mapMaybe getIPAddr . S.toList . fromDnsInfo . getInfo +getAddresses = mapMaybe getIPAddr . S.toList . fromDnsInfo . fromInfo hostAddresses :: HostName -> [Host] -> [IPAddr] hostAddresses hn hosts = maybe [] (getAddresses . hostInfo) (findHost hosts hn) diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs index 77c7133f..0bc0c100 100644 --- a/src/Propellor/PrivData.hs +++ b/src/Propellor/PrivData.hs @@ -161,7 +161,7 @@ filterPrivData :: Host -> PrivMap -> PrivMap filterPrivData host = M.filterWithKey (\k _v -> S.member k used) where used = S.map (\(f, _, c) -> (f, mkHostContext c (hostName host))) $ - fromPrivInfo $ getInfo $ hostInfo host + fromPrivInfo $ fromInfo $ hostInfo host getPrivData :: PrivDataField -> Context -> PrivMap -> Maybe PrivData getPrivData field context m = do @@ -245,7 +245,7 @@ mkUsedByMap = M.unionsWith (++) . map (\h -> mkPrivDataMap h $ const [hostName h mkPrivDataMap :: Host -> (Maybe PrivDataSourceDesc -> a) -> M.Map (PrivDataField, Context) a mkPrivDataMap host mkv = M.fromList $ map (\(f, d, c) -> ((f, mkHostContext c (hostName host)), mkv d)) - (S.toList $ fromPrivInfo $ getInfo $ hostInfo host) + (S.toList $ fromPrivInfo $ fromInfo $ hostInfo host) setPrivDataTo :: PrivDataField -> Context -> PrivData -> IO () setPrivDataTo field context (PrivData value) = do diff --git a/src/Propellor/PropAccum.hs b/src/Propellor/PropAccum.hs index 8281b9a1..af362ca7 100644 --- a/src/Propellor/PropAccum.hs +++ b/src/Propellor/PropAccum.hs @@ -12,7 +12,6 @@ module Propellor.PropAccum , (&) , (&^) , (!) - --, propagateContainer ) where import Propellor.Types @@ -82,35 +81,3 @@ Props c &^ p = Props (toChildProperty p : c) -> RevertableProperty (MetaTypes y) (MetaTypes z) -> Props (MetaTypes (Combine x z)) Props c ! p = Props (c ++ [toChildProperty (revert p)]) - -{- - --- | Adjust the provided Property, adding to its --- propertyChidren the properties of the provided container. --- --- The Info of the propertyChildren is adjusted to only include --- info that should be propagated out to the Property. --- --- Any PrivInfo that uses HostContext is adjusted to use the name --- of the container as its context. -propagateContainer - :: (PropAccum container) - => String - -> container - -> Property metatypes - -> Property metatypes -propagateContainer containername c prop = Property - undefined - (propertyDesc prop) - (getSatisfy prop) - (propertyInfo prop) - (propertyChildren prop ++ hostprops) - where - hostprops = map go $ getProperties c - go p = - let i = mapInfo (forceHostContext containername) - (propagatableInfo (propertyInfo p)) - cs = map go (propertyChildren p) - in infoProperty (propertyDesc p) (getSatisfy p) i cs - --} diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs index 4480f98d..547e5c94 100644 --- a/src/Propellor/Property/Chroot.hs +++ b/src/Propellor/Property/Chroot.hs @@ -41,23 +41,18 @@ data Chroot where Chroot :: ChrootBootstrapper b => FilePath -> b -> Host -> Chroot chrootSystem :: Chroot -> Maybe System -chrootSystem (Chroot _ _ h) = fromInfoVal (getInfo (hostInfo h)) +chrootSystem (Chroot _ _ h) = fromInfoVal (fromInfo (hostInfo h)) instance Show Chroot where show c@(Chroot loc _ _) = "Chroot " ++ loc ++ " " ++ show (chrootSystem c) -instance PropAccum Chroot where - (Chroot l c h) `addProp` p = Chroot l c (h & p) - (Chroot l c h) `addPropFront` p = Chroot l c (h `addPropFront` p) - getProperties (Chroot _ _ h) = hostProperties h - -- | Class of things that can do initial bootstrapping of an operating -- System in a chroot. class ChrootBootstrapper b where -- | Do initial bootstrapping of an operating system in a chroot. -- If the operating System is not supported, return -- Left error message. - buildchroot :: b -> Maybe System -> FilePath -> Either String (Property HasInfo) + buildchroot :: b -> Maybe System -> FilePath -> Either String (Property (HasInfo + UnixLike)) -- | Use this to bootstrap a chroot by extracting a tarball. -- @@ -70,12 +65,11 @@ data ChrootTarball = ChrootTarball FilePath instance ChrootBootstrapper ChrootTarball where buildchroot (ChrootTarball tb) _ loc = Right $ extractTarball loc tb -extractTarball :: FilePath -> FilePath -> Property HasInfo -extractTarball target src = toProp . - check (unpopulated target) $ - cmdProperty "tar" params - `assume` MadeChange - `requires` File.dirExists target +extractTarball :: FilePath -> FilePath -> Property UnixLike +extractTarball target src = check (unpopulated target) $ + cmdProperty "tar" params + `assume` MadeChange + `requires` File.dirExists target where params = [ "-C" @@ -92,14 +86,15 @@ instance ChrootBootstrapper Debootstrapped where (Just s@(System (Debian _) _)) -> Right $ debootstrap s (Just s@(System (Buntish _) _)) -> Right $ debootstrap s (Just (System (FreeBSD _) _)) -> Left "FreeBSD not supported by debootstrap." - Nothing -> Left "Cannot debootstrap; `os` property not specified" + Nothing -> Left "Cannot debootstrap; OS not specified" where debootstrap s = Debootstrap.built loc s cf -- | Defines a Chroot at the given location, built with debootstrap. -- -- Properties can be added to configure the Chroot. At a minimum, --- add the `os` property to specify the operating system to bootstrap. +-- add a property such as `osDebian` to specify the operating system +-- to bootstrap. -- -- > debootstrapped Debootstrap.BuildD "/srv/chroot/ghc-dev" -- > & osDebian Unstable "amd64" @@ -131,25 +126,25 @@ provisioned' propigator c@(Chroot loc bootstrapper _) systemdonly = (propertyList (chrootDesc c "removed") [teardown]) where setup = propellChroot c (inChrootProcess (not systemdonly) c) systemdonly - `requires` toProp built + `requires` built built = case buildchroot bootstrapper (chrootSystem c) loc of Right p -> p Left e -> cantbuild e - cantbuild e = infoProperty (chrootDesc c "built") (error e) mempty [] + cantbuild e = property (chrootDesc c "built") (error e) teardown = check (not <$> unpopulated loc) $ property ("removed " ++ loc) $ makeChange (removeChroot loc) -propagateChrootInfo :: (IsProp (Property i)) => Chroot -> Property i -> Property HasInfo +propagateChrootInfo :: (IsProp (Property i)) => Chroot -> Property i -> Property (HasInfo + UnixLike) propagateChrootInfo c@(Chroot location _ _) p = propagateContainer location c p' where p' = infoProperty - (propertyDesc p) + (getDesc p) (getSatisfy p) - (propertyInfo p <> chrootInfo c) + (getInfo p <> chrootInfo c) (propertyChildren p) chrootInfo :: Chroot -> Info @@ -157,7 +152,7 @@ chrootInfo (Chroot loc _ h) = mempty `addInfo` mempty { _chroots = M.singleton loc h } -- | Propellor is run inside the chroot to provision it. -propellChroot :: Chroot -> ([String] -> IO (CreateProcess, IO ())) -> Bool -> Property NoInfo +propellChroot :: Chroot -> ([String] -> IO (CreateProcess, IO ())) -> Bool -> Property UnixLike propellChroot c@(Chroot loc _ _) mkproc systemdonly = property (chrootDesc c "provisioned") $ do let d = localdir shimdir c let me = localdir "propellor" @@ -205,7 +200,7 @@ chain :: [Host] -> CmdLine -> IO () chain hostlist (ChrootChain hn loc systemdonly onconsole) = case findHostNoAlias hostlist hn of Nothing -> errorMessage ("cannot find host " ++ hn) - Just parenthost -> case M.lookup loc (_chroots $ getInfo $ hostInfo parenthost) of + Just parenthost -> case M.lookup loc (_chroots $ fromInfo $ hostInfo parenthost) of Nothing -> errorMessage ("cannot find chroot " ++ loc ++ " on host " ++ hn) Just h -> go h where @@ -215,7 +210,7 @@ chain hostlist (ChrootChain hn loc systemdonly onconsole) = onlyProcess (provisioningLock loc) $ do r <- runPropellor (setInChroot h) $ ensureChildProperties $ if systemdonly - then [toProp Systemd.installed] + then [toChildProperty Systemd.installed] else hostProperties h flushConcurrentOutput putStrLn $ "\n" ++ show r @@ -257,7 +252,7 @@ chrootDesc (Chroot loc _ _) desc = "chroot " ++ loc ++ " " ++ desc -- This is accomplished by installing a script -- that does not let any daemons be started by packages that use -- invoke-rc.d. Reverting the property removes the script. -noServices :: RevertableProperty NoInfo +noServices :: RevertableProperty DebianLike DebianLike noServices = setup teardown where f = "/usr/sbin/policy-rc.d" diff --git a/src/Propellor/Property/Concurrent.hs b/src/Propellor/Property/Concurrent.hs index a86c839f..ace85a3c 100644 --- a/src/Propellor/Property/Concurrent.hs +++ b/src/Propellor/Property/Concurrent.hs @@ -78,7 +78,7 @@ concurrently p1 p2 = (combineWith go go p1 p2) -- The above example will run foo and bar concurrently, and once either of -- those 2 properties finishes, will start running baz. concurrentList :: SingI metatypes => IO Int -> Desc -> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes) -concurrentList getn d (Props ps) = property d go `modifyChildren` (++ ps) +concurrentList getn d (Props ps) = property d go `addChildren` ps where go = do n <- liftIO getn diff --git a/src/Propellor/Property/Conductor.hs b/src/Propellor/Property/Conductor.hs index ec15281b..8fe607bc 100644 --- a/src/Propellor/Property/Conductor.hs +++ b/src/Propellor/Property/Conductor.hs @@ -126,7 +126,7 @@ mkOrchestra = fromJust . go S.empty where go seen h | S.member (hostName h) seen = Nothing -- break loop - | otherwise = Just $ case getInfo (hostInfo h) of + | otherwise = Just $ case fromInfo (hostInfo h) of ConductorFor [] -> Conducted h ConductorFor l -> let seen' = S.insert (hostName h) seen @@ -214,7 +214,7 @@ orchestrate :: [Host] -> [Host] orchestrate hs = map go hs where go h - | isOrchestrated (getInfo (hostInfo h)) = h + | isOrchestrated (fromInfo (hostInfo h)) = h | otherwise = foldl orchestrate' (removeold h) (map (deloop h) os) os = extractOrchestras hs @@ -222,7 +222,7 @@ orchestrate hs = map go hs removeold' h oldconductor = addPropHost h $ undoRevertableProperty $ conductedBy oldconductor - oldconductors = zip hs (map (getInfo . hostInfo) hs) + oldconductors = zip hs (map (fromInfo . hostInfo) hs) oldconductorsof h = flip mapMaybe oldconductors $ \(oldconductor, NotConductorFor l) -> if any (sameHost h) l @@ -299,7 +299,7 @@ addConductorPrivData h hs = h { hostInfo = hostInfo h <> i } i = mempty `addInfo` mconcat (map privinfo hs) `addInfo` Orchestrated (Any True) - privinfo h' = forceHostContext (hostName h') $ getInfo (hostInfo h') + privinfo h' = forceHostContext (hostName h') $ fromInfo (hostInfo h') -- Use this property to let the specified conductor ssh in and run propellor. conductedBy :: Host -> RevertableProperty DebianLike UnixLike diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs index a660a016..2b5596bd 100644 --- a/src/Propellor/Property/Dns.hs +++ b/src/Propellor/Property/Dns.hs @@ -213,7 +213,7 @@ otherServers :: DnsServerType -> [Host] -> Domain -> [HostName] otherServers wantedtype hosts domain = M.keys $ M.filter wanted $ hostMap hosts where - wanted h = case M.lookup domain (fromNamedConfMap $ getInfo $ hostInfo h) of + wanted h = case M.lookup domain (fromNamedConfMap $ fromInfo $ hostInfo h) of Nothing -> False Just conf -> confDnsServerType conf == wantedtype && confDomain conf == domain @@ -468,7 +468,7 @@ genZone inzdomain hostmap zdomain soa = -- So we can just use the IPAddrs. addcnames :: Host -> [Either WarningMessage (BindDomain, Record)] addcnames h = concatMap gen $ filter (inDomain zdomain) $ - mapMaybe getCNAME $ S.toList $ fromDnsInfo $ getInfo info + mapMaybe getCNAME $ S.toList $ fromDnsInfo $ fromInfo info where info = hostInfo h gen c = case getAddresses info of @@ -483,7 +483,7 @@ genZone inzdomain hostmap zdomain soa = where info = hostInfo h l = zip (repeat $ AbsDomain $ hostName h) - (S.toList $ S.filter (\r -> isNothing (getIPAddr r) && isNothing (getCNAME r)) (fromDnsInfo $ getInfo info)) + (S.toList $ S.filter (\r -> isNothing (getIPAddr r) && isNothing (getCNAME r)) (fromDnsInfo $ fromInfo info)) -- Simplifies the list of hosts. Remove duplicate entries. -- Also, filter out any CHAMES where the same domain has an @@ -518,7 +518,7 @@ addNamedConf conf = NamedConfMap (M.singleton domain conf) domain = confDomain conf getNamedConf :: Propellor (M.Map Domain NamedConf) -getNamedConf = asks $ fromNamedConfMap . getInfo . hostInfo +getNamedConf = asks $ fromNamedConfMap . fromInfo . hostInfo -- | Generates SSHFP records for hosts in the domain (or with CNAMES -- in the domain) that have configured ssh public keys. @@ -531,7 +531,7 @@ genSSHFP domain h = concatMap mk . concat <$> (gen =<< get) gen = liftIO . mapM genSSHFP' . M.elems . fromMaybe M.empty mk r = mapMaybe (\d -> if inDomain domain d then Just (d, r) else Nothing) (AbsDomain hostname : cnames) - cnames = mapMaybe getCNAME $ S.toList $ fromDnsInfo $ getInfo info + cnames = mapMaybe getCNAME $ S.toList $ fromDnsInfo $ fromInfo info hostname = hostName h info = hostInfo h diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs index d19d15aa..fe1e3b18 100644 --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -172,9 +172,9 @@ propagateContainerInfo :: (IsProp (Property i)) => Container -> Property i -> Pr propagateContainerInfo ctr@(Container _ h) p = propagateContainer cn ctr p' where p' = infoProperty - (propertyDesc p) + (getDesc p) (getSatisfy p) - (propertyInfo p <> dockerinfo) + (getInfo p <> dockerinfo) (propertyChildren p) dockerinfo = dockerInfo $ mempty { _dockerContainers = M.singleton cn h } @@ -186,7 +186,7 @@ mkContainerInfo cid@(ContainerId hn _cn) (Container img h) = where runparams = map (\(DockerRunParam mkparam) -> mkparam hn) (_dockerRunParams info) - info = getInfo $ hostInfo h' + info = fromInfo $ hostInfo h' h' = h -- Restart by default so container comes up on -- boot or when docker is upgraded. @@ -435,7 +435,7 @@ myContainerSuffix = ".propellor" containerDesc :: (IsProp (Property i)) => ContainerId -> Property i -> Property i containerDesc cid p = p `describe` desc where - desc = "container " ++ fromContainerId cid ++ " " ++ propertyDesc p + desc = "container " ++ fromContainerId cid ++ " " ++ getDesc p runningContainer :: ContainerId -> Image -> [RunParam] -> Property Linux runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ property "running" $ do @@ -574,7 +574,7 @@ chain hostlist hn s = case toContainerId s of Nothing -> errorMessage "bad container id" Just cid -> case findHostNoAlias hostlist hn of Nothing -> errorMessage ("cannot find host " ++ hn) - Just parenthost -> case M.lookup (containerName cid) (_dockerContainers $ getInfo $ hostInfo parenthost) of + Just parenthost -> case M.lookup (containerName cid) (_dockerContainers $ fromInfo $ hostInfo parenthost) of Nothing -> errorMessage ("cannot find container " ++ containerName cid ++ " docked on host " ++ hn) Just h -> go cid h where diff --git a/src/Propellor/Property/List.hs b/src/Propellor/Property/List.hs index 304d0863..a8b8347a 100644 --- a/src/Propellor/Property/List.hs +++ b/src/Propellor/Property/List.hs @@ -35,7 +35,7 @@ toProps ps = Props (map toChildProperty ps) propertyList :: SingI metatypes => Desc -> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes) propertyList desc (Props ps) = property desc (ensureChildProperties cs) - `modifyChildren` (++ cs) + `addChildren` cs where cs = map toChildProperty ps @@ -44,7 +44,7 @@ propertyList desc (Props ps) = combineProperties :: SingI metatypes => Desc -> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes) combineProperties desc (Props ps) = property desc (combineSatisfy cs NoChange) - `modifyChildren` (++ cs) + `addChildren` cs where cs = map toChildProperty ps diff --git a/src/Propellor/Property/Partition.hs b/src/Propellor/Property/Partition.hs index 5aff4ba4..291d4168 100644 --- a/src/Propellor/Property/Partition.hs +++ b/src/Propellor/Property/Partition.hs @@ -68,7 +68,7 @@ kpartx :: FilePath -> ([LoopDev] -> Property DebianLike) -> Property DebianLike kpartx diskimage mkprop = go `requires` Apt.installed ["kpartx"] where go :: Property DebianLike - go = property' (propertyDesc (mkprop [])) $ \w -> do + go = property' (getDesc (mkprop [])) $ \w -> do cleanup -- idempotency loopdevs <- liftIO $ kpartxParse <$> readProcess "kpartx" ["-avs", diskimage] diff --git a/src/Propellor/Property/Postfix.hs b/src/Propellor/Property/Postfix.hs index 7d9e7068..45aa4e42 100644 --- a/src/Propellor/Property/Postfix.hs +++ b/src/Propellor/Property/Postfix.hs @@ -304,7 +304,7 @@ saslAuthdInstalled = setupdaemon -- | Uses `saslpasswd2` to set the password for a user in the sasldb2 file. -- -- The password is taken from the privdata. -saslPasswdSet :: Domain -> User -> Property HasInfo +saslPasswdSet :: Domain -> User -> Property (HasInfo + UnixLike) saslPasswdSet domain (User user) = go `changesFileContent` "/etc/sasldb2" where go = withPrivData src ctx $ \getpw -> diff --git a/src/Propellor/Property/Scheduled.hs b/src/Propellor/Property/Scheduled.hs index 534e1e88..95e4e362 100644 --- a/src/Propellor/Property/Scheduled.hs +++ b/src/Propellor/Property/Scheduled.hs @@ -22,18 +22,18 @@ import qualified Data.Map as M -- last run. period :: (IsProp (Property i)) => Property i -> Recurrance -> Property i period prop recurrance = flip describe desc $ adjustPropertySatisfy prop $ \satisfy -> do - lasttime <- liftIO $ getLastChecked (propertyDesc prop) + lasttime <- liftIO $ getLastChecked (getDesc prop) nexttime <- liftIO $ fmap startTime <$> nextTime schedule lasttime t <- liftIO localNow if Just t >= nexttime then do r <- satisfy - liftIO $ setLastChecked t (propertyDesc prop) + liftIO $ setLastChecked t (getDesc prop) return r else noChange where schedule = Schedule recurrance AnyTime - desc = propertyDesc prop ++ " (period " ++ fromRecurrance recurrance ++ ")" + desc = getDesc prop ++ " (period " ++ fromRecurrance recurrance ++ ")" -- | Like period, but parse a human-friendly string. periodParse :: (IsProp (Property i)) => Property i -> String -> Property i diff --git a/src/Propellor/Property/Systemd.hs b/src/Propellor/Property/Systemd.hs index 2234ad5c..d909e4df 100644 --- a/src/Propellor/Property/Systemd.hs +++ b/src/Propellor/Property/Systemd.hs @@ -214,13 +214,13 @@ container name system mkchroot = Container name c h -- -- Reverting this property stops the container, removes the systemd unit, -- and deletes the chroot and all its contents. -nspawned :: Container -> RevertableProperty HasInfo +nspawned :: Container -> RevertableProperty (HasInfo + UnixLike) UnixLike nspawned c@(Container name (Chroot.Chroot loc builder _) h) = p `describe` ("nspawned " ++ name) where p = enterScript c `before` chrootprovisioned - `before` nspawnService c (_chrootCfg $ getInfo $ hostInfo h) + `before` nspawnService c (_chrootCfg $ fromInfo $ hostInfo h) `before` containerprovisioned -- Chroot provisioning is run in systemd-only mode, @@ -336,7 +336,7 @@ mungename = replace "/" "_" -- When there is no leading dash, "--" is prepended to the parameter. -- -- Reverting the property will remove a parameter, if it's present. -containerCfg :: String -> RevertableProperty HasInfo +containerCfg :: String -> RevertableProperty (HasInfo + UnixLike) UnixLike containerCfg p = RevertableProperty (mk True) (mk False) where mk b = pureInfoProperty ("container configuration " ++ (if b then "" else "without ") ++ p') $ @@ -348,18 +348,18 @@ containerCfg p = RevertableProperty (mk True) (mk False) -- | Bind mounts from the host into the container. -- -- This property is enabled by default. Revert it to disable it. -resolvConfed :: RevertableProperty HasInfo +resolvConfed :: RevertableProperty (HasInfo + UnixLike) UnixLike resolvConfed = containerCfg "bind=/etc/resolv.conf" -- | Link the container's journal to the host's if possible. -- (Only works if the host has persistent journal enabled.) -- -- This property is enabled by default. Revert it to disable it. -linkJournal :: RevertableProperty HasInfo +linkJournal :: RevertableProperty (HasInfo + UnixLike) UnixLike linkJournal = containerCfg "link-journal=try-guest" -- | Disconnect networking of the container from the host. -privateNetwork :: RevertableProperty HasInfo +privateNetwork :: RevertableProperty (HasInfo + UnixLike) UnixLike privateNetwork = containerCfg "private-network" class Publishable a where @@ -397,7 +397,7 @@ instance Publishable (Proto, Bound Port) where -- > & Systemd.running Systemd.networkd -- > & Systemd.publish (Port 80 ->- Port 8080) -- > & Apt.installedRunning "apache2" -publish :: Publishable p => p -> RevertableProperty HasInfo +publish :: Publishable p => p -> RevertableProperty (HasInfo + UnixLike) UnixLike publish p = containerCfg $ "--port=" ++ toPublish p class Bindable a where @@ -410,9 +410,9 @@ instance Bindable (Bound FilePath) where toBind v = hostSide v ++ ":" ++ containerSide v -- | Bind mount a file or directory from the host into the container. -bind :: Bindable p => p -> RevertableProperty HasInfo +bind :: Bindable p => p -> RevertableProperty (HasInfo + UnixLike) UnixLike bind p = containerCfg $ "--bind=" ++ toBind p -- | Read-only mind mount. -bindRo :: Bindable p => p -> RevertableProperty HasInfo +bindRo :: Bindable p => p -> RevertableProperty (HasInfo + UnixLike) UnixLike bindRo p = containerCfg $ "--bind-ro=" ++ toBind p diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs index 5f103b8a..944696dd 100644 --- a/src/Propellor/Spin.hs +++ b/src/Propellor/Spin.hs @@ -90,7 +90,7 @@ spin' mprivdata relay target hst = do error "remote propellor failed" where hn = fromMaybe target relay - sys = case getInfo (hostInfo hst) of + sys = case fromInfo (hostInfo hst) of InfoVal o -> Just o NoInfoVal -> Nothing @@ -170,7 +170,7 @@ getSshTarget target hst return ip configips = map fromIPAddr $ mapMaybe getIPAddr $ - S.toList $ fromDnsInfo $ getInfo $ hostInfo hst + S.toList $ fromDnsInfo $ fromInfo $ hostInfo hst -- Update the privdata, repo url, and git repo over the ssh -- connection, talking to the user's local propellor instance which is diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs index ccbfd3e0..2bddfc1a 100644 --- a/src/Propellor/Types.hs +++ b/src/Propellor/Types.hs @@ -26,11 +26,7 @@ module Propellor.Types , type (+) , addInfoProperty , addInfoProperty' - , addChildrenProperty , adjustPropertySatisfy - , propertyInfo - , propertyDesc - , propertyChildren , RevertableProperty(..) , () , ChildProperty @@ -124,12 +120,15 @@ type Desc = String -- internally, so you needn't worry about them. data Property metatypes = Property metatypes Desc (Propellor Result) Info [ChildProperty] +instance Show (Property metatypes) where + show p = "property " ++ show (getDesc p) + -- | Since there are many different types of Properties, they cannot be put -- into a list. The simplified ChildProperty can be put into a list. data ChildProperty = ChildProperty Desc (Propellor Result) Info [ChildProperty] instance Show ChildProperty where - show (ChildProperty desc _ _ _) = desc + show = getDesc -- | Constructs a Property, from a description and an action to run to -- ensure the Property is met. @@ -170,28 +169,10 @@ addInfoProperty' addInfoProperty' (Property t d a oldi c) newi = Property t d a (oldi <> newi) c --- | Adds children to a Property. -addChildrenProperty :: Property metatypes -> [ChildProperty] -> Property metatypes -addChildrenProperty (Property t s a i cs) cs' = Property t s a i (cs ++ cs') - -- | Changes the action that is performed to satisfy a property. adjustPropertySatisfy :: Property metatypes -> (Propellor Result -> Propellor Result) -> Property metatypes adjustPropertySatisfy (Property t d s i c) f = Property t d (f s) i c -propertyInfo :: Property metatypes -> Info -propertyInfo (Property _ _ _ i _) = i - -propertyDesc :: Property metatypes -> Desc -propertyDesc (Property _ d _ _ _) = d - -instance Show (Property metatypes) where - show p = "property " ++ show (propertyDesc p) - --- | A Property can include a list of child properties that it also --- satisfies. This allows them to be introspected to collect their info, etc. -propertyChildren :: Property metatypes -> [ChildProperty] -propertyChildren (Property _ _ _ _ c) = c - -- | A property that can be reverted. The first Property is run -- normally and the second is run when it's reverted. data RevertableProperty setupmetatypes undometatypes = RevertableProperty @@ -209,14 +190,16 @@ instance Show (RevertableProperty setupmetatypes undometatypes) where -> RevertableProperty setupmetatypes undometatypes setup undo = RevertableProperty setup undo --- | Class of types that can be used as properties of a host. class IsProp p where setDesc :: p -> Desc -> p getDesc :: p -> Desc - modifyChildren :: p -> ([ChildProperty] -> [ChildProperty]) -> p + getChildren :: p -> [ChildProperty] + addChildren :: p -> [ChildProperty] -> p -- | Gets the info of the property, combined with all info -- of all children properties. getInfoRecursive :: p -> Info + -- | Info, not including info from children. + getInfo :: p -> Info -- | Gets a ChildProperty representing the Property. -- You should not normally need to use this. toChildProperty :: p -> ChildProperty @@ -227,19 +210,23 @@ class IsProp p where instance IsProp (Property metatypes) where setDesc (Property t _ a i c) d = Property t d a i c - getDesc = propertyDesc - modifyChildren (Property t d a i c) f = Property t d a i (f c) + getDesc (Property _ d _ _ _) = d + getChildren (Property _ _ _ _ c) = c + addChildren (Property t d a i c) c' = Property t d a i (c ++ c') getInfoRecursive (Property _ _ _ i c) = i <> mconcat (map getInfoRecursive c) + getInfo (Property _ _ _ i _) = i toChildProperty (Property _ d a i c) = ChildProperty d a i c getSatisfy (Property _ _ a _ _) = a instance IsProp ChildProperty where setDesc (ChildProperty _ a i c) d = ChildProperty d a i c getDesc (ChildProperty d _ _ _) = d - modifyChildren (ChildProperty d a i c) f = ChildProperty d a i (f c) + getChildren (ChildProperty _ _ _ c) = c + addChildren (ChildProperty d a i c) c' = ChildProperty d a i (c ++ c') getInfoRecursive (ChildProperty _ _ i c) = i <> mconcat (map getInfoRecursive c) + getInfo (ChildProperty _ _ i _) = i toChildProperty = id getSatisfy (ChildProperty _ a _ _) = a @@ -248,9 +235,12 @@ instance IsProp (RevertableProperty setupmetatypes undometatypes) where setDesc (RevertableProperty p1 p2) d = RevertableProperty (setDesc p1 d) (setDesc p2 ("not " ++ d)) getDesc (RevertableProperty p1 _) = getDesc p1 - modifyChildren (RevertableProperty p1 p2) f = RevertableProperty (modifyChildren p1 f) (modifyChildren p2 f) + getChildren (RevertableProperty p1 _) = getChildren p1 + -- | Only add children to the active side. + addChildren (RevertableProperty p1 p2) c = RevertableProperty (addChildren p1 c) p2 -- | Return the Info of the currently active side. getInfoRecursive (RevertableProperty p1 _p2) = getInfoRecursive p1 + getInfo (RevertableProperty p1 _p2) = getInfo p1 toChildProperty (RevertableProperty p1 _p2) = toChildProperty p1 getSatisfy (RevertableProperty p1 _) = getSatisfy p1 diff --git a/src/Propellor/Types/Info.hs b/src/Propellor/Types/Info.hs index bc1543e2..c7f6b82f 100644 --- a/src/Propellor/Types/Info.hs +++ b/src/Propellor/Types/Info.hs @@ -5,7 +5,7 @@ module Propellor.Types.Info ( IsInfo(..), addInfo, toInfo, - getInfo, + fromInfo, mapInfo, propagatableInfo, InfoVal(..), @@ -51,8 +51,8 @@ toInfo :: IsInfo v => v -> Info toInfo = addInfo mempty -- The list is reversed here because addInfo builds it up in reverse order. -getInfo :: IsInfo v => Info -> v -getInfo (Info l) = mconcat (mapMaybe extractInfoEntry (reverse l)) +fromInfo :: IsInfo v => Info -> v +fromInfo (Info l) = mconcat (mapMaybe extractInfoEntry (reverse l)) -- | Maps a function over all values stored in the Info that are of the -- appropriate type. -- cgit v1.3-2-g0d8e From 500635568514bc106597a857c60d268dcf668037 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 27 Mar 2016 18:32:01 -0400 Subject: split out singletons lib --- debian/changelog | 4 ++-- propellor.cabal | 1 + src/Propellor/Types/MetaTypes.hs | 14 +------------- src/Propellor/Types/Singletons.hs | 17 +++++++++++++++++ 4 files changed, 21 insertions(+), 15 deletions(-) create mode 100644 src/Propellor/Types/Singletons.hs (limited to 'propellor.cabal') diff --git a/debian/changelog b/debian/changelog index fc499c86..af2f5c2b 100644 --- a/debian/changelog +++ b/debian/changelog @@ -39,10 +39,10 @@ propellor (3.0.0) UNRELEASED; urgency=medium go = property "foo" (return NoChange) To fix, specify the type of go: go :: Property UnixLike - - `ensureProperty` now needs to be passed information about the + - `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 $ \o -> ... ensureProperty o 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. diff --git a/propellor.cabal b/propellor.cabal index 4a7739d3..f11d2afe 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -162,6 +162,7 @@ Library Propellor.Types.PrivData Propellor.Types.Result Propellor.Types.ResultCheck + Propellor.Types.Singletons Propellor.Types.ZFS Other-Modules: Propellor.Bootstrap diff --git a/src/Propellor/Types/MetaTypes.hs b/src/Propellor/Types/MetaTypes.hs index 3e89e28d..39d6e725 100644 --- a/src/Propellor/Types/MetaTypes.hs +++ b/src/Propellor/Types/MetaTypes.hs @@ -25,6 +25,7 @@ module Propellor.Types.MetaTypes ( EqT, ) where +import Propellor.Types.Singletons import Propellor.Types.OS data MetaType @@ -49,13 +50,6 @@ type instance IncludesInfo (MetaTypes l) = Elem 'WithInfo l type MetaTypes = Sing --- | The data family of singleton types. -data family Sing (x :: k) - --- | A class used to pass singleton values implicitly. -class SingI t where - sing :: Sing t - -- This boilerplatw would not be needed if the singletons library were -- used. However, we're targeting too old a version of ghc to use it yet. data instance Sing (x :: MetaType) where @@ -68,12 +62,6 @@ instance SingI ('Targeting 'OSBuntish) where sing = OSBuntishS instance SingI ('Targeting 'OSFreeBSD) where sing = OSFreeBSDS instance SingI 'WithInfo where sing = WithInfoS -data instance Sing (x :: [k]) where - Nil :: Sing '[] - Cons :: Sing x -> Sing xs -> Sing (x ': xs) -instance (SingI x, SingI xs) => SingI (x ': xs) where sing = Cons sing sing -instance SingI '[] where sing = Nil - -- | Convenience type operator to combine two `MetaTypes` lists. -- -- For example: diff --git a/src/Propellor/Types/Singletons.hs b/src/Propellor/Types/Singletons.hs new file mode 100644 index 00000000..be777ecb --- /dev/null +++ b/src/Propellor/Types/Singletons.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE DataKinds, PolyKinds, TypeOperators, TypeFamilies, GADTs #-} + +module Propellor.Types.Singletons where + +-- | The data family of singleton types. +data family Sing (x :: k) + +-- | A class used to pass singleton values implicitly. +class SingI t where + sing :: Sing t + +-- Lists of singletons +data instance Sing (x :: [k]) where + Nil :: Sing '[] + Cons :: Sing x -> Sing xs -> Sing (x ': xs) +instance (SingI x, SingI xs) => SingI (x ': xs) where sing = Cons sing sing +instance SingI '[] where sing = Nil -- cgit v1.3-2-g0d8e From 9d6dc29555b8499d8ae6c73c891b0b5dc19f83e5 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 27 Mar 2016 19:59:20 -0400 Subject: improve haddocks and move code around to make them more clear --- propellor.cabal | 1 + src/Propellor/Container.hs | 4 +- src/Propellor/Engine.hs | 4 +- src/Propellor/EnsureProperty.hs | 1 + src/Propellor/Info.hs | 28 +++++- src/Propellor/PrivData.hs | 2 +- src/Propellor/PropAccum.hs | 5 +- src/Propellor/Property.hs | 1 + src/Propellor/Property/Chroot.hs | 3 +- src/Propellor/Property/Concurrent.hs | 2 + src/Propellor/Property/Conductor.hs | 13 +-- src/Propellor/Property/Dns.hs | 2 +- src/Propellor/Property/Docker.hs | 3 +- src/Propellor/Property/FreeBSD/Pkg.hs | 4 +- src/Propellor/Property/List.hs | 2 + src/Propellor/Property/Partition.hs | 1 + src/Propellor/Property/Scheduled.hs | 1 + src/Propellor/Types.hs | 168 ++++++---------------------------- src/Propellor/Types/Core.hs | 106 +++++++++++++++++++++ src/Propellor/Types/Info.hs | 5 + 20 files changed, 196 insertions(+), 160 deletions(-) create mode 100644 src/Propellor/Types/Core.hs (limited to 'propellor.cabal') diff --git a/propellor.cabal b/propellor.cabal index f11d2afe..e946f697 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -150,6 +150,7 @@ Library Propellor.EnsureProperty Propellor.Exception Propellor.Types + Propellor.Types.Core Propellor.Types.Chroot Propellor.Types.CmdLine Propellor.Types.Container diff --git a/src/Propellor/Container.hs b/src/Propellor/Container.hs index 4cd46ae5..c4d6f864 100644 --- a/src/Propellor/Container.hs +++ b/src/Propellor/Container.hs @@ -3,8 +3,10 @@ module Propellor.Container where import Propellor.Types +import Propellor.Types.Core import Propellor.Types.MetaTypes import Propellor.Types.Info +import Propellor.Info import Propellor.PrivData import Propellor.PropAccum @@ -54,7 +56,7 @@ propagateContainer containername c prop = prop convert p = let n = property (getDesc p) (getSatisfy p) :: Property UnixLike n' = n - `addInfoProperty` mapInfo (forceHostContext containername) + `setInfoProperty` mapInfo (forceHostContext containername) (propagatableInfo (getInfo p)) `addChildren` map convert (getChildren p) in toChildProperty n' diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs index 4c37e704..f0035c40 100644 --- a/src/Propellor/Engine.hs +++ b/src/Propellor/Engine.hs @@ -4,7 +4,6 @@ module Propellor.Engine ( mainProperties, runPropellor, - ensureProperty, ensureChildProperties, fromHost, fromHost', @@ -23,10 +22,11 @@ import Control.Applicative import Prelude import Propellor.Types +import Propellor.Types.MetaTypes +import Propellor.Types.Core import Propellor.Message import Propellor.Exception import Propellor.Info -import Propellor.Property import Utility.Exception -- | Gets the Properties of a Host, and ensures them all, diff --git a/src/Propellor/EnsureProperty.hs b/src/Propellor/EnsureProperty.hs index f9094c5b..ce01d436 100644 --- a/src/Propellor/EnsureProperty.hs +++ b/src/Propellor/EnsureProperty.hs @@ -11,6 +11,7 @@ module Propellor.EnsureProperty ) where import Propellor.Types +import Propellor.Types.Core import Propellor.Types.MetaTypes import Propellor.Exception diff --git a/src/Propellor/Info.hs b/src/Propellor/Info.hs index ff0b3b5e..b87369c3 100644 --- a/src/Propellor/Info.hs +++ b/src/Propellor/Info.hs @@ -1,9 +1,11 @@ -{-# LANGUAGE PackageImports #-} +{-# LANGUAGE PackageImports, TypeFamilies, DataKinds, PolyKinds #-} module Propellor.Info ( osDebian, osBuntish, osFreeBSD, + setInfoProperty, + addInfoProperty, pureInfoProperty, pureInfoProperty', askInfo, @@ -22,6 +24,7 @@ module Propellor.Info ( import Propellor.Types import Propellor.Types.Info +import Propellor.Types.MetaTypes import "mtl" Control.Monad.Reader import qualified Data.Set as S @@ -31,11 +34,32 @@ import Data.Monoid import Control.Applicative import Prelude +-- | Adds info to a Property. +-- +-- The new Property will include HasInfo in its metatypes. +setInfoProperty + :: (MetaTypes metatypes' ~ (+) HasInfo metatypes, SingI metatypes') + => Property metatypes + -> Info + -> Property (MetaTypes metatypes') +setInfoProperty (Property _ d a oldi c) newi = + Property sing d a (oldi <> newi) c + +-- | Adds more info to a Property that already HasInfo. +addInfoProperty + :: (IncludesInfo metatypes ~ 'True) + => Property metatypes + -> Info + -> Property metatypes +addInfoProperty (Property t d a oldi c) newi = + Property t d a (oldi <> newi) c + +-- | Makes a property that does nothing but set some `Info`. pureInfoProperty :: (IsInfo v) => Desc -> v -> Property (HasInfo + UnixLike) pureInfoProperty desc v = pureInfoProperty' desc (toInfo v) pureInfoProperty' :: Desc -> Info -> Property (HasInfo + UnixLike) -pureInfoProperty' desc i = addInfoProperty p i +pureInfoProperty' desc i = setInfoProperty p i where p :: Property UnixLike p = property ("has " ++ desc) (return NoChange) diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs index 0bc0c100..d3bb3a6d 100644 --- a/src/Propellor/PrivData.hs +++ b/src/Propellor/PrivData.hs @@ -127,7 +127,7 @@ withPrivData' feed srclist c mkprop = addinfo $ mkprop $ \a -> "Fix this by running:" : showSet (map (\s -> (privDataField s, Context cname, describePrivDataSource s)) srclist) return FailedChange - addinfo p = p `addInfoProperty'` (toInfo privset) + addinfo p = p `addInfoProperty` (toInfo privset) privset = PrivInfo $ S.fromList $ map (\s -> (privDataField s, describePrivDataSource s, hc)) srclist fieldnames = map show fieldlist diff --git a/src/Propellor/PropAccum.hs b/src/Propellor/PropAccum.hs index 856f2e8e..d9fa8ec7 100644 --- a/src/Propellor/PropAccum.hs +++ b/src/Propellor/PropAccum.hs @@ -16,6 +16,7 @@ module Propellor.PropAccum import Propellor.Types import Propellor.Types.MetaTypes +import Propellor.Types.Core import Propellor.Property import Data.Monoid @@ -30,10 +31,6 @@ import Prelude host :: HostName -> Props metatypes -> Host host hn (Props ps) = Host hn ps (mconcat (map getInfoRecursive ps)) --- | Props is a combination of a list of properties, with their combined --- metatypes. -data Props metatypes = Props [ChildProperty] - -- | Start accumulating a list of properties. -- -- Properties can be added to it using `(&)` etc. diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs index 70583edc..29a8ec0f 100644 --- a/src/Propellor/Property.hs +++ b/src/Propellor/Property.hs @@ -53,6 +53,7 @@ import Control.Applicative import Prelude import Propellor.Types +import Propellor.Types.Core import Propellor.Types.ResultCheck import Propellor.Types.MetaTypes import Propellor.Info diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs index 811b5baa..09047ce5 100644 --- a/src/Propellor/Property/Chroot.hs +++ b/src/Propellor/Property/Chroot.hs @@ -23,6 +23,7 @@ import Propellor.Container import Propellor.Types.CmdLine import Propellor.Types.Chroot import Propellor.Types.Info +import Propellor.Types.Core import Propellor.Property.Chroot.Util import qualified Propellor.Property.Debootstrap as Debootstrap import qualified Propellor.Property.Systemd.Core as Systemd @@ -151,7 +152,7 @@ provisioned' propigator c@(Chroot loc bootstrapper _) systemdonly = propagateChrootInfo :: Chroot -> Property Linux -> Property (HasInfo + Linux) propagateChrootInfo c@(Chroot location _ _) p = propagateContainer location c $ - p `addInfoProperty` chrootInfo c + p `setInfoProperty` chrootInfo c chrootInfo :: Chroot -> Info chrootInfo (Chroot loc _ h) = mempty `addInfo` diff --git a/src/Propellor/Property/Concurrent.hs b/src/Propellor/Property/Concurrent.hs index ace85a3c..e69dc17d 100644 --- a/src/Propellor/Property/Concurrent.hs +++ b/src/Propellor/Property/Concurrent.hs @@ -37,6 +37,8 @@ module Propellor.Property.Concurrent ( ) where import Propellor.Base +import Propellor.Types.Core +import Propellor.Types.MetaTypes import Control.Concurrent import qualified Control.Concurrent.Async as A diff --git a/src/Propellor/Property/Conductor.hs b/src/Propellor/Property/Conductor.hs index ab747acc..8aa18d20 100644 --- a/src/Propellor/Property/Conductor.hs +++ b/src/Propellor/Property/Conductor.hs @@ -83,16 +83,17 @@ import qualified Propellor.Property.Ssh as Ssh import qualified Data.Set as S -- | Class of things that can be conducted. +-- +-- There are instances for single hosts, and for lists of hosts. +-- With a list, each listed host will be conducted in turn. Failure to conduct +-- one host does not prevent conducting subsequent hosts in the list, but +-- will be propagated as an overall failure of the property. class Conductable c where conducts :: c -> RevertableProperty (HasInfo + UnixLike) (HasInfo + UnixLike) instance Conductable Host where - -- | Conduct the specified host. conducts h = conductorFor h notConductorFor h --- | Each host in the list will be conducted in turn. Failure to conduct --- one host does not prevent conducting subsequent hosts in the list, but --- will be propagated as an overall failure of the property. instance Conductable [Host] where conducts hs = propertyList desc (toProps $ map (setupRevertableProperty . conducts) hs) @@ -246,7 +247,7 @@ orchestrate' h (Conductor c l) -- to have any effect. conductorFor :: Host -> Property (HasInfo + UnixLike) conductorFor h = go - `addInfoProperty` (toInfo (ConductorFor [h])) + `setInfoProperty` (toInfo (ConductorFor [h])) `requires` setupRevertableProperty (conductorKnownHost h) `requires` Ssh.installed where @@ -270,7 +271,7 @@ conductorFor h = go -- Reverts conductorFor. notConductorFor :: Host -> Property (HasInfo + UnixLike) notConductorFor h = (doNothing :: Property UnixLike) - `addInfoProperty` (toInfo (NotConductorFor [h])) + `setInfoProperty` (toInfo (NotConductorFor [h])) `describe` desc `requires` undoRevertableProperty (conductorKnownHost h) where diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs index 2b5596bd..2e2710a6 100644 --- a/src/Propellor/Property/Dns.hs +++ b/src/Propellor/Property/Dns.hs @@ -81,7 +81,7 @@ setupPrimary zonefile mknamedconffile hosts domain soa rs = (partialzone, zonewarnings) = genZone indomain hostmap domain soa baseprop = primaryprop - `addInfoProperty` (toInfo (addNamedConf conf)) + `setInfoProperty` (toInfo (addNamedConf conf)) primaryprop :: Property DebianLike primaryprop = property ("dns primary for " ++ domain) $ do sshfps <- concat <$> mapM (genSSHFP domain) (M.elems hostmap) diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs index ddefef15..2ef97438 100644 --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -48,6 +48,7 @@ module Propellor.Property.Docker ( import Propellor.Base hiding (init) import Propellor.Types.Docker import Propellor.Types.Container +import Propellor.Types.Core import Propellor.Types.CmdLine import Propellor.Types.Info import Propellor.Container @@ -183,7 +184,7 @@ imagePulled ctr = pulled `describe` msg propagateContainerInfo :: Container -> Property (HasInfo + Linux) -> Property (HasInfo + Linux) propagateContainerInfo ctr@(Container _ h) p = propagateContainer cn ctr $ - p `addInfoProperty'` dockerinfo + p `addInfoProperty` dockerinfo where dockerinfo = dockerInfo $ mempty { _dockerContainers = M.singleton cn h } diff --git a/src/Propellor/Property/FreeBSD/Pkg.hs b/src/Propellor/Property/FreeBSD/Pkg.hs index 6c775b94..704c1db9 100644 --- a/src/Propellor/Property/FreeBSD/Pkg.hs +++ b/src/Propellor/Property/FreeBSD/Pkg.hs @@ -51,7 +51,7 @@ update = go = ifM (pkgUpdated <$> askInfo) ((noChange), (liftIO upd >> return MadeChange)) in (property "pkg update has run" go :: Property FreeBSD) - `addInfoProperty` (toInfo (PkgUpdate "")) + `setInfoProperty` (toInfo (PkgUpdate "")) newtype PkgUpgrade = PkgUpgrade String deriving (Typeable, Monoid, Show) @@ -68,7 +68,7 @@ upgrade = go = ifM (pkgUpgraded <$> askInfo) ((noChange), (liftIO upd >> return MadeChange)) in (property "pkg upgrade has run" go :: Property FreeBSD) - `addInfoProperty` (toInfo (PkgUpdate "")) + `setInfoProperty` (toInfo (PkgUpdate "")) `requires` update type Package = String diff --git a/src/Propellor/Property/List.hs b/src/Propellor/Property/List.hs index a8b8347a..0eec04c7 100644 --- a/src/Propellor/Property/List.hs +++ b/src/Propellor/Property/List.hs @@ -13,6 +13,8 @@ module Propellor.Property.List ( ) where import Propellor.Types +import Propellor.Types.Core +import Propellor.Types.MetaTypes import Propellor.PropAccum import Propellor.Engine import Propellor.Exception diff --git a/src/Propellor/Property/Partition.hs b/src/Propellor/Property/Partition.hs index 291d4168..2bf5b927 100644 --- a/src/Propellor/Property/Partition.hs +++ b/src/Propellor/Property/Partition.hs @@ -3,6 +3,7 @@ module Propellor.Property.Partition where import Propellor.Base +import Propellor.Types.Core import qualified Propellor.Property.Apt as Apt import Utility.Applicative diff --git a/src/Propellor/Property/Scheduled.hs b/src/Propellor/Property/Scheduled.hs index 95e4e362..729a3749 100644 --- a/src/Propellor/Property/Scheduled.hs +++ b/src/Propellor/Property/Scheduled.hs @@ -10,6 +10,7 @@ module Propellor.Property.Scheduled ) where import Propellor.Base +import Propellor.Types.Core import Utility.Scheduled import Data.Time.Clock diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs index d5959cbb..6d6b14ea 100644 --- a/src/Propellor/Types.hs +++ b/src/Propellor/Types.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE PackageImports #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} @@ -8,15 +7,18 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} -module Propellor.Types - ( Host(..) +module Propellor.Types ( + -- * Core data types + Host(..) , Property(..) , property - , Info , Desc - , MetaType(..) - , MetaTypes - , TargetOS(..) + , RevertableProperty(..) + , () + , Propellor(..) + , LiftPropellor(..) + , Info + -- * Types of properties , UnixLike , Linux , DebianLike @@ -25,34 +27,22 @@ module Propellor.Types , FreeBSD , HasInfo , type (+) - , addInfoProperty - , addInfoProperty' - , adjustPropertySatisfy - , RevertableProperty(..) - , () - , ChildProperty - , IsProp(..) + , TightenTargets(..) + -- * Combining and modifying properties , Combines(..) , CombinedType , ResultCombiner - , Propellor(..) - , LiftPropellor(..) - , EndAction(..) + , adjustPropertySatisfy + -- * Other included types , module Propellor.Types.OS , module Propellor.Types.Dns , module Propellor.Types.Result , module Propellor.Types.ZFS - , TightenTargets(..) - , SingI ) where import Data.Monoid -import "mtl" Control.Monad.RWS.Strict -import Control.Monad.Catch -import Data.Typeable -import Control.Applicative -import Prelude +import Propellor.Types.Core import Propellor.Types.Info import Propellor.Types.OS import Propellor.Types.Dns @@ -60,89 +50,38 @@ import Propellor.Types.Result import Propellor.Types.MetaTypes import Propellor.Types.ZFS --- | Everything Propellor knows about a system: Its hostname, --- properties and their collected info. -data Host = Host - { hostName :: HostName - , hostProperties :: [ChildProperty] - , hostInfo :: Info - } - deriving (Show, Typeable) - --- | Propellor's monad provides read-only access to info about the host --- it's running on, and a writer to accumulate EndActions. -newtype Propellor p = Propellor { runWithHost :: RWST Host [EndAction] () IO p } - deriving - ( Monad - , Functor - , Applicative - , MonadReader Host - , MonadWriter [EndAction] - , MonadIO - , MonadCatch - , MonadThrow - , MonadMask - ) - -class LiftPropellor m where - liftPropellor :: m a -> Propellor a - -instance LiftPropellor Propellor where - liftPropellor = id - -instance LiftPropellor IO where - liftPropellor = liftIO - -instance Monoid (Propellor Result) where - mempty = return NoChange - -- | The second action is only run if the first action does not fail. - mappend x y = do - rx <- x - case rx of - FailedChange -> return FailedChange - _ -> do - ry <- y - return (rx <> ry) - --- | An action that Propellor runs at the end, after trying to satisfy all --- properties. It's passed the combined Result of the entire Propellor run. -data EndAction = EndAction Desc (Result -> Propellor Result) - -type Desc = String - -- | The core data type of Propellor, this represents a property --- that the system should have, with a descrition, an action to ensure --- it has the property, and perhaps some Info that can be added to Hosts +-- that the system should have, with a descrition, and an action to ensure +-- it has the property. -- that have the property. -- --- A property has a list of `[MetaType]`, which is part of its type. +-- There are different types of properties that target different OS's, +-- and so have different metatypes. +-- For example: "Property DebianLike" and "Property FreeBSD". -- --- There are many instances and type families, which are mostly used +-- Also, some properties have associated `Info`, which is indicated in +-- their type: "Property (HasInfo + DebianLike)" +-- +-- There are many associated type families, which are mostly used -- internally, so you needn't worry about them. data Property metatypes = Property metatypes Desc (Propellor Result) Info [ChildProperty] instance Show (Property metatypes) where show p = "property " ++ show (getDesc p) --- | Since there are many different types of Properties, they cannot be put --- into a list. The simplified ChildProperty can be put into a list. -data ChildProperty = ChildProperty Desc (Propellor Result) Info [ChildProperty] - -instance Show ChildProperty where - show = getDesc - -- | Constructs a Property, from a description and an action to run to -- ensure the Property is met. -- --- You can specify any metatypes that make sense to indicate what OS --- the property targets, etc. +-- Due to the polymorphic return type of this function, most uses will need +-- to specify a type signature. This lets you specify what OS the property +-- targets, etc. -- -- For example: -- -- > foo :: Property Debian --- > foo = mkProperty "foo" (...) --- --- Note that using this needs LANGUAGE PolyKinds. +-- > foo = property "foo" $ do +-- > ... +-- > return MadeChange property :: SingI metatypes => Desc @@ -150,26 +89,6 @@ property -> Property (MetaTypes metatypes) property d a = Property sing d a mempty mempty --- | Adds info to a Property. --- --- The new Property will include HasInfo in its metatypes. -addInfoProperty - :: (MetaTypes metatypes' ~ (+) HasInfo metatypes, SingI metatypes') - => Property metatypes - -> Info - -> Property (MetaTypes metatypes') -addInfoProperty (Property _ d a oldi c) newi = - Property sing d a (oldi <> newi) c - --- | Adds more info to a Property that already HasInfo. -addInfoProperty' - :: (IncludesInfo metatypes ~ 'True) - => Property metatypes - -> Info - -> Property metatypes -addInfoProperty' (Property t d a oldi c) newi = - Property t d a (oldi <> newi) c - -- | Changes the action that is performed to satisfy a property. adjustPropertySatisfy :: Property metatypes -> (Propellor Result -> Propellor Result) -> Property metatypes adjustPropertySatisfy (Property t d s i c) f = Property t d (f s) i c @@ -191,24 +110,6 @@ instance Show (RevertableProperty setupmetatypes undometatypes) where -> RevertableProperty setupmetatypes undometatypes setup undo = RevertableProperty setup undo -class IsProp p where - setDesc :: p -> Desc -> p - getDesc :: p -> Desc - getChildren :: p -> [ChildProperty] - addChildren :: p -> [ChildProperty] -> p - -- | Gets the info of the property, combined with all info - -- of all children properties. - getInfoRecursive :: p -> Info - -- | Info, not including info from children. - getInfo :: p -> Info - -- | Gets a ChildProperty representing the Property. - -- You should not normally need to use this. - toChildProperty :: p -> ChildProperty - -- | Gets the action that can be run to satisfy a Property. - -- You should never run this action directly. Use - -- 'Propellor.EnsureProperty.ensureProperty` instead. - getSatisfy :: p -> Propellor Result - instance IsProp (Property metatypes) where setDesc (Property t _ a i c) d = Property t d a i c getDesc (Property _ d _ _ _) = d @@ -220,17 +121,6 @@ instance IsProp (Property metatypes) where toChildProperty (Property _ d a i c) = ChildProperty d a i c getSatisfy (Property _ _ a _ _) = a -instance IsProp ChildProperty where - setDesc (ChildProperty _ a i c) d = ChildProperty d a i c - getDesc (ChildProperty d _ _ _) = d - getChildren (ChildProperty _ _ _ c) = c - addChildren (ChildProperty d a i c) c' = ChildProperty d a i (c ++ c') - getInfoRecursive (ChildProperty _ _ i c) = - i <> mconcat (map getInfoRecursive c) - getInfo (ChildProperty _ _ i _) = i - toChildProperty = id - getSatisfy (ChildProperty _ a _ _) = a - instance IsProp (RevertableProperty setupmetatypes undometatypes) where -- | Sets the description of both sides. setDesc (RevertableProperty p1 p2) d = diff --git a/src/Propellor/Types/Core.hs b/src/Propellor/Types/Core.hs new file mode 100644 index 00000000..fa939d2b --- /dev/null +++ b/src/Propellor/Types/Core.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} + +module Propellor.Types.Core where + +import Propellor.Types.Info +import Propellor.Types.OS +import Propellor.Types.Result + +import Data.Monoid +import "mtl" Control.Monad.RWS.Strict +import Control.Monad.Catch +import Control.Applicative +import Prelude + +-- | Everything Propellor knows about a system: Its hostname, +-- properties and their collected info. +data Host = Host + { hostName :: HostName + , hostProperties :: [ChildProperty] + , hostInfo :: Info + } + deriving (Show, Typeable) + +-- | Propellor's monad provides read-only access to info about the host +-- it's running on, and a writer to accumulate EndActions. +newtype Propellor p = Propellor { runWithHost :: RWST Host [EndAction] () IO p } + deriving + ( Monad + , Functor + , Applicative + , MonadReader Host + , MonadWriter [EndAction] + , MonadIO + , MonadCatch + , MonadThrow + , MonadMask + ) + +class LiftPropellor m where + liftPropellor :: m a -> Propellor a + +instance LiftPropellor Propellor where + liftPropellor = id + +instance LiftPropellor IO where + liftPropellor = liftIO + +instance Monoid (Propellor Result) where + mempty = return NoChange + -- | The second action is only run if the first action does not fail. + mappend x y = do + rx <- x + case rx of + FailedChange -> return FailedChange + _ -> do + ry <- y + return (rx <> ry) + +-- | An action that Propellor runs at the end, after trying to satisfy all +-- properties. It's passed the combined Result of the entire Propellor run. +data EndAction = EndAction Desc (Result -> Propellor Result) + +type Desc = String + +-- | Props is a combination of a list of properties, with their combined +-- metatypes. +data Props metatypes = Props [ChildProperty] + +-- | Since there are many different types of Properties, they cannot be put +-- into a list. The simplified ChildProperty can be put into a list. +data ChildProperty = ChildProperty Desc (Propellor Result) Info [ChildProperty] + +instance Show ChildProperty where + show = getDesc + +class IsProp p where + setDesc :: p -> Desc -> p + getDesc :: p -> Desc + getChildren :: p -> [ChildProperty] + addChildren :: p -> [ChildProperty] -> p + -- | Gets the info of the property, combined with all info + -- of all children properties. + getInfoRecursive :: p -> Info + -- | Info, not including info from children. + getInfo :: p -> Info + -- | Gets a ChildProperty representing the Property. + -- You should not normally need to use this. + toChildProperty :: p -> ChildProperty + -- | Gets the action that can be run to satisfy a Property. + -- You should never run this action directly. Use + -- 'Propellor.EnsureProperty.ensureProperty` instead. + getSatisfy :: p -> Propellor Result + +instance IsProp ChildProperty where + setDesc (ChildProperty _ a i c) d = ChildProperty d a i c + getDesc (ChildProperty d _ _ _) = d + getChildren (ChildProperty _ _ _ c) = c + addChildren (ChildProperty d a i c) c' = ChildProperty d a i (c ++ c') + getInfoRecursive (ChildProperty _ _ i c) = + i <> mconcat (map getInfoRecursive c) + getInfo (ChildProperty _ _ i _) = i + toChildProperty = id + getSatisfy (ChildProperty _ a _ _) = a diff --git a/src/Propellor/Types/Info.hs b/src/Propellor/Types/Info.hs index c7f6b82f..2e188ae5 100644 --- a/src/Propellor/Types/Info.hs +++ b/src/Propellor/Types/Info.hs @@ -19,6 +19,9 @@ import Data.Monoid import Prelude -- | Information about a Host, which can be provided by its properties. +-- +-- Many different types of data can be contained in the same Info value +-- at the same time. See `toInfo` and `fromInfo`. newtype Info = Info [InfoEntry] deriving (Monoid, Show) @@ -47,6 +50,8 @@ class (Typeable v, Monoid v, Show v) => IsInfo v where addInfo :: IsInfo v => Info -> v -> Info addInfo (Info l) v = Info (InfoEntry v:l) +-- | Converts any value in the `IsInfo` type class into an Info, +-- which is otherwise empty. toInfo :: IsInfo v => v -> Info toInfo = addInfo mempty -- cgit v1.3-2-g0d8e From af7b2d61c0c7f9b4fe53d8f5d18b5426a93cbd7b Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 27 Mar 2016 22:10:48 -0400 Subject: add dep on concurrent-output, and re-enable -O0 Using the external concurrent-output library lets it be built with -O2 as is needed to get good runtime memory use. Enabling -O0 because ghc is using rather a lot more time and memory due to the new more complex types. old master branch: Linking dist/build/propellor-config/propellor-config ... 24.59user 0.97system 0:25.93elapsed 98%CPU (0avgtext+0avgdata 354612maxresident)k 1544inputs+46064outputs (0major+371244minor)pagefaults 0swaps this branch before -O0: Linking dist/build/propellor-config/propellor-config ... 25.56user 0.73system 0:26.61elapsed 98%CPU (0avgtext+0avgdata 345348maxresident)k 0inputs+43480outputs (0major+364163minor)pagefaults 0swaps this branch with -O0: Linking dist/build/propellor-config/propellor-config ... 11.91user 0.75system 0:12.97elapsed 97%CPU (0avgtext+0avgdata 237472maxresident)k 16inputs+37264outputs (0major+336166minor)pagefaults 0swaps Above benchmarks are building all source files needed by config-simple.hs. The story is rather worse for joeyconfig.hs; building it now needs over 500 mb even with -O0 :-/ --- debian/changelog | 3 + debian/control | 2 + doc/todo/depend_on_concurrent-output.mdwn | 3 + propellor.cabal | 34 +- src/Propellor/Bootstrap.hs | 1 + src/System/Console/Concurrent.hs | 44 --- src/System/Console/Concurrent/Internal.hs | 556 ------------------------------ src/System/Process/Concurrent.hs | 34 -- 8 files changed, 27 insertions(+), 650 deletions(-) delete mode 100644 src/System/Console/Concurrent.hs delete mode 100644 src/System/Console/Concurrent/Internal.hs delete mode 100644 src/System/Process/Concurrent.hs (limited to 'propellor.cabal') diff --git a/debian/changelog b/debian/changelog index af2f5c2b..036b8f34 100644 --- a/debian/changelog +++ b/debian/changelog @@ -57,6 +57,9 @@ propellor (3.0.0) UNRELEASED; urgency=medium * The new `pickOS` property combinator can be used to combine different properties, supporting different OS's, into one Property that chooses what to do 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. -- Joey Hess Thu, 24 Mar 2016 15:02:33 -0400 diff --git a/debian/control b/debian/control index 757462d1..898e558d 100644 --- a/debian/control +++ b/debian/control @@ -18,6 +18,7 @@ Build-Depends: libghc-exceptions-dev (>= 0.6), libghc-stm-dev, libghc-text-dev, + libghc-concurrent-output-dev, Maintainer: Joey Hess Standards-Version: 3.9.6 Vcs-Git: git://git.joeyh.name/propellor @@ -41,6 +42,7 @@ Depends: ${misc:Depends}, ${shlibs:Depends}, libghc-exceptions-dev (>= 0.6), libghc-stm-dev, libghc-text-dev, + libghc-concurrent-output-dev, git, make, Description: property-based host configuration management in haskell diff --git a/doc/todo/depend_on_concurrent-output.mdwn b/doc/todo/depend_on_concurrent-output.mdwn index fdc66b04..a104c82b 100644 --- a/doc/todo/depend_on_concurrent-output.mdwn +++ b/doc/todo/depend_on_concurrent-output.mdwn @@ -8,3 +8,6 @@ Once this is done, can switch GHC-Options back to -O0 from -O. -O0 is better because ghc takes less memory to build propellor. [[!tag user/joey]] + +> [[done]]. Didn't wait for it to hit stable; cabal will be used to install +> it. diff --git a/propellor.cabal b/propellor.cabal index e946f697..06142155 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -36,34 +36,39 @@ Description: Executable propellor Main-Is: wrapper.hs - GHC-Options: -threaded -Wall -fno-warn-tabs + GHC-Options: -threaded -Wall -fno-warn-tabs -O0 Extensions: TypeOperators Hs-Source-Dirs: src - Build-Depends: + Build-Depends: -- propellor needs to support the ghc shipped in Debian stable base >= 4.5, base < 5, MissingH, directory, filepath, IfElse, process, bytestring, hslogger, unix, unix-compat, ansi-terminal, containers (>= 0.5), network, async, - time, mtl, transformers, exceptions (>= 0.6), stm, text + time, mtl, transformers, exceptions (>= 0.6), stm, text, + concurrent-output Executable propellor-config Main-Is: config.hs - GHC-Options: -threaded -Wall -fno-warn-tabs + GHC-Options: -threaded -Wall -fno-warn-tabs -O0 Extensions: TypeOperators Hs-Source-Dirs: src - Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, - IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal, - containers (>= 0.5), network, async, time, mtl, transformers, - exceptions (>= 0.6), stm, text, unix + Build-Depends: + base >= 4.5, base < 5, + MissingH, directory, filepath, IfElse, process, bytestring, hslogger, + unix, unix-compat, ansi-terminal, containers (>= 0.5), network, async, + time, mtl, transformers, exceptions (>= 0.6), stm, text, + concurrent-output Library - GHC-Options: -Wall -fno-warn-tabs + GHC-Options: -Wall -fno-warn-tabs -O0 Extensions: TypeOperators Hs-Source-Dirs: src - Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5, - IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal, - containers (>= 0.5), network, async, time, mtl, transformers, - exceptions (>= 0.6), stm, text, unix + Build-Depends: + base >= 4.5, base < 5, + MissingH, directory, filepath, IfElse, process, bytestring, hslogger, + unix, unix-compat, ansi-terminal, containers (>= 0.5), network, async, + time, mtl, transformers, exceptions (>= 0.6), stm, text, + concurrent-output Exposed-Modules: Propellor @@ -201,9 +206,6 @@ Library Utility.ThreadScheduler Utility.Tmp Utility.UserInfo - System.Console.Concurrent - System.Console.Concurrent.Internal - System.Process.Concurrent source-repository head type: git diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs index 69eee66c..3b4c3106 100644 --- a/src/Propellor/Bootstrap.hs +++ b/src/Propellor/Bootstrap.hs @@ -90,6 +90,7 @@ depsCommand msys = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall]) , "libghc-exceptions-dev" , "libghc-stm-dev" , "libghc-text-dev" + , "libghc-concurrent-output-dev" , "make" ] fbsddeps = diff --git a/src/System/Console/Concurrent.hs b/src/System/Console/Concurrent.hs deleted file mode 100644 index 12447637..00000000 --- a/src/System/Console/Concurrent.hs +++ /dev/null @@ -1,44 +0,0 @@ --- | --- Copyright: 2015 Joey Hess --- License: BSD-2-clause --- --- Concurrent output handling. --- --- > import Control.Concurrent.Async --- > import System.Console.Concurrent --- > --- > main = withConcurrentOutput $ --- > outputConcurrent "washed the car\n" --- > `concurrently` --- > outputConcurrent "walked the dog\n" --- > `concurrently` --- > createProcessConcurrent (proc "ls" []) - -{-# LANGUAGE CPP #-} - -module System.Console.Concurrent ( - -- * Concurrent output - withConcurrentOutput, - Outputable(..), - outputConcurrent, - errorConcurrent, - ConcurrentProcessHandle, -#ifndef mingw32_HOST_OS - createProcessConcurrent, -#endif - waitForProcessConcurrent, - createProcessForeground, - flushConcurrentOutput, - lockOutput, - -- * Low level access to the output buffer - OutputBuffer, - StdHandle(..), - bufferOutputSTM, - outputBufferWaiterSTM, - waitAnyBuffer, - waitCompleteLines, - emitOutputBuffer, -) where - -import System.Console.Concurrent.Internal - diff --git a/src/System/Console/Concurrent/Internal.hs b/src/System/Console/Concurrent/Internal.hs deleted file mode 100644 index 5b9cf454..00000000 --- a/src/System/Console/Concurrent/Internal.hs +++ /dev/null @@ -1,556 +0,0 @@ -{-# LANGUAGE BangPatterns, TypeSynonymInstances, FlexibleInstances, TupleSections #-} -{-# LANGUAGE CPP #-} - --- | --- Copyright: 2015 Joey Hess --- License: BSD-2-clause --- --- Concurrent output handling, internals. --- --- May change at any time. - -module System.Console.Concurrent.Internal where - -import System.IO -#ifndef mingw32_HOST_OS -import System.Posix.IO -#endif -import System.Directory -import System.Exit -import Control.Monad -import Control.Monad.IO.Class (liftIO, MonadIO) -import System.IO.Unsafe (unsafePerformIO) -import Control.Concurrent -import Control.Concurrent.STM -import Control.Concurrent.Async -import Data.Maybe -import Data.List -import Data.Monoid -import qualified System.Process as P -import qualified Data.Text as T -import qualified Data.Text.IO as T -import Control.Applicative -import Prelude -import System.Log.Logger - -import Utility.Monad -import Utility.Exception - -data OutputHandle = OutputHandle - { outputLock :: TMVar Lock - , outputBuffer :: TMVar OutputBuffer - , errorBuffer :: TMVar OutputBuffer - , outputThreads :: TMVar Integer - , processWaiters :: TMVar [Async ()] - , waitForProcessLock :: TMVar () - } - -data Lock = Locked - --- | A shared global variable for the OutputHandle. -{-# NOINLINE globalOutputHandle #-} -globalOutputHandle :: OutputHandle -globalOutputHandle = unsafePerformIO $ OutputHandle - <$> newEmptyTMVarIO - <*> newTMVarIO (OutputBuffer []) - <*> newTMVarIO (OutputBuffer []) - <*> newTMVarIO 0 - <*> newTMVarIO [] - <*> newEmptyTMVarIO - --- | Holds a lock while performing an action. This allows the action to --- perform its own output to the console, without using functions from this --- module. --- --- While this is running, other threads that try to lockOutput will block. --- Any calls to `outputConcurrent` and `createProcessConcurrent` will not --- block, but the output will be buffered and displayed only once the --- action is done. -lockOutput :: (MonadIO m, MonadMask m) => m a -> m a -lockOutput = bracket_ (liftIO takeOutputLock) (liftIO dropOutputLock) - --- | Blocks until we have the output lock. -takeOutputLock :: IO () -takeOutputLock = void $ takeOutputLock' True - --- | Tries to take the output lock, without blocking. -tryTakeOutputLock :: IO Bool -tryTakeOutputLock = takeOutputLock' False - -withLock :: (TMVar Lock -> STM a) -> IO a -withLock a = atomically $ a (outputLock globalOutputHandle) - -takeOutputLock' :: Bool -> IO Bool -takeOutputLock' block = do - locked <- withLock $ \l -> do - v <- tryTakeTMVar l - case v of - Just Locked - | block -> retry - | otherwise -> do - -- Restore value we took. - putTMVar l Locked - return False - Nothing -> do - putTMVar l Locked - return True - when locked $ do - (outbuf, errbuf) <- atomically $ (,) - <$> swapTMVar (outputBuffer globalOutputHandle) (OutputBuffer []) - <*> swapTMVar (errorBuffer globalOutputHandle) (OutputBuffer []) - emitOutputBuffer StdOut outbuf - emitOutputBuffer StdErr errbuf - return locked - --- | Only safe to call after taking the output lock. -dropOutputLock :: IO () -dropOutputLock = withLock $ void . takeTMVar - --- | Use this around any actions that use `outputConcurrent` --- or `createProcessConcurrent` --- --- This is necessary to ensure that buffered concurrent output actually --- gets displayed before the program exits. -withConcurrentOutput :: (MonadIO m, MonadMask m) => m a -> m a -withConcurrentOutput a = a `finally` liftIO flushConcurrentOutput - --- | Blocks until any processes started by `createProcessConcurrent` have --- finished, and any buffered output is displayed. Also blocks while --- `lockOutput` is is use. --- --- `withConcurrentOutput` calls this at the end, so you do not normally --- need to use this. -flushConcurrentOutput :: IO () -flushConcurrentOutput = do - atomically $ do - r <- takeTMVar (outputThreads globalOutputHandle) - if r <= 0 - then putTMVar (outputThreads globalOutputHandle) r - else retry - -- Take output lock to wait for anything else that might be - -- currently generating output. - lockOutput $ return () - --- | Values that can be output. -class Outputable v where - toOutput :: v -> T.Text - -instance Outputable T.Text where - toOutput = id - -instance Outputable String where - toOutput = toOutput . T.pack - --- | Displays a value to stdout. --- --- No newline is appended to the value, so if you want a newline, be sure --- to include it yourself. --- --- Uses locking to ensure that the whole output occurs atomically --- even when other threads are concurrently generating output. --- --- When something else is writing to the console at the same time, this does --- not block. It buffers the value, so it will be displayed once the other --- writer is done. -outputConcurrent :: Outputable v => v -> IO () -outputConcurrent = outputConcurrent' StdOut - --- | Like `outputConcurrent`, but displays to stderr. --- --- (Does not throw an exception.) -errorConcurrent :: Outputable v => v -> IO () -errorConcurrent = outputConcurrent' StdErr - -outputConcurrent' :: Outputable v => StdHandle -> v -> IO () -outputConcurrent' stdh v = bracket setup cleanup go - where - setup = tryTakeOutputLock - cleanup False = return () - cleanup True = dropOutputLock - go True = do - T.hPutStr h (toOutput v) - hFlush h - go False = do - oldbuf <- atomically $ takeTMVar bv - newbuf <- addOutputBuffer (Output (toOutput v)) oldbuf - atomically $ putTMVar bv newbuf - h = toHandle stdh - bv = bufferFor stdh - -newtype ConcurrentProcessHandle = ConcurrentProcessHandle P.ProcessHandle - -toConcurrentProcessHandle :: (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle) -> (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle) -toConcurrentProcessHandle (i, o, e, h) = (i, o, e, ConcurrentProcessHandle h) - --- | Use this to wait for processes started with --- `createProcessConcurrent` and `createProcessForeground`, and get their --- exit status. --- --- Note that such processes are actually automatically waited for --- internally, so not calling this explicitly will not result --- in zombie processes. This behavior differs from `P.waitForProcess` -waitForProcessConcurrent :: ConcurrentProcessHandle -> IO ExitCode -waitForProcessConcurrent (ConcurrentProcessHandle h) = - bracket lock unlock checkexit - where - lck = waitForProcessLock globalOutputHandle - lock = atomically $ tryPutTMVar lck () - unlock True = atomically $ takeTMVar lck - unlock False = return () - checkexit locked = maybe (waitsome locked) return - =<< P.getProcessExitCode h - waitsome True = do - let v = processWaiters globalOutputHandle - l <- atomically $ readTMVar v - if null l - -- Avoid waitAny [] which blocks forever - then P.waitForProcess h - else do - -- Wait for any of the running - -- processes to exit. It may or may not - -- be the one corresponding to the - -- ProcessHandle. If it is, - -- getProcessExitCode will succeed. - void $ tryIO $ waitAny l - checkexit True - waitsome False = do - -- Another thread took the lck first. Wait for that thread to - -- wait for one of the running processes to exit. - atomically $ do - putTMVar lck () - takeTMVar lck - checkexit False - --- Registers an action that waits for a process to exit, --- adding it to the processWaiters list, and removing it once the action --- completes. -asyncProcessWaiter :: IO () -> IO () -asyncProcessWaiter waitaction = do - regdone <- newEmptyTMVarIO - waiter <- async $ do - self <- atomically (takeTMVar regdone) - waitaction `finally` unregister self - register waiter regdone - where - v = processWaiters globalOutputHandle - register waiter regdone = atomically $ do - l <- takeTMVar v - putTMVar v (waiter:l) - putTMVar regdone waiter - unregister waiter = atomically $ do - l <- takeTMVar v - putTMVar v (filter (/= waiter) l) - --- | Wrapper around `System.Process.createProcess` that prevents --- multiple processes that are running concurrently from writing --- to stdout/stderr at the same time. --- --- If the process does not output to stdout or stderr, it's run --- by createProcess entirely as usual. Only processes that can generate --- output are handled specially: --- --- A process is allowed to write to stdout and stderr in the usual --- way, assuming it can successfully take the output lock. --- --- When the output lock is held (ie, by another concurrent process, --- or because `outputConcurrent` is being called at the same time), --- the process is instead run with its stdout and stderr --- redirected to a buffer. The buffered output will be displayed as soon --- as the output lock becomes free. --- --- Currently only available on Unix systems, not Windows. -#ifndef mingw32_HOST_OS -createProcessConcurrent :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle) -createProcessConcurrent p - | willOutput (P.std_out p) || willOutput (P.std_err p) = - ifM tryTakeOutputLock - ( fgProcess p - , bgProcess p - ) - | otherwise = do - r@(_, _, _, h) <- P.createProcess p - asyncProcessWaiter $ - void $ tryIO $ P.waitForProcess h - return (toConcurrentProcessHandle r) -#endif - --- | Wrapper around `System.Process.createProcess` that makes sure a process --- is run in the foreground, with direct access to stdout and stderr. --- Useful when eg, running an interactive process. -createProcessForeground :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle) -createProcessForeground p = do - takeOutputLock - fgProcess p - -fgProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle) -fgProcess p = do - r@(_, _, _, h) <- P.createProcess p - `onException` dropOutputLock - registerOutputThread - debug ["fgProcess", showProc p] - -- Wait for the process to exit and drop the lock. - asyncProcessWaiter $ do - void $ tryIO $ P.waitForProcess h - unregisterOutputThread - dropOutputLock - debug ["fgProcess done", showProc p] - return (toConcurrentProcessHandle r) - -debug :: [String] -> IO () -debug = debugM "concurrent-output" . unwords - -showProc :: P.CreateProcess -> String -showProc = go . P.cmdspec - where - go (P.ShellCommand s) = s - go (P.RawCommand c ps) = show (c, ps) - -#ifndef mingw32_HOST_OS -bgProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle) -bgProcess p = do - (toouth, fromouth) <- pipe - (toerrh, fromerrh) <- pipe - debug ["bgProcess", showProc p] - let p' = p - { P.std_out = rediroutput (P.std_out p) toouth - , P.std_err = rediroutput (P.std_err p) toerrh - } - registerOutputThread - r@(_, _, _, h) <- P.createProcess p' - `onException` unregisterOutputThread - asyncProcessWaiter $ void $ tryIO $ P.waitForProcess h - outbuf <- setupOutputBuffer StdOut toouth (P.std_out p) fromouth - errbuf <- setupOutputBuffer StdErr toerrh (P.std_err p) fromerrh - void $ async $ bufferWriter [outbuf, errbuf] - return (toConcurrentProcessHandle r) - where - pipe = do - (from, to) <- createPipe - (,) <$> fdToHandle to <*> fdToHandle from - rediroutput ss h - | willOutput ss = P.UseHandle h - | otherwise = ss -#endif - -willOutput :: P.StdStream -> Bool -willOutput P.Inherit = True -willOutput _ = False - --- | Buffered output. -data OutputBuffer = OutputBuffer [OutputBufferedActivity] - deriving (Eq) - -data StdHandle = StdOut | StdErr - -toHandle :: StdHandle -> Handle -toHandle StdOut = stdout -toHandle StdErr = stderr - -bufferFor :: StdHandle -> TMVar OutputBuffer -bufferFor StdOut = outputBuffer globalOutputHandle -bufferFor StdErr = errorBuffer globalOutputHandle - -data OutputBufferedActivity - = Output T.Text - | InTempFile - { tempFile :: FilePath - , endsInNewLine :: Bool - } - deriving (Eq) - -data AtEnd = AtEnd - deriving Eq - -data BufSig = BufSig - -setupOutputBuffer :: StdHandle -> Handle -> P.StdStream -> Handle -> IO (StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd) -setupOutputBuffer h toh ss fromh = do - hClose toh - buf <- newMVar (OutputBuffer []) - bufsig <- atomically newEmptyTMVar - bufend <- atomically newEmptyTMVar - void $ async $ outputDrainer ss fromh buf bufsig bufend - return (h, buf, bufsig, bufend) - --- Drain output from the handle, and buffer it. -outputDrainer :: P.StdStream -> Handle -> MVar OutputBuffer -> TMVar BufSig -> TMVar AtEnd -> IO () -outputDrainer ss fromh buf bufsig bufend - | willOutput ss = go - | otherwise = atend - where - go = do - t <- T.hGetChunk fromh - if T.null t - then atend - else do - modifyMVar_ buf $ addOutputBuffer (Output t) - changed - go - atend = do - atomically $ putTMVar bufend AtEnd - hClose fromh - changed = atomically $ do - void $ tryTakeTMVar bufsig - putTMVar bufsig BufSig - -registerOutputThread :: IO () -registerOutputThread = do - let v = outputThreads globalOutputHandle - atomically $ putTMVar v . succ =<< takeTMVar v - -unregisterOutputThread :: IO () -unregisterOutputThread = do - let v = outputThreads globalOutputHandle - atomically $ putTMVar v . pred =<< takeTMVar v - --- Wait to lock output, and once we can, display everything --- that's put into the buffers, until the end. --- --- If end is reached before lock is taken, instead add the command's --- buffers to the global outputBuffer and errorBuffer. -bufferWriter :: [(StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd)] -> IO () -bufferWriter ts = do - activitysig <- atomically newEmptyTMVar - worker1 <- async $ lockOutput $ - ifM (atomically $ tryPutTMVar activitysig ()) - ( void $ mapConcurrently displaybuf ts - , noop -- buffers already moved to global - ) - worker2 <- async $ void $ globalbuf activitysig worker1 - void $ async $ do - void $ waitCatch worker1 - void $ waitCatch worker2 - unregisterOutputThread - where - displaybuf v@(outh, buf, bufsig, bufend) = do - change <- atomically $ - (Right <$> takeTMVar bufsig) - `orElse` - (Left <$> takeTMVar bufend) - l <- takeMVar buf - putMVar buf (OutputBuffer []) - emitOutputBuffer outh l - case change of - Right BufSig -> displaybuf v - Left AtEnd -> return () - globalbuf activitysig worker1 = do - ok <- atomically $ do - -- signal we're going to handle it - -- (returns false if the displaybuf already did) - ok <- tryPutTMVar activitysig () - -- wait for end of all buffers - when ok $ - mapM_ (\(_outh, _buf, _bufsig, bufend) -> takeTMVar bufend) ts - return ok - when ok $ do - -- add all of the command's buffered output to the - -- global output buffer, atomically - bs <- forM ts $ \(outh, buf, _bufsig, _bufend) -> - (outh,) <$> takeMVar buf - atomically $ - forM_ bs $ \(outh, b) -> - bufferOutputSTM' outh b - -- worker1 might be blocked waiting for the output - -- lock, and we've already done its job, so cancel it - cancel worker1 - --- Adds a value to the OutputBuffer. When adding Output to a Handle, --- it's cheaper to combine it with any already buffered Output to that --- same Handle. --- --- When the total buffered Output exceeds 1 mb in size, it's moved out of --- memory, to a temp file. This should only happen rarely, but is done to --- avoid some verbose process unexpectedly causing excessive memory use. -addOutputBuffer :: OutputBufferedActivity -> OutputBuffer -> IO OutputBuffer -addOutputBuffer (Output t) (OutputBuffer buf) - | T.length t' <= 1048576 = return $ OutputBuffer (Output t' : other) - | otherwise = do - tmpdir <- getTemporaryDirectory - (tmp, h) <- openTempFile tmpdir "output.tmp" - let !endnl = endsNewLine t' - let i = InTempFile - { tempFile = tmp - , endsInNewLine = endnl - } - T.hPutStr h t' - hClose h - return $ OutputBuffer (i : other) - where - !t' = T.concat (mapMaybe getOutput this) <> t - !(this, other) = partition isOutput buf - isOutput v = case v of - Output _ -> True - _ -> False - getOutput v = case v of - Output t'' -> Just t'' - _ -> Nothing -addOutputBuffer v (OutputBuffer buf) = return $ OutputBuffer (v:buf) - --- | Adds a value to the output buffer for later display. --- --- Note that buffering large quantities of data this way will keep it --- resident in memory until it can be displayed. While `outputConcurrent` --- uses temp files if the buffer gets too big, this STM function cannot do --- so. -bufferOutputSTM :: Outputable v => StdHandle -> v -> STM () -bufferOutputSTM h v = bufferOutputSTM' h (OutputBuffer [Output (toOutput v)]) - -bufferOutputSTM' :: StdHandle -> OutputBuffer -> STM () -bufferOutputSTM' h (OutputBuffer newbuf) = do - (OutputBuffer buf) <- takeTMVar bv - putTMVar bv (OutputBuffer (newbuf ++ buf)) - where - bv = bufferFor h - --- | A STM action that waits for some buffered output to become --- available, and returns it. --- --- The function can select a subset of output when only some is desired; --- the fst part is returned and the snd is left in the buffer. --- --- This will prevent it from being displayed in the usual way, so you'll --- need to use `emitOutputBuffer` to display it yourself. -outputBufferWaiterSTM :: (OutputBuffer -> (OutputBuffer, OutputBuffer)) -> STM (StdHandle, OutputBuffer) -outputBufferWaiterSTM selector = waitgetbuf StdOut `orElse` waitgetbuf StdErr - where - waitgetbuf h = do - let bv = bufferFor h - (selected, rest) <- selector <$> takeTMVar bv - when (selected == OutputBuffer []) - retry - putTMVar bv rest - return (h, selected) - -waitAnyBuffer :: OutputBuffer -> (OutputBuffer, OutputBuffer) -waitAnyBuffer b = (b, OutputBuffer []) - --- | Use with `outputBufferWaiterSTM` to make it only return buffered --- output that ends with a newline. Anything buffered without a newline --- is left in the buffer. -waitCompleteLines :: OutputBuffer -> (OutputBuffer, OutputBuffer) -waitCompleteLines (OutputBuffer l) = - let (selected, rest) = span completeline l - in (OutputBuffer selected, OutputBuffer rest) - where - completeline (v@(InTempFile {})) = endsInNewLine v - completeline (Output b) = endsNewLine b - -endsNewLine :: T.Text -> Bool -endsNewLine t = not (T.null t) && T.last t == '\n' - --- | Emits the content of the OutputBuffer to the Handle --- --- If you use this, you should use `lockOutput` to ensure you're the only --- thread writing to the console. -emitOutputBuffer :: StdHandle -> OutputBuffer -> IO () -emitOutputBuffer stdh (OutputBuffer l) = - forM_ (reverse l) $ \ba -> case ba of - Output t -> emit t - InTempFile tmp _ -> do - emit =<< T.readFile tmp - void $ tryWhenExists $ removeFile tmp - where - outh = toHandle stdh - emit t = void $ tryIO $ do - T.hPutStr outh t - hFlush outh diff --git a/src/System/Process/Concurrent.hs b/src/System/Process/Concurrent.hs deleted file mode 100644 index 0e00e4fd..00000000 --- a/src/System/Process/Concurrent.hs +++ /dev/null @@ -1,34 +0,0 @@ --- | --- Copyright: 2015 Joey Hess --- License: BSD-2-clause --- --- The functions exported by this module are intended to be drop-in --- replacements for those from System.Process, when converting a whole --- program to use System.Console.Concurrent. - -module System.Process.Concurrent where - -import System.Console.Concurrent -import System.Console.Concurrent.Internal (ConcurrentProcessHandle(..)) -import System.Process hiding (createProcess, waitForProcess) -import System.IO -import System.Exit - --- | Calls `createProcessConcurrent` --- --- You should use the waitForProcess in this module on the resulting --- ProcessHandle. Using System.Process.waitForProcess instead can have --- mildly unexpected results. -createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -createProcess p = do - (i, o, e, ConcurrentProcessHandle h) <- createProcessConcurrent p - return (i, o, e, h) - --- | Calls `waitForProcessConcurrent` --- --- You should only use this on a ProcessHandle obtained by calling --- createProcess from this module. Using this with a ProcessHandle --- obtained from System.Process.createProcess etc will have extremely --- unexpected results; it can wait a very long time before returning. -waitForProcess :: ProcessHandle -> IO ExitCode -waitForProcess = waitForProcessConcurrent . ConcurrentProcessHandle -- cgit v1.3-2-g0d8e From 49255357459cd2f5661e5f6832ac1f611bb37967 Mon Sep 17 00:00:00 2001 From: Evan Cofsky Date: Tue, 29 Mar 2016 13:05:35 -0500 Subject: Adding support for software-properties-common to OS properties branch. The config-simple file now shows: 1. Adding PPAs 2. Adding apt keys from a remote keyserver 3. Adding apt sources 4. Installing signed packages from a new repository. --- propellor.cabal | 1 + src/Propellor/Property/Apt/PPA.hs | 121 +++++++++++++++++++++ .../Property/AptSoftwarePropertiesCommon.hs | 121 --------------------- 3 files changed, 122 insertions(+), 121 deletions(-) create mode 100644 src/Propellor/Property/Apt/PPA.hs delete mode 100644 src/Propellor/Property/AptSoftwarePropertiesCommon.hs (limited to 'propellor.cabal') diff --git a/propellor.cabal b/propellor.cabal index 06142155..9f74d264 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -78,6 +78,7 @@ Library Propellor.Property.Aiccu Propellor.Property.Apache Propellor.Property.Apt + Propellor.Property.Apt.PPA Propellor.Property.Cmd Propellor.Property.Concurrent Propellor.Property.Conductor diff --git a/src/Propellor/Property/Apt/PPA.hs b/src/Propellor/Property/Apt/PPA.hs new file mode 100644 index 00000000..9831ff30 --- /dev/null +++ b/src/Propellor/Property/Apt/PPA.hs @@ -0,0 +1,121 @@ +-- | This module provides properties software-properties-common. +module Propellor.Property.Apt.PPA where + +import Data.List +import Control.Applicative +import Prelude +import Data.String.Utils +import Data.String (IsString(..)) +import Propellor.Base +import qualified Propellor.Property.Apt as Apt + +-- | Ensure it's installed in case it's not. It's part of Buntish's defaults so +-- one might assume... +installed :: Property DebianLike +installed = Apt.installed ["software-properties-common"] + +-- | Personal Package Archives are people's individual package contributions to +-- Ubuntu. There's a well-known format for adding them, and this type represents +-- that. It's also an instance of 'Show' and 'IsString' so it can work with +-- 'OverloadedStrings'. More on PPAs can be found at +-- +data PPA = PPA { + -- | The Launchpad account hosting this archive. + ppaAccount :: String, + -- | The + ppaArchive :: String +} deriving (Eq, Ord) + +instance Show PPA where + show p = concat ["ppa:", ppaAccount p, "/", ppaArchive p] + +instance IsString PPA where + -- | Parse strings like "ppa:zfs-native/stable" into a PPA. + fromString s = + let + [_, ppa] = split "ppa:" s + [acct, arch] = split "/" ppa + in + PPA acct arch + +-- | Adds a PPA to the local system repositories. +addPpa :: PPA -> Property DebianLike +addPpa p = + cmdPropertyEnv "apt-add-repository" ["--yes", show p] Apt.noninteractiveEnv + `assume` MadeChange + `describe` ("Added PPA " ++ (show p)) + `requires` installed + +-- | A repository key ID to be downloaded with apt-key. +data AptKeyId = AptKeyId { + akiName :: String, + akiId :: String, + akiServer :: String + } deriving (Eq, Ord) + +instance Show AptKeyId where + show k = unwords ["Apt Key", akiName k, akiId k, "from", akiServer k] + +-- | Adds an 'AptKeyId' from the specified GPG server. +addKeyId :: AptKeyId -> Property DebianLike +addKeyId keyId = + check keyTrusted akcmd + `describe` (unwords ["Add third-party Apt key", show keyId]) + where + akcmd = + tightenTargets $ cmdProperty "apt-key" ["adv", "--keyserver", akiServer keyId, "--recv-keys", akiId keyId] + keyTrusted = + let + pks ls = concatMap (drop 1 . split "/") + $ concatMap (take 1 . drop 1 . words) + $ filter (\l -> "pub" `isPrefixOf` l) + $ lines ls + nkid = take 8 (akiId keyId) + in + (isInfixOf [nkid] . pks) <$> readProcess "apt-key" ["list"] + +-- | An Apt source line that apt-add-repository will just add to +-- sources.list. It's also an instance of both 'Show' and 'IsString' to make +-- using 'OverloadedStrings' in the configuration file easier. +-- +-- | FIXME there's apparently an optional "options" fragment that I've +-- definitely not parsed here. +data AptSource = AptSource { + -- | The URL hosting the repository + asURL :: Apt.Url, + + -- | The operating system suite + asSuite :: String, + + -- | The list of components to install from this repository. + asComponents :: [String] + } deriving (Eq, Ord) + +instance Show AptSource where + show asrc = unwords ["deb", asURL asrc, asSuite asrc, unwords . asComponents $ asrc] + +instance IsString AptSource where + fromString s = + let + url:suite:comps = drop 1 . words $ s + in + AptSource url suite comps + +-- | A repository for apt-add-source, either a PPA or a regular repository line. +data AptRepository = AptRepositoryPPA PPA | AptRepositorySource AptSource + +-- | Adds an 'AptRepository' using apt-add-source. +addRepository :: AptRepository -> Property DebianLike +addRepository (AptRepositoryPPA p) = addPpa p +addRepository (AptRepositorySource src) = + check repoExists addSrc + `describe` unwords ["Adding APT repository", show src] + `requires` installed + where + allSourceLines = + readProcess "/bin/sh" ["-c", "cat /etc/apt/sources.list /etc/apt/sources.list.d/*"] + activeSources = map (\s -> fromString s :: AptSource ) + . filter (not . isPrefixOf "#") + . filter (/= "") . lines <$> allSourceLines + repoExists = isInfixOf [src] <$> activeSources + addSrc = cmdProperty "apt-add-source" [show src] diff --git a/src/Propellor/Property/AptSoftwarePropertiesCommon.hs b/src/Propellor/Property/AptSoftwarePropertiesCommon.hs deleted file mode 100644 index 484f7b08..00000000 --- a/src/Propellor/Property/AptSoftwarePropertiesCommon.hs +++ /dev/null @@ -1,121 +0,0 @@ --- | This module provides properties for Buntish. -module Propellor.Property.AptSoftwarePropertiesCommon where - -import Data.List -import Control.Applicative -import Prelude -import Data.String.Utils -import Data.String (IsString(..)) -import Propellor.Base -import qualified Propellor.Property.Apt as Apt - --- | Ensure it's installed in case it's not. It's part of Buntish's defaults so --- one might assume... -installed :: Property NoInfo -installed = Apt.installed ["software-properties-common"] - --- | Personal Package Archives are people's individual package contributions to --- Ubuntu. There's a well-known format for adding them, and this type represents --- that. It's also an instance of 'Show' and 'IsString' so it can work with --- 'OverloadedStrings'. More on PPAs can be found at --- -data PPA = PPA { - -- | The Launchpad account hosting this archive. - ppaAccount :: String, - -- | The - ppaArchive :: String -} deriving (Eq, Ord) - -instance Show PPA where - show p = concat ["ppa:", ppaAccount p, "/", ppaArchive p] - -instance IsString PPA where - -- | Parse strings like "ppa:zfs-native/stable" into a PPA. - fromString s = - let - [_, ppa] = split "ppa:" s - [acct, arch] = split "/" ppa - in - PPA acct arch - --- | Adds a PPA to the local system repositories. -addPpa :: PPA -> Property NoInfo -addPpa p = - cmdPropertyEnv "apt-add-repository" ["--yes", show p] Apt.noninteractiveEnv - `assume` MadeChange - `describe` ("Added PPA " ++ (show p)) - `requires` installed - --- | A repository key ID to be downloaded with apt-key. -data AptKeyId = AptKeyId { - akiName :: String, - akiId :: String, - akiServer :: String - } deriving (Eq, Ord) - -instance Show AptKeyId where - show k = unwords ["Apt Key", akiName k, akiId k, "from", akiServer k] - --- | Adds an 'AptKeyId' from the specified GPG server. -addKeyId :: AptKeyId -> Property NoInfo -addKeyId keyId = - check keyTrusted akcmd - `describe` (unwords ["Add third-party Apt key", show keyId]) - where - akcmd = - cmdProperty "apt-key" ["adv", "--keyserver", akiServer keyId, "--recv-keys", akiId keyId] - keyTrusted = - let - pks ls = concatMap (drop 1 . split "/") - $ concatMap (take 1 . drop 1 . words) - $ filter (\l -> "pub" `isPrefixOf` l) - $ lines ls - nkid = take 8 (akiId keyId) - in - (isInfixOf [nkid] . pks) <$> readProcess "apt-key" ["list"] - --- | An Apt source line that apt-add-repository will just add to --- sources.list. It's also an instance of both 'Show' and 'IsString' to make --- using 'OverloadedStrings' in the configuration file easier. --- --- | FIXME there's apparently an optional "options" fragment that I've --- definitely not parsed here. -data AptSource = AptSource { - -- | The URL hosting the repository - asURL :: Apt.Url, - - -- | The operating system suite - asSuite :: String, - - -- | The list of components to install from this repository. - asComponents :: [String] - } deriving (Eq, Ord) - -instance Show AptSource where - show asrc = unwords ["deb", asURL asrc, asSuite asrc, unwords . asComponents $ asrc] - -instance IsString AptSource where - fromString s = - let - url:suite:comps = drop 1 . words $ s - in - AptSource url suite comps - --- | A repository for apt-add-source, either a PPA or a regular repository line. -data AptRepository = AptRepositoryPPA PPA | AptRepositorySource AptSource - --- | Adds an 'AptRepository' using apt-add-source. -addRepository :: AptRepository -> Property NoInfo -addRepository (AptRepositoryPPA p) = addPpa p -addRepository (AptRepositorySource src) = - check repoExists addSrc - `describe` unwords ["Adding APT repository", show src] - `requires` installed - where - allSourceLines = - readProcess "/bin/sh" ["-c", "cat /etc/apt/sources.list /etc/apt/sources.list.d/*"] - activeSources = map (\s -> fromString s :: AptSource ) - . filter (not . isPrefixOf "#") - . filter (/= "") . lines <$> allSourceLines - repoExists = isInfixOf [src] <$> activeSources - addSrc = cmdProperty "apt-add-source" [show src] -- cgit v1.3-2-g0d8e From 1dc914a71c94e0395641565e5891a2dc33ba1b35 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 1 Apr 2016 21:20:13 -0400 Subject: separate propellor --init --- debian/changelog | 4 +- doc/README.mdwn | 2 +- propellor.cabal | 1 + src/Propellor/CmdLine.hs | 4 + src/Propellor/DotDir.hs | 348 ++++++++++++++++++++++++++++++++++++++++ src/Propellor/Types/CmdLine.hs | 1 + src/wrapper.hs | 353 ++--------------------------------------- 7 files changed, 370 insertions(+), 343 deletions(-) create mode 100644 src/Propellor/DotDir.hs (limited to 'propellor.cabal') diff --git a/debian/changelog b/debian/changelog index 21c53bf8..ae593902 100644 --- a/debian/changelog +++ b/debian/changelog @@ -64,8 +64,8 @@ propellor (3.0.0) UNRELEASED; urgency=medium these complex new types. * Added dependency on concurrent-output; removed embedded copy. * Apt.PPA: New module, contributed by Evan Cofsky. - * Improved propellor's first run experience; the wrapper program will - now walk the user through setting up ~/.propellor, with a choice between + * Improved propellor's first run experience; propellor --init will + walk the user through setting up ~/.propellor, with a choice between a clone of propellor's git repository, or a minimal config, and will configure propellor to use a gpg key. diff --git a/doc/README.mdwn b/doc/README.mdwn index fc3c3fd1..31d222c1 100644 --- a/doc/README.mdwn +++ b/doc/README.mdwn @@ -42,7 +42,7 @@ see [configuration for the Haskell newbie](https://propellor.branchable.com/hask `cabal install propellor` or `apt-get install propellor` -2. Run `propellor` for the first time. It will set up a `~/.propellor/` git +2. Run `propellor --init` ; this will set up a `~/.propellor/` git repository for you. 3. Edit `~/.propellor/config.hs`, and add a host you want to manage. You can start by not adding any properties, or only a few. diff --git a/propellor.cabal b/propellor.cabal index 9f74d264..d97d4096 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -151,6 +151,7 @@ Library Propellor.Info Propellor.Message Propellor.Debug + Propellor.DotDir Propellor.PrivData Propellor.Engine Propellor.EnsureProperty diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs index d93a8e3a..19e49f5a 100644 --- a/src/Propellor/CmdLine.hs +++ b/src/Propellor/CmdLine.hs @@ -16,6 +16,7 @@ import Propellor.Git.VerifiedBranch import Propellor.Bootstrap import Propellor.Spin import Propellor.Types.CmdLine +import Propellor.DotDir (interactiveInit) import qualified Propellor.Property.Docker as Docker import qualified Propellor.Property.Chroot as Chroot import qualified Propellor.Shim as Shim @@ -23,6 +24,7 @@ import qualified Propellor.Shim as Shim usage :: Handle -> IO () usage h = hPutStrLn h $ unlines [ "Usage:" + , " propellor --init" , " propellor" , " propellor hostname" , " propellor --spin targethost [--via relayhost]" @@ -69,6 +71,7 @@ processCmdLine = go =<< getArgs go ("--serialized":s:[]) = serialized Serialized s go ("--continue":s:[]) = serialized Continue s go ("--gitpush":fin:fout:_) = return $ GitPush (Prelude.read fin) (Prelude.read fout) + go ("--init":_) = return Init go ("--run":h:[]) = go [h] go (h:[]) | "--" `isPrefixOf` h = usageError [h] @@ -130,6 +133,7 @@ defaultMain hostlist = withConcurrentOutput $ do fetchFirst (buildFirst (findHost hostlist hn) cr cmdline (runhost hn)) -- When continuing after a rebuild, don't want to rebuild again. go _ (Continue cmdline) = go NoRebuild cmdline + go _ Init = interactiveInit withhost :: HostName -> (Host -> IO ()) -> IO () withhost hn a = maybe (unknownhost hn hostlist) a (findHost hostlist hn) diff --git a/src/Propellor/DotDir.hs b/src/Propellor/DotDir.hs new file mode 100644 index 00000000..92c20654 --- /dev/null +++ b/src/Propellor/DotDir.hs @@ -0,0 +1,348 @@ +module Propellor.DotDir where + +import Propellor.Message +import Propellor.Bootstrap +import Propellor.Git +import Propellor.Gpg +import Utility.UserInfo +import Utility.Monad +import Utility.Process +import Utility.SafeCommand +import Utility.Exception +import Utility.Path + +import Data.Char +import Data.List +import Control.Monad +import Control.Monad.IfElse +import System.Directory +import System.FilePath +import System.Posix.Directory +import System.IO +import Control.Applicative +import Prelude + +distdir :: FilePath +distdir = "/usr/src/propellor" + +-- A distribution may include a bundle of propellor's git repository here. +-- If not, it will be pulled from the network when needed. +distrepo :: FilePath +distrepo = distdir "propellor.git" + +-- File containing the head rev of the distrepo. +disthead :: FilePath +disthead = distdir "head" + +upstreambranch :: String +upstreambranch = "upstream/master" + +-- Using the github mirror of the main propellor repo because +-- it is accessible over https for better security. +netrepo :: String +netrepo = "https://github.com/joeyh/propellor.git" + +dotPropellor :: IO FilePath +dotPropellor = do + home <- myHomeDir + return (home ".propellor") + +interactiveInit :: IO () +interactiveInit = ifM (doesDirectoryExist =<< dotPropellor) + ( error "~/.propellor/ already exists, not doing anything" + , do + welcomeBanner + setup + ) + +welcomeBanner :: IO () +welcomeBanner = putStr $ unlines $ map prettify + [ "" + , "" + , " _ ______`| ,-.__" + , " .--------------------------- / ~___-=O`/|O`/__| (____.'" + , " - Welcome to -- ~ / | / ) _.-'-._" + , " - Propellor! -- `/-==__ _/__|/__=-| ( ~_" + , " `--------------------------- * ~ | | '--------'" + , " (o) `" + , "" + , "" + ] + where + prettify = map (replace '~' '\\') + replace x y c + | c == x = y + | otherwise = c + +prompt :: String -> [(String, IO ())] -> IO () +prompt p cs = do + putStr (p ++ " [" ++ intercalate "|" (map fst cs) ++ "] ") + hFlush stdout + r <- map toLower <$> getLine + if null r + then snd (head cs) -- default to first choice on return + else case filter (\(s, _) -> map toLower s == r) cs of + [(_, a)] -> a + _ -> do + putStrLn "Not a valid choice, try again.. (Or ctrl-c to quit)" + prompt p cs + +section :: IO () +section = do + putStrLn "" + putStrLn "---------------------------------------------------------------------------------" + putStrLn "" + +setup :: IO () +setup = do + dotpropellor <- dotPropellor + putStrLn "Propellor's configuration file is ~/.propellor/config.hs" + putStrLn "" + putStrLn "Lets get you started with a simple config that you can adapt" + putStrLn "to your needs. You can start with:" + putStrLn " A: A clone of propellor's git repository (most flexible)" + putStrLn " B: The bare minimum files to use propellor (most simple)" + prompt "Which would you prefer?" + [ ("A", fullClone) + , ("B", minimalConfig) + ] + putStrLn "Ok, ~/.propellor/config.hs is set up!" + changeWorkingDirectory dotpropellor + + section + putStrLn "Let's try building the propellor configuration, to make sure it will work..." + buildPropellor Nothing + putStrLn "Great! Propellor is bootstrapped." + + section + putStrLn "Propellor uses gpg to encrypt private data about the systems it manages," + putStrLn "and to sign git commits." + gpg <- getGpgBin + ifM (inPath gpg) + ( setupGpgKey + , do + putStrLn "You don't seem to have gpg installed, so skipping setting it up." + explainManualSetupGpgKey + ) + + section + putStrLn "Everything is set up ..." + putStrLn "Your next step is to edit ~/.propellor/config.hs," + putStrLn "and run propellor again to try it out." + putStrLn "" + putStrLn "For docs, see https://propellor.branchable.com/" + putStrLn "Enjoy propellor!" + +explainManualSetupGpgKey :: IO () +explainManualSetupGpgKey = do + putStrLn "Propellor can still be used without gpg, but it won't be able to" + putStrLn "manage private data. You can set this up later:" + putStrLn " 1. gpg --gen-key" + putStrLn " 2. propellor --add-key (pass it the key ID generated in step 1)" + +setupGpgKey :: IO () +setupGpgKey = do + ks <- listSecretKeys + putStrLn "" + case ks of + [] -> makeGpgKey + [(k, _)] -> propellorAddKey k + _ -> do + let nks = zip ks (map show ([1..] :: [Integer])) + putStrLn "I see you have several gpg keys:" + forM_ nks $ \((k, d), n) -> + putStrLn $ " " ++ n ++ " " ++ d ++ " (keyid " ++ k ++ ")" + prompt "Which of your gpg keys should propellor use?" + (map (\((k, _), n) -> (n, propellorAddKey k)) nks) + +makeGpgKey :: IO () +makeGpgKey = do + putStrLn "You seem to not have any gpg secret keys." + prompt "Would you like to create one now?" + [("Y", rungpg), ("N", nope)] + where + nope = do + putStrLn "No problem." + explainManualSetupGpgKey + rungpg = do + putStrLn "Running gpg --gen-key ..." + gpg <- getGpgBin + void $ boolSystem gpg [Param "--gen-key"] + ks <- listSecretKeys + case ks of + [] -> do + putStrLn "Hmm, gpg seemed to not set up a secret key." + prompt "Want to try running gpg again?" + [("Y", rungpg), ("N", nope)] + ((k, _):_) -> propellorAddKey k + +propellorAddKey :: String -> IO () +propellorAddKey keyid = do + putStrLn "" + putStrLn $ "Telling propellor to use your gpg key by running: propellor --add-key " ++ keyid + d <- dotPropellor + unlessM (boolSystem (d "propellor") [Param "--add-key", Param keyid]) $ do + putStrLn "Oops, that didn't work! You can retry the same command later." + putStrLn "Continuing onward ..." + +minimalConfig :: IO () +minimalConfig = do + d <- dotPropellor + createDirectoryIfMissing True d + let cabalfile = d "config.cabal" + let configfile = d "config.hs" + writeFile cabalfile (unlines cabalcontent) + writeFile configfile (unlines configcontent) + changeWorkingDirectory d + void $ boolSystem "git" [Param "init"] + void $ boolSystem "git" [Param "add" , File cabalfile, File configfile] + where + cabalcontent = + [ "-- This is a cabal file to use to build your propellor configuration." + , "" + , "Name: config" + , "Cabal-Version: >= 1.6" + , "Build-Type: Simple" + , "Version: 0" + , "" + , "Executable propellor-config" + , " Main-Is: config.hs" + , " GHC-Options: -threaded -Wall -fno-warn-tabs -O0" + , " Extensions: TypeOperators" + , " Build-Depends: propellor >= 3.0, base >= 3" + ] + configcontent = + [ "-- This is the main configuration file for Propellor, and is used to build" + , "-- the propellor program." + , "" + , "import Propellor" + , "import qualified Propellor.Property.File as File" + , "import qualified Propellor.Property.Apt as Apt" + , "import qualified Propellor.Property.Cron as Cron" + , "import qualified Propellor.Property.User as User" + , "" + , "main :: IO ()" + , "main = defaultMain hosts" + , "" + , "-- The hosts propellor knows about." + , "hosts :: [Host]" + , "hosts =" + , " [ mybox" + , " ]" + , "" + , "-- An example host." + , "mybox :: Host" + , "mybox = host \"mybox.example.com\" $ props" + , " & osDebian Unstable \"amd64\"" + , " & Apt.stdSourcesList" + , " & Apt.unattendedUpgrades" + , " & Apt.installed [\"etckeeper\"]" + , " & Apt.installed [\"ssh\"]" + , " & User.hasSomePassword (User \"root\")" + , " & File.dirExists \"/var/www\"" + , " & Cron.runPropellor (Cron.Times \"30 * * * *\")" + , "" + ] + +fullClone :: IO () +fullClone = do + d <- dotPropellor + ifM (doesFileExist distrepo <||> doesDirectoryExist distrepo) + ( do + void $ boolSystem "git" [Param "clone", File distrepo, File d] + fetchUpstreamBranch distrepo + changeWorkingDirectory d + void $ boolSystem "git" [Param "remote", Param "rm", Param "origin"] + , do + void $ boolSystem "git" [Param "clone", Param netrepo, File d] + changeWorkingDirectory d + -- Rename origin to upstream and avoid + -- git push to that read-only repo. + void $ boolSystem "git" [Param "remote", Param "rename", Param "origin", Param "upstream"] + void $ boolSystem "git" [Param "config", Param "--unset", Param "branch.master.remote", Param "upstream"] + ) + +fetchUpstreamBranch :: FilePath -> IO () +fetchUpstreamBranch repo = do + changeWorkingDirectory =<< dotPropellor + void $ boolSystem "git" + [ Param "fetch" + , File repo + , Param ("+refs/heads/master:refs/remotes/" ++ upstreambranch) + , Param "--quiet" + ] + +checkRepoUpToDate :: IO () +checkRepoUpToDate = whenM (gitbundleavail <&&> dotpropellorpopulated) $ do + headrev <- takeWhile (/= '\n') <$> readFile disthead + changeWorkingDirectory =<< dotPropellor + headknown <- catchMaybeIO $ + withQuietOutput createProcessSuccess $ + proc "git" ["log", headrev] + if (headknown == Nothing) + then setupUpstreamMaster headrev + else do + theirhead <- getCurrentGitSha1 =<< getCurrentBranchRef + when (theirhead /= headrev) $ do + merged <- not . null <$> + readProcess "git" ["log", headrev ++ "..HEAD", "--ancestry-path"] + unless merged $ + warnoutofdate True + where + gitbundleavail = doesFileExist disthead + dotpropellorpopulated = do + d <- dotPropellor + doesFileExist (d "propellor.cabal") + +-- Passed the user's dotpropellor repository, makes upstream/master +-- be a usefully mergeable branch. +-- +-- We cannot just use origin/master, because in the case of a distrepo, +-- it only contains 1 commit. So, trying to merge with it will result +-- in lots of merge conflicts, since git cannot find a common parent +-- commit. +-- +-- Instead, the upstream/master branch is created by taking the +-- upstream/master branch (which must be an old version of propellor, +-- as distributed), and diffing from it to the current origin/master, +-- and committing the result. This is done in a temporary clone of the +-- repository, giving it a new master branch. That new branch is fetched +-- into the user's repository, as if fetching from a upstream remote, +-- yielding a new upstream/master branch. +setupUpstreamMaster :: String -> IO () +setupUpstreamMaster newref = do + changeWorkingDirectory =<< dotPropellor + go =<< catchMaybeIO getoldrev + where + go Nothing = warnoutofdate False + go (Just oldref) = do + let tmprepo = ".git/propellordisttmp" + let cleantmprepo = void $ catchMaybeIO $ removeDirectoryRecursive tmprepo + cleantmprepo + git ["clone", "--quiet", ".", tmprepo] + + changeWorkingDirectory tmprepo + git ["fetch", distrepo, "--quiet"] + git ["reset", "--hard", oldref, "--quiet"] + git ["merge", newref, "-s", "recursive", "-Xtheirs", "--quiet", "-m", "merging upstream version"] + + fetchUpstreamBranch tmprepo + cleantmprepo + warnoutofdate True + + getoldrev = takeWhile (/= '\n') + <$> readProcess "git" ["show-ref", upstreambranch, "--hash"] + + git = run "git" + run cmd ps = unlessM (boolSystem cmd (map Param ps)) $ + error $ "Failed to run " ++ cmd ++ " " ++ show ps + +warnoutofdate :: Bool -> IO () +warnoutofdate havebranch = do + warningMessage ("** Your ~/.propellor/ is out of date..") + let also s = hPutStrLn stderr (" " ++ s) + also ("A newer upstream version is available in " ++ distrepo) + if havebranch + then also ("To merge it, run: git merge " ++ upstreambranch) + else also ("To merge it, find the most recent commit in your repository's history that corresponds to an upstream release of propellor, and set refs/remotes/" ++ upstreambranch ++ " to it. Then run propellor again.") + also "" diff --git a/src/Propellor/Types/CmdLine.hs b/src/Propellor/Types/CmdLine.hs index 558c6e8b..0773d9d9 100644 --- a/src/Propellor/Types/CmdLine.hs +++ b/src/Propellor/Types/CmdLine.hs @@ -28,4 +28,5 @@ data CmdLine | ChrootChain HostName FilePath Bool Bool | GitPush Fd Fd | Check + | Init deriving (Read, Show, Eq) diff --git a/src/wrapper.hs b/src/wrapper.hs index 32e036da..1a90fcb0 100644 --- a/src/wrapper.hs +++ b/src/wrapper.hs @@ -9,360 +9,33 @@ module Main where +import Propellor.DotDir import Propellor.Message import Propellor.Bootstrap -import Propellor.Git -import Propellor.Gpg -import Utility.UserInfo import Utility.Monad import Utility.Process -import Utility.SafeCommand -import Utility.Exception -import Utility.Path -import Data.Char -import Data.List -import Control.Monad -import Control.Monad.IfElse import System.Directory -import System.FilePath import System.Environment (getArgs) import System.Exit import System.Posix.Directory -import System.IO -import Control.Applicative -import Prelude - -distdir :: FilePath -distdir = "/usr/src/propellor" - --- A distribution may include a bundle of propellor's git repository here. --- If not, it will be pulled from the network when needed. -distrepo :: FilePath -distrepo = distdir "propellor.git" - --- File containing the head rev of the distrepo. -disthead :: FilePath -disthead = distdir "head" - -upstreambranch :: String -upstreambranch = "upstream/master" - --- Using the github mirror of the main propellor repo because --- it is accessible over https for better security. -netrepo :: String -netrepo = "https://github.com/joeyh/propellor.git" main :: IO () -main = withConcurrentOutput $ do - args <- getArgs - home <- myHomeDir - let dotpropellor = home ".propellor" - ifM (doesDirectoryExist dotpropellor) +main = withConcurrentOutput $ go =<< getArgs + where + go ["--init"] = interactiveInit + go args = ifM (doesDirectoryExist =<< dotPropellor) ( do - checkRepoUpToDate dotpropellor - buildRunConfig dotpropellor args - , do - welcomeBanner - setup dotpropellor + checkRepoUpToDate + buildRunConfig args + , error "Seems that ~/.propellor/ does not exist. To set it up, run: propellor --init" ) -buildRunConfig :: FilePath -> [String] -> IO () -buildRunConfig dotpropellor args = do - changeWorkingDirectory dotpropellor - buildPropellor Nothing - putStrLn "" - putStrLn "" - chain - where - propellorbin = dotpropellor "propellor" - chain = do - (_, _, _, pid) <- createProcess (proc propellorbin args) - exitWith =<< waitForProcess pid - -welcomeBanner :: IO () -welcomeBanner = putStr $ unlines $ map prettify - [ "" - , "" - , " _ ______`| ,-.__" - , " .--------------------------- / ~___-=O`/|O`/__| (____.'" - , " - Welcome to -- ~ / | / ) _.-'-._" - , " - Propellor! -- `/-==__ _/__|/__=-| ( ~_" - , " `--------------------------- * ~ | | '--------'" - , " (o) `" - , "" - , "" - ] - where - prettify = map (replace '~' '\\') - replace x y c - | c == x = y - | otherwise = c - -prompt :: String -> [(String, IO ())] -> IO () -prompt p cs = do - putStr (p ++ " [" ++ intercalate "|" (map fst cs) ++ "] ") - hFlush stdout - r <- map toLower <$> getLine - if null r - then snd (head cs) -- default to first choice on return - else case filter (\(s, _) -> map toLower s == r) cs of - [(_, a)] -> a - _ -> do - putStrLn "Not a valid choice, try again.. (Or ctrl-c to quit)" - prompt p cs - -section :: IO () -section = do - putStrLn "" - putStrLn "---------------------------------------------------------------------------------" - putStrLn "" - -setup :: FilePath -> IO () -setup dotpropellor = do - putStrLn "Propellor's configuration file is ~/.propellor/config.hs" - putStrLn "" - putStrLn "Lets get you started with a simple config that you can adapt" - putStrLn "to your needs. You can start with:" - putStrLn " A: A clone of propellor's git repository (most flexible)" - putStrLn " B: The bare minimum files to use propellor (most simple)" - prompt "Which would you prefer?" - [ ("A", fullClone dotpropellor) - , ("B", minimalConfig dotpropellor) - ] - putStrLn "Ok, ~/.propellor/config.hs is set up!" - changeWorkingDirectory dotpropellor - - section - putStrLn "Let's try building the propellor configuration, to make sure it will work..." +buildRunConfig :: [String] -> IO () +buildRunConfig args = do + changeWorkingDirectory =<< dotPropellor buildPropellor Nothing - putStrLn "Great! Propellor is bootstrapped." - - section - putStrLn "Propellor uses gpg to encrypt private data about the systems it manages," - putStrLn "and to sign git commits." - gpg <- getGpgBin - ifM (inPath gpg) - ( setupGpgKey dotpropellor - , do - putStrLn "You don't seem to have gpg installed, so skipping setting it up." - explainManualSetupGpgKey - ) - - section - putStrLn "Everything is set up ..." - putStrLn "Your next step is to edit ~/.propellor/config.hs," - putStrLn "and run propellor again to try it out." putStrLn "" - putStrLn "For docs, see https://propellor.branchable.com/" - putStrLn "Enjoy propellor!" - -explainManualSetupGpgKey :: IO () -explainManualSetupGpgKey = do - putStrLn "Propellor can still be used without gpg, but it won't be able to" - putStrLn "manage private data. You can set this up later:" - putStrLn " 1. gpg --gen-key" - putStrLn " 2. propellor --add-key (pass it the key ID generated in step 1)" - -setupGpgKey :: FilePath -> IO () -setupGpgKey dotpropellor = do - ks <- listSecretKeys - putStrLn "" - case ks of - [] -> makeGpgKey dotpropellor - [(k, _)] -> propellorAddKey dotpropellor k - _ -> do - let nks = zip ks (map show ([1..] :: [Integer])) - putStrLn "I see you have several gpg keys:" - forM_ nks $ \((k, d), n) -> - putStrLn $ " " ++ n ++ " " ++ d ++ " (keyid " ++ k ++ ")" - prompt "Which of your gpg keys should propellor use?" - (map (\((k, _), n) -> (n, propellorAddKey dotpropellor k)) nks) - -makeGpgKey :: FilePath -> IO () -makeGpgKey dotpropellor = do - putStrLn "You seem to not have any gpg secret keys." - prompt "Would you like to create one now?" - [("Y", rungpg), ("N", nope)] - where - nope = do - putStrLn "No problem." - explainManualSetupGpgKey - rungpg = do - putStrLn "Running gpg --gen-key ..." - gpg <- getGpgBin - void $ boolSystem gpg [Param "--gen-key"] - ks <- listSecretKeys - case ks of - [] -> do - putStrLn "Hmm, gpg seemed to not set up a secret key." - prompt "Want to try running gpg again?" - [("Y", rungpg), ("N", nope)] - ((k, _):_) -> propellorAddKey dotpropellor k - -propellorAddKey :: FilePath -> String -> IO () -propellorAddKey dotpropellor keyid = do putStrLn "" - putStrLn $ "Telling propellor to use your gpg key by running: propellor --add-key " ++ keyid - unlessM (boolSystem propellorbin [Param "--add-key", Param keyid]) $ do - putStrLn "Oops, that didn't work! You can retry the same command later." - putStrLn "Continuing onward ..." - where - propellorbin = dotpropellor "propellor" - -minimalConfig :: FilePath -> IO () -minimalConfig dotpropellor = do - createDirectoryIfMissing True dotpropellor - writeFile cabalfile (unlines cabalcontent) - writeFile configfile (unlines configcontent) - changeWorkingDirectory dotpropellor - void $ boolSystem "git" [Param "init"] - void $ boolSystem "git" [Param "add" , File cabalfile, File configfile] - where - cabalfile = dotpropellor "config.cabal" - configfile = dotpropellor "config.hs" - cabalcontent = - [ "-- This is a cabal file to use to build your propellor configuration." - , "" - , "Name: config" - , "Cabal-Version: >= 1.6" - , "Build-Type: Simple" - , "Version: 0" - , "" - , "Executable propellor-config" - , " Main-Is: config.hs" - , " GHC-Options: -threaded -Wall -fno-warn-tabs -O0" - , " Extensions: TypeOperators" - , " Build-Depends: propellor >= 3.0, base >= 3" - ] - configcontent = - [ "-- This is the main configuration file for Propellor, and is used to build" - , "-- the propellor program." - , "" - , "import Propellor" - , "import qualified Propellor.Property.File as File" - , "import qualified Propellor.Property.Apt as Apt" - , "import qualified Propellor.Property.Cron as Cron" - , "import qualified Propellor.Property.User as User" - , "" - , "main :: IO ()" - , "main = defaultMain hosts" - , "" - , "-- The hosts propellor knows about." - , "hosts :: [Host]" - , "hosts =" - , " [ mybox" - , " ]" - , "" - , "-- An example host." - , "mybox :: Host" - , "mybox = host \"mybox.example.com\" $ props" - , " & osDebian Unstable \"amd64\"" - , " & Apt.stdSourcesList" - , " & Apt.unattendedUpgrades" - , " & Apt.installed [\"etckeeper\"]" - , " & Apt.installed [\"ssh\"]" - , " & User.hasSomePassword (User \"root\")" - , " & File.dirExists \"/var/www\"" - , " & Cron.runPropellor (Cron.Times \"30 * * * *\")" - , "" - ] - -fullClone :: FilePath -> IO () -fullClone dotpropellor = ifM (doesFileExist distrepo <||> doesDirectoryExist distrepo) - ( do - void $ boolSystem "git" [Param "clone", File distrepo, File dotpropellor] - fetchUpstreamBranch dotpropellor distrepo - changeWorkingDirectory dotpropellor - void $ boolSystem "git" [Param "remote", Param "rm", Param "origin"] - , do - void $ boolSystem "git" [Param "clone", Param netrepo, File dotpropellor] - changeWorkingDirectory dotpropellor - -- Rename origin to upstream and avoid - -- git push to that read-only repo. - void $ boolSystem "git" [Param "remote", Param "rename", Param "origin", Param "upstream"] - void $ boolSystem "git" [Param "config", Param "--unset", Param "branch.master.remote", Param "upstream"] - ) - -checkRepoUpToDate :: FilePath -> IO () -checkRepoUpToDate dotpropellor = whenM (gitbundleavail <&&> dotpropellorpopulated) $ do - headrev <- takeWhile (/= '\n') <$> readFile disthead - changeWorkingDirectory dotpropellor - headknown <- catchMaybeIO $ - withQuietOutput createProcessSuccess $ - proc "git" ["log", headrev] - if (headknown == Nothing) - then setupUpstreamMaster headrev dotpropellor - else do - theirhead <- getCurrentGitSha1 =<< getCurrentBranchRef - when (theirhead /= headrev) $ do - merged <- not . null <$> - readProcess "git" ["log", headrev ++ "..HEAD", "--ancestry-path"] - unless merged $ - warnoutofdate dotpropellor True - where - gitbundleavail = doesFileExist disthead - dotpropellorpopulated = doesFileExist (dotpropellor "propellor.cabal") - --- Passed the user's dotpropellor repository, makes upstream/master --- be a usefully mergeable branch. --- --- We cannot just use origin/master, because in the case of a distrepo, --- it only contains 1 commit. So, trying to merge with it will result --- in lots of merge conflicts, since git cannot find a common parent --- commit. --- --- Instead, the upstream/master branch is created by taking the --- upstream/master branch (which must be an old version of propellor, --- as distributed), and diffing from it to the current origin/master, --- and committing the result. This is done in a temporary clone of the --- repository, giving it a new master branch. That new branch is fetched --- into the user's repository, as if fetching from a upstream remote, --- yielding a new upstream/master branch. -setupUpstreamMaster :: String -> FilePath -> IO () -setupUpstreamMaster newref dotpropellor = do - changeWorkingDirectory dotpropellor - go =<< catchMaybeIO getoldrev - where - go Nothing = warnoutofdate dotpropellor False - go (Just oldref) = do - let tmprepo = ".git/propellordisttmp" - let cleantmprepo = void $ catchMaybeIO $ removeDirectoryRecursive tmprepo - cleantmprepo - git ["clone", "--quiet", ".", tmprepo] - - changeWorkingDirectory tmprepo - git ["fetch", distrepo, "--quiet"] - git ["reset", "--hard", oldref, "--quiet"] - git ["merge", newref, "-s", "recursive", "-Xtheirs", "--quiet", "-m", "merging upstream version"] - - fetchUpstreamBranch dotpropellor tmprepo - cleantmprepo - warnoutofdate dotpropellor True - - getoldrev = takeWhile (/= '\n') - <$> readProcess "git" ["show-ref", upstreambranch, "--hash"] - - git = run "git" - run cmd ps = unlessM (boolSystem cmd (map Param ps)) $ - error $ "Failed to run " ++ cmd ++ " " ++ show ps - -warnoutofdate :: FilePath -> Bool -> IO () -warnoutofdate dotpropellor havebranch = do - warningMessage ("** Your " ++ dotpropellor ++ " is out of date..") - let also s = hPutStrLn stderr (" " ++ s) - also ("A newer upstream version is available in " ++ distrepo) - if havebranch - then also ("To merge it, run: git merge " ++ upstreambranch) - else also ("To merge it, find the most recent commit in your repository's history that corresponds to an upstream release of propellor, and set refs/remotes/" ++ upstreambranch ++ " to it. Then run propellor again.") - also "" - -fetchUpstreamBranch :: FilePath -> FilePath -> IO () -fetchUpstreamBranch dotpropellor repo = do - changeWorkingDirectory dotpropellor - void $ boolSystem "git" - [ Param "fetch" - , File repo - , Param ("+refs/heads/master:refs/remotes/" ++ upstreambranch) - , Param "--quiet" - ] + (_, _, _, pid) <- createProcess (proc "./propellor" args) + exitWith =<< waitForProcess pid -- cgit v1.3-2-g0d8e From e3920861ee444945e54fd42ce0f599d585155652 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 2 Apr 2016 01:29:23 -0400 Subject: Stack support. * Stack support. "git config propellor.buildsystem stack" will make propellor build its config using stack. * When propellor is installed using stack, propellor --init will automatically set propellor.buildsystem=stack. --- Makefile | 1 + debian/changelog | 4 ++ ...use___96__GHC__95__PACKAGE__95__PATH__96__.mdwn | 6 +++ propellor.cabal | 6 +++ src/Propellor/Bootstrap.hs | 54 ++++++++++++++++++---- src/Propellor/DotDir.hs | 47 +++++++++++++++---- stack.yaml | 6 +++ 7 files changed, 107 insertions(+), 17 deletions(-) create mode 100644 stack.yaml (limited to 'propellor.cabal') diff --git a/Makefile b/Makefile index a9ad2b84..5322d6c5 100644 --- a/Makefile +++ b/Makefile @@ -16,6 +16,7 @@ install: mkdir -p dist/gittmp $(CABAL) sdist cat dist/propellor-*.tar.gz | (cd dist/gittmp && tar zx --strip-components=1) + cp stack.yaml dist/gittmp # also include in bundle # cabal sdist does not preserve symlinks, so copy over file cd dist/gittmp && for f in $$(find -type f); do rm -f $$f; cp -a ../../$$f $$f; done # reset mtime on files in git bundle so bundle is reproducible diff --git a/debian/changelog b/debian/changelog index ae593902..aab077b0 100644 --- a/debian/changelog +++ b/debian/changelog @@ -68,6 +68,10 @@ propellor (3.0.0) UNRELEASED; urgency=medium walk the user through setting up ~/.propellor, with a choice between a clone of propellor's git repository, or a minimal config, and will configure propellor to use a gpg key. + * Stack support. "git config propellor.buildsystem stack" will make + propellor build its config using stack. + * When propellor is installed using stack, propellor --init will + automatically set propellor.buildsystem=stack. -- Joey Hess Wed, 30 Mar 2016 15:45:08 -0400 diff --git a/doc/todo/detect_and_use___96__GHC__95__PACKAGE__95__PATH__96__.mdwn b/doc/todo/detect_and_use___96__GHC__95__PACKAGE__95__PATH__96__.mdwn index 2973e662..55c3ef7e 100644 --- a/doc/todo/detect_and_use___96__GHC__95__PACKAGE__95__PATH__96__.mdwn +++ b/doc/todo/detect_and_use___96__GHC__95__PACKAGE__95__PATH__96__.mdwn @@ -7,3 +7,9 @@ and run with stack exec -- propellor ... see [[https://github.com/yesodweb/yesod/issues/1018]] and [[https://github.com/yesodweb/yesod/commit/a7cccf2a7c5df8b26da9ea4fdcb6bac5ab3a3b75]] + +> I don't think `stack exec propellor` makes sense to use. +> Instead, `stack install propellor` and then put that in PATH. +> I've now made `propellor --init` know when it was built using stack, +> and it will set up propellor to continue to build itself using stack. +> [[done]] --[[Joey]] diff --git a/propellor.cabal b/propellor.cabal index d97d4096..3431d410 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -34,6 +34,10 @@ Description: . It is configured using haskell. +Flag UseStack + Description: Have propellor rebuild itself using Stack (default is Cabal) + Default: False + Executable propellor Main-Is: wrapper.hs GHC-Options: -threaded -Wall -fno-warn-tabs -O0 @@ -46,6 +50,8 @@ Executable propellor unix, unix-compat, ansi-terminal, containers (>= 0.5), network, async, time, mtl, transformers, exceptions (>= 0.6), stm, text, concurrent-output + if flag(UseStack) + CPP-Options: -DUSE_STACK Executable propellor-config Main-Is: config.hs diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs index 969e1a42..300be156 100644 --- a/src/Propellor/Bootstrap.hs +++ b/src/Propellor/Bootstrap.hs @@ -7,6 +7,7 @@ module Propellor.Bootstrap ( import Propellor.Base import Propellor.Types.Info +import Propellor.Git.Config import System.Posix.Files import Data.List @@ -139,16 +140,22 @@ buildPropellor mh = unlessM (actionMessage "Propellor build" (build msys)) $ Just (InfoVal sys) -> Just sys _ -> Nothing --- Build propellor using cabal, and symlink propellor to where cabal --- leaves the built binary. --- +-- Build propellor using cabal or stack, and symlink propellor to the +-- built binary. +build :: Maybe System -> IO Bool +build msys = catchBoolIO $ do + bs <- getGitConfigValue "propellor.buildsystem" + case bs of + Just "stack" -> stackBuild msys + _ -> cabalBuild msys + -- For speed, only runs cabal configure when it's not been run before. -- If the build fails cabal may need to have configure re-run. -- -- If the cabal configure fails, and a System is provided, installs -- dependencies and retries. -build :: Maybe System -> IO Bool -build msys = catchBoolIO $ do +cabalBuild :: Maybe System -> IO Bool +cabalBuild msys = do make "dist/setup-config" ["propellor.cabal"] cabal_configure unlessM cabal_build $ unlessM (cabal_configure <&&> cabal_build) $ @@ -163,14 +170,11 @@ build msys = catchBoolIO $ do unlessM (boolSystem "cp" [Param "-af", Param cabalbuiltbin, Param (tmpfor safetycopy)]) $ error "cp of binary failed" rename (tmpfor safetycopy) safetycopy - createSymbolicLink safetycopy (tmpfor dest) - rename (tmpfor dest) dest + symlinkPropellorBin safetycopy return True where - dest = "propellor" cabalbuiltbin = "dist/build/propellor-config/propellor-config" safetycopy = cabalbuiltbin ++ ".built" - tmpfor f = f ++ ".propellortmp" cabal_configure = ifM (cabal ["configure"]) ( return True , case msys of @@ -181,6 +185,35 @@ build msys = catchBoolIO $ do ) cabal_build = cabal ["build", "propellor-config"] +stackBuild :: Maybe System -> IO Bool +stackBuild _msys = do + createDirectoryIfMissing True builddest + ifM (stack buildparams) + ( do + symlinkPropellorBin (builddest "propellor-config") + return True + , return False + ) + where + builddest = ".built" + buildparams = + [ "--local-bin-path", builddest + , "build" + , ":propellor-config" -- only build config program + , "--copy-bins" + ] + +-- Atomic symlink creation/update. +symlinkPropellorBin :: FilePath -> IO () +symlinkPropellorBin bin = do + createSymbolicLink bin (tmpfor dest) + rename (tmpfor dest) dest + where + dest = "propellor" + +tmpfor :: FilePath -> FilePath +tmpfor f = f ++ ".propellortmp" + make :: FilePath -> [FilePath] -> IO Bool -> IO () make dest srcs builder = do dt <- getmtime dest @@ -193,3 +226,6 @@ make dest srcs builder = do cabal :: [String] -> IO Bool cabal = boolSystem "cabal" . map Param + +stack :: [String] -> IO Bool +stack = boolSystem "stack" . map Param diff --git a/src/Propellor/DotDir.hs b/src/Propellor/DotDir.hs index f0dace2f..90147abe 100644 --- a/src/Propellor/DotDir.hs +++ b/src/Propellor/DotDir.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + module Propellor.DotDir where import Propellor.Message @@ -11,9 +13,12 @@ import Utility.Process import Utility.SafeCommand import Utility.Exception import Utility.Path +-- This module is autogenerated by the build system. +import qualified Paths_propellor as Package import Data.Char import Data.List +import Data.Version import Control.Monad import Control.Monad.IfElse import System.Directory @@ -48,6 +53,15 @@ dotPropellor = do home <- myHomeDir return (home ".propellor") +data InitCfg = UseCabal | UseStack + +initCfg :: InitCfg +#ifdef USE_STACK +initCfg = UseStack +#else +initCfg = UseCabal +#endif + interactiveInit :: IO () interactiveInit = ifM (doesDirectoryExist =<< dotPropellor) ( error "~/.propellor/ already exists, not doing anything" @@ -95,7 +109,7 @@ section = do putStrLn "" setup :: IO () -setup = do +setup initcfg = do putStrLn "Propellor's configuration file is ~/.propellor/config.hs" putStrLn "" putStrLn "Lets get you started with a simple config that you can adapt" @@ -103,14 +117,21 @@ setup = do putStrLn " A: A clone of propellor's git repository (most flexible)" putStrLn " B: The bare minimum files to use propellor (most simple)" prompt "Which would you prefer?" - [ ("A", actionMessage "Cloning propellor's git repository" fullClone >> return ()) - , ("B", actionMessage "Creating minimal config" minimalConfig >> return ()) + [ ("A", void $ actionMessage "Cloning propellor's git repository" fullClone) + , ("B", void $ actionMessage "Creating minimal config" minimalConfig) ] changeWorkingDirectory =<< dotPropellor section putStrLn "Let's try building the propellor configuration, to make sure it will work..." putStrLn "" + void $ boolSystem "git" + [ Param "config" + , Param "propellor.buildsystem" + , Param $ case initCfg of + UseCabal -> "cabal" + UseStack -> "stack" + ] buildPropellor Nothing putStrLn "" putStrLn "Great! Propellor is bootstrapped." @@ -197,15 +218,16 @@ minimalConfig :: IO Result minimalConfig = do d <- dotPropellor createDirectoryIfMissing True d - let cabalfile = d "config.cabal" - let configfile = d "config.hs" - writeFile cabalfile (unlines cabalcontent) - writeFile configfile (unlines configcontent) changeWorkingDirectory d void $ boolSystem "git" [Param "init"] - void $ boolSystem "git" [Param "add" , File cabalfile, File configfile] + addfile "config.cabal" cabalcontent + addfile "config.hs" configcontent + addfile "stack.yaml" stackcontent return MadeChange where + addfile f content = do + writeFile f (unlines content) + void $ boolSystem "git" [Param "add" , File f] cabalcontent = [ "-- This is a cabal file to use to build your propellor configuration." , "" @@ -252,6 +274,15 @@ minimalConfig = do , " & Cron.runPropellor (Cron.Times \"30 * * * *\")" , "" ] + stackcontent = + -- This should be the same resolver version in propellor's + -- own stack.yaml + [ "resolver: lts-5.10" + , "packages:" + , "- '.'" + , "extra-deps:" + , "- propellor-" ++ showVersion Package.version + ] fullClone :: IO Result fullClone = do diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 00000000..6b5e859c --- /dev/null +++ b/stack.yaml @@ -0,0 +1,6 @@ +resolver: lts-5.10 +packages: +- '.' +flags: + propellor: + usestack: true -- cgit v1.3-2-g0d8e From ecf786ddab0161a4f5fa84e07cced60efb1595cd Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 2 Apr 2016 12:05:07 -0400 Subject: got rid of build flag to detect stack --- propellor.cabal | 6 ------ src/Propellor/DotDir.hs | 20 +++++++------------- stack.yaml | 3 --- 3 files changed, 7 insertions(+), 22 deletions(-) (limited to 'propellor.cabal') diff --git a/propellor.cabal b/propellor.cabal index 3431d410..d97d4096 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -34,10 +34,6 @@ Description: . It is configured using haskell. -Flag UseStack - Description: Have propellor rebuild itself using Stack (default is Cabal) - Default: False - Executable propellor Main-Is: wrapper.hs GHC-Options: -threaded -Wall -fno-warn-tabs -O0 @@ -50,8 +46,6 @@ Executable propellor unix, unix-compat, ansi-terminal, containers (>= 0.5), network, async, time, mtl, transformers, exceptions (>= 0.6), stm, text, concurrent-output - if flag(UseStack) - CPP-Options: -DUSE_STACK Executable propellor-config Main-Is: config.hs diff --git a/src/Propellor/DotDir.hs b/src/Propellor/DotDir.hs index 43067417..21479cb1 100644 --- a/src/Propellor/DotDir.hs +++ b/src/Propellor/DotDir.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE CPP #-} - module Propellor.DotDir where import Propellor.Message @@ -53,14 +51,11 @@ dotPropellor = do home <- myHomeDir return (home ".propellor") -data InitCfg = UseCabal | UseStack - -initCfg :: InitCfg -#ifdef USE_STACK -initCfg = UseStack -#else -initCfg = UseCabal -#endif +-- Detect if propellor was built using stack. This is somewhat of a hack. +buildSystem :: IO String +buildSystem = do + d <- Package.getLibDir + return $ if "stack-work" `isInfixOf` d then "stack" else "cabal" interactiveInit :: IO () interactiveInit = ifM (doesDirectoryExist =<< dotPropellor) @@ -125,12 +120,11 @@ setup = do section putStrLn "Let's try building the propellor configuration, to make sure it will work..." putStrLn "" + b <- buildSystem void $ boolSystem "git" [ Param "config" , Param "propellor.buildsystem" - , Param $ case initCfg of - UseCabal -> "cabal" - UseStack -> "stack" + , Param b ] buildPropellor Nothing putStrLn "" diff --git a/stack.yaml b/stack.yaml index 6b5e859c..7b6bcef8 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,6 +1,3 @@ resolver: lts-5.10 packages: - '.' -flags: - propellor: - usestack: true -- cgit v1.3-2-g0d8e From 1c5da932e9e356c2fbad22dcb97e1ea8943407cd Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 2 Apr 2016 12:07:40 -0400 Subject: include stack.yaml in sdist --- Makefile | 1 - propellor.cabal | 1 + 2 files changed, 1 insertion(+), 1 deletion(-) (limited to 'propellor.cabal') diff --git a/Makefile b/Makefile index 5322d6c5..a9ad2b84 100644 --- a/Makefile +++ b/Makefile @@ -16,7 +16,6 @@ install: mkdir -p dist/gittmp $(CABAL) sdist cat dist/propellor-*.tar.gz | (cd dist/gittmp && tar zx --strip-components=1) - cp stack.yaml dist/gittmp # also include in bundle # cabal sdist does not preserve symlinks, so copy over file cd dist/gittmp && for f in $$(find -type f); do rm -f $$f; cp -a ../../$$f $$f; done # reset mtime on files in git bundle so bundle is reproducible diff --git a/propellor.cabal b/propellor.cabal index d97d4096..4017df87 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -20,6 +20,7 @@ Extra-Source-Files: joeyconfig.hs config.hs contrib/post-merge-hook + stack.yaml debian/changelog debian/README.Debian debian/compat -- cgit v1.3-2-g0d8e