From c012af576a6c55e03447cfb6ed3b047a623c0944 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 24 Mar 2016 16:57:21 -0400 Subject: partially converted; a few things commented out for now --- src/Propellor/Property.hs | 21 ++++++++------------- 1 file changed, 8 insertions(+), 13 deletions(-) (limited to 'src/Propellor/Property.hs') diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs index b6b8dc0d..e5ccf9b1 100644 --- a/src/Propellor/Property.hs +++ b/src/Propellor/Property.hs @@ -18,8 +18,8 @@ module Propellor.Property ( -- * Constructing properties , Propellor , property - , ensureProperty - , withOS + --, ensureProperty + --, withOS , unsupportedOS , makeChange , noChange @@ -55,11 +55,6 @@ import Utility.Exception import Utility.Monad import Utility.Misc --- | Constructs a Property, from a description and an action to run to --- ensure the Property is met. -property :: Desc -> Propellor Result -> Property NoInfo -property d s = simpleProperty d s mempty - -- | Makes a perhaps non-idempotent Property be idempotent by using a flag -- file to indicate whether it has run before. -- Use with caution. @@ -168,8 +163,8 @@ infixl 1 ==> -- Property. -- -- This can only be used on a Property that has NoInfo. -ensureProperty :: Property NoInfo -> Propellor Result -ensureProperty = catchPropellor . propertySatisfy +--ensureProperty :: Property NoInfo -> Propellor Result +--ensureProperty = catchPropellor . propertySatisfy -- | Tries the first property, but if it fails to work, instead uses -- the second. @@ -258,8 +253,8 @@ isNewerThan x y = do -- > (Just (System (Debian suite) arch)) -> ... -- > (Just (System (Buntish release) arch)) -> ... -- > Nothing -> unsupportedOS -withOS :: Desc -> (Maybe System -> Propellor Result) -> Property NoInfo -withOS desc a = property desc $ a =<< getOS +--withOS :: Desc -> (Maybe System -> Propellor Result) -> Property NoInfo +--withOS desc a = property desc $ a =<< getOS -- | Throws an error, for use in `withOS` when a property is lacking -- support for an OS. @@ -270,7 +265,7 @@ unsupportedOS = go =<< getOS go (Just o) = error $ "This property is not implemented for " ++ show o -- | Undoes the effect of a RevertableProperty. -revert :: RevertableProperty i -> RevertableProperty i +revert :: RevertableProperty setup undo -> RevertableProperty undo setup revert (RevertableProperty p1 p2) = RevertableProperty p2 p1 makeChange :: IO () -> Propellor Result @@ -279,7 +274,7 @@ makeChange a = liftIO a >> return MadeChange noChange :: Propellor Result noChange = return NoChange -doNothing :: Property NoInfo +doNothing :: Property UnixLike doNothing = property "noop property" noChange -- | Registers an action that should be run at the very end, after -- cgit v1.2.3 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 'src/Propellor/Property.hs') 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.2.3 From e3a44ab5825466f9db9c4749497445bd0af1068e Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 24 Mar 2016 20:20:34 -0400 Subject: add tightenTargets, ported Network properties (DebinLike only) --- debian/changelog | 6 +++++ src/Propellor/Property.hs | 47 +++++++++++++++++++++++++++++++++++++++ src/Propellor/Property/Network.hs | 39 ++++++++++++++++++-------------- 3 files changed, 75 insertions(+), 17 deletions(-) (limited to 'src/Propellor/Property.hs') diff --git a/debian/changelog b/debian/changelog index 323394f9..ead6585e 100644 --- a/debian/changelog +++ b/debian/changelog @@ -23,6 +23,12 @@ propellor (3.0.0) UNRELEASED; urgency=medium of `ensureProperty` for an example, but basically, change this: foo = property desc $ ... ensureProperty bar to this: foo = property' desc $ \o -> ... ensureProperty o 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 targets to only the OS that your more specific + property works on. For example: + upgraded :: Property Debian + upgraded = tightenTargets (cmdProperty "apt-get" ["upgrade"]) - 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/src/Propellor/Property.hs b/src/Propellor/Property.hs index 27d17135..cab233d0 100644 --- a/src/Propellor/Property.hs +++ b/src/Propellor/Property.hs @@ -1,5 +1,8 @@ {-# LANGUAGE PackageImports #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PolyKinds #-} module Propellor.Property ( -- * Property combinators @@ -20,6 +23,7 @@ module Propellor.Property ( , property , property' , ensureProperty + , tightenTargets --, withOS , unsupportedOS , makeChange @@ -240,6 +244,49 @@ isNewerThan x y = do where mtime f = catchMaybeIO $ modificationTimeHiRes <$> getFileStatus f +-- | Tightens the MetaType list of a Property, to contain fewer targets. +-- +-- Anything else in the MetaType list is passed through unchanged. +-- +-- For example, to make a property that uses apt-get, which is only +-- available on DebianLike systems: +-- +-- > upgraded :: Property DebianLike +-- > upgraded = tightenTargets $ cmdProperty "apt-get" ["upgrade"] +tightenTargets + :: + -- Note that this uses PolyKinds + ( (Targets old `NotSuperset` Targets new) ~ CanCombineTargets + , (NonTargets new `NotSuperset` NonTargets old) ~ CanCombineTargets + , SingI new + ) + => Property (Sing old) + -> Property (Sing new) +tightenTargets (Property old d a i c) = Property sing d a i c + +{- + +-- | 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 + , SingI combined + ) + => Property (Sing a) + -> Property (Sing b) + -> Property (Sing 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 + +-} + -- | Makes a property that is satisfied differently depending on the host's -- operating system. -- diff --git a/src/Propellor/Property/Network.hs b/src/Propellor/Property/Network.hs index 382f5d9d..46f5cef3 100644 --- a/src/Propellor/Property/Network.hs +++ b/src/Propellor/Property/Network.hs @@ -2,13 +2,14 @@ module Propellor.Property.Network where import Propellor.Base import Propellor.Property.File +import Propellor.Types.MetaTypes import Data.Char type Interface = String -ifUp :: Interface -> Property NoInfo -ifUp iface = cmdProperty "ifup" [iface] +ifUp :: Interface -> Property DebianLike +ifUp iface = tightenTargets $ cmdProperty "ifup" [iface] `assume` MadeChange -- | Resets /etc/network/interfaces to a clean and empty state, @@ -18,8 +19,8 @@ ifUp iface = cmdProperty "ifup" [iface] -- This can be used as a starting point to defining other interfaces. -- -- No interfaces are brought up or down by this property. -cleanInterfacesFile :: Property NoInfo -cleanInterfacesFile = hasContent interfacesFile +cleanInterfacesFile :: Property DebianLike +cleanInterfacesFile = tightenTargets $ hasContent interfacesFile [ "# Deployed by propellor, do not edit." , "" , "source-directory interfaces.d" @@ -31,8 +32,8 @@ cleanInterfacesFile = hasContent interfacesFile `describe` ("clean " ++ interfacesFile) -- | Configures an interface to get its address via dhcp. -dhcp :: Interface -> Property NoInfo -dhcp iface = hasContent (interfaceDFile iface) +dhcp :: Interface -> Property DebianLike +dhcp iface = tightenTargets $ hasContent (interfaceDFile iface) [ "auto " ++ iface , "iface " ++ iface ++ " inet dhcp" ] @@ -50,18 +51,20 @@ dhcp iface = hasContent (interfaceDFile iface) -- -- (ipv6 addresses are not included because it's assumed they come up -- automatically in most situations.) -static :: Interface -> Property NoInfo -static iface = check (not <$> doesFileExist f) setup - `describe` desc - `requires` interfacesDEnabled +static :: Interface -> Property DebianLike +static iface = tightenTargets $ + check (not <$> doesFileExist f) setup + `describe` desc + `requires` interfacesDEnabled where f = interfaceDFile iface desc = "static " ++ iface - setup = property desc $ do + setup :: Property DebianLike + setup = property' desc $ \o -> do ls <- liftIO $ lines <$> readProcess "ip" ["-o", "addr", "show", iface, "scope", "global"] stanzas <- liftIO $ concat <$> mapM mkstanza ls - ensureProperty $ hasContent f $ ("auto " ++ iface) : stanzas + ensureProperty o $ hasContent f $ ("auto " ++ iface) : stanzas mkstanza ipline = case words ipline of -- Note that the IP address is written CIDR style, so -- the netmask does not need to be specified separately. @@ -81,8 +84,8 @@ static iface = check (not <$> doesFileExist f) setup _ -> Nothing -- | 6to4 ipv6 connection, should work anywhere -ipv6to4 :: Property NoInfo -ipv6to4 = hasContent (interfaceDFile "sit0") +ipv6to4 :: Property DebianLike +ipv6to4 = tightenTargets $ hasContent (interfaceDFile "sit0") [ "# Deployed by propellor, do not edit." , "iface sit0 inet6 static" , "\taddress 2002:5044:5531::1" @@ -107,6 +110,8 @@ escapeInterfaceDName :: Interface -> FilePath escapeInterfaceDName = filter (\c -> isAscii c && (isAlphaNum c || c `elem` "_-")) -- | Ensures that files in the the interfaces.d directory are used. -interfacesDEnabled :: Property NoInfo -interfacesDEnabled = containsLine interfacesFile "source-directory interfaces.d" - `describe` "interfaces.d directory enabled" +-- interfacesDEnabled :: Property DebianLike +interfacesDEnabled :: Property DebianLike +interfacesDEnabled = tightenTargets $ + containsLine interfacesFile "source-directory interfaces.d" + `describe` "interfaces.d directory enabled" -- cgit v1.2.3 From 2506453874aa30968d8533a603d295ac248273c5 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 25 Mar 2016 02:00:23 -0400 Subject: add type alias for Sing to be less confusing for users --- src/Propellor/EnsureProperty.hs | 8 ++++---- src/Propellor/Property.hs | 10 +++++----- src/Propellor/Types.hs | 26 +++++++++++++------------- src/Propellor/Types/MetaTypes.hs | 16 +++++++++------- 4 files changed, 31 insertions(+), 29 deletions(-) (limited to 'src/Propellor/Property.hs') diff --git a/src/Propellor/EnsureProperty.hs b/src/Propellor/EnsureProperty.hs index 00495f87..f3e79ae5 100644 --- a/src/Propellor/EnsureProperty.hs +++ b/src/Propellor/EnsureProperty.hs @@ -37,7 +37,7 @@ ensureProperty , CannotUse_ensureProperty_WithInfo inner ~ 'True ) => OuterMetaTypes outer - -> Property (Sing inner) + -> Property (MetaTypes inner) -> Propellor Result ensureProperty _ = catchPropellor . propertySatisfy @@ -53,14 +53,14 @@ property' :: SingI metatypes => Desc -> (OuterMetaTypes metatypes -> Propellor Result) - -> Property (Sing metatypes) + -> Property (MetaTypes 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) +newtype OuterMetaTypes metatypes = OuterMetaTypes (MetaTypes metatypes) -outerMetaTypes :: Property (Sing l) -> OuterMetaTypes l +outerMetaTypes :: Property (MetaTypes l) -> OuterMetaTypes l outerMetaTypes (Property metatypes _ _ _ _) = OuterMetaTypes metatypes diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs index cab233d0..c665b6a0 100644 --- a/src/Propellor/Property.hs +++ b/src/Propellor/Property.hs @@ -260,8 +260,8 @@ tightenTargets , (NonTargets new `NotSuperset` NonTargets old) ~ CanCombineTargets , SingI new ) - => Property (Sing old) - -> Property (Sing new) + => Property (MetaTypes old) + -> Property (MetaTypes new) tightenTargets (Property old d a i c) = Property sing d a i c {- @@ -276,9 +276,9 @@ pickOS ( combined ~ Union a b , SingI combined ) - => Property (Sing a) - -> Property (Sing b) - -> Property (Sing combined) + => Property (MetaTypes a) + -> Property (MetaTypes b) + -> Property (MetaTypes 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 diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs index 3cd5a368..f23a18dd 100644 --- a/src/Propellor/Types.hs +++ b/src/Propellor/Types.hs @@ -41,7 +41,7 @@ module Propellor.Types , module Propellor.Types.Result , module Propellor.Types.ZFS , propertySatisfy - , Sing + , MetaTypes ) where import Data.Monoid @@ -142,17 +142,17 @@ property :: SingI metatypes => Desc -> Propellor Result - -> Property (Sing metatypes) + -> 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 - :: (Sing metatypes' ~ (+) HasInfo metatypes, SingI metatypes') + :: (MetaTypes metatypes' ~ (+) HasInfo metatypes, SingI metatypes') => Property metatypes -> Info - -> Property (Sing metatypes') + -> Property (MetaTypes metatypes') addInfoProperty (Property metatypes d a oldi c) newi = Property sing d a (oldi <> newi) c @@ -163,7 +163,7 @@ addInfoProperty (Property metatypes d a oldi c) newi = ignoreInfo :: (metatypes' ~ => Property metatypes - -> Property (Sing metatypes') + -> Property (MetaTypes metatypes') ignoreInfo = -} @@ -245,12 +245,12 @@ instance IsProp (RevertableProperty setupmetatypes undometatypes) where -- | Type level calculation of the type that results from combining two -- types of properties. type family CombinedType x y -type instance CombinedType (Property (Sing x)) (Property (Sing y)) = Property (Sing (Combine x y)) -type instance CombinedType (RevertableProperty (Sing x) (Sing x')) (RevertableProperty (Sing y) (Sing y')) = RevertableProperty (Sing (Combine x y)) (Sing (Combine x' y')) +type instance CombinedType (Property (MetaTypes x)) (Property (MetaTypes y)) = Property (MetaTypes (Combine x y)) +type instance CombinedType (RevertableProperty (MetaTypes x) (MetaTypes x')) (RevertableProperty (MetaTypes y) (MetaTypes y')) = RevertableProperty (MetaTypes (Combine x y)) (MetaTypes (Combine 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 (Sing x) (Sing x')) (Property (Sing y)) = Property (Sing (Combine x y)) -type instance CombinedType (Property (Sing x)) (RevertableProperty (Sing y) (Sing y')) = Property (Sing (Combine x y)) +type instance CombinedType (RevertableProperty (MetaTypes x) (MetaTypes x')) (Property (MetaTypes y)) = Property (MetaTypes (Combine x y)) +type instance CombinedType (Property (MetaTypes x)) (RevertableProperty (MetaTypes y) (MetaTypes y')) = Property (MetaTypes (Combine x y)) type ResultCombiner = Propellor Result -> Propellor Result -> Propellor Result @@ -268,15 +268,15 @@ class Combines x y where -> y -> CombinedType x y -instance (CannotCombineTargets x y (Combine x y) ~ 'CanCombineTargets, SingI (Combine x y)) => Combines (Property (Sing x)) (Property (Sing y)) where +instance (CannotCombineTargets x y (Combine x y) ~ 'CanCombineTargets, SingI (Combine x y)) => Combines (Property (MetaTypes x)) (Property (MetaTypes 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 (CannotCombineTargets x y (Combine x y) ~ 'CanCombineTargets, CannotCombineTargets x' y' (Combine x' y') ~ 'CanCombineTargets, SingI (Combine x y), SingI (Combine x' y')) => Combines (RevertableProperty (Sing x) (Sing x')) (RevertableProperty (Sing y) (Sing y')) where +instance (CannotCombineTargets x y (Combine x y) ~ 'CanCombineTargets, CannotCombineTargets x' y' (Combine x' y') ~ 'CanCombineTargets, SingI (Combine x y), SingI (Combine x' y')) => Combines (RevertableProperty (MetaTypes x) (MetaTypes x')) (RevertableProperty (MetaTypes y) (MetaTypes y')) where combineWith sf tf (RevertableProperty s1 t1) (RevertableProperty s2 t2) = RevertableProperty (combineWith sf tf s1 s2) (combineWith tf sf t1 t2) -instance (CannotCombineTargets x y (Combine x y) ~ 'CanCombineTargets, SingI (Combine x y)) => Combines (RevertableProperty (Sing x) (Sing x')) (Property (Sing y)) where +instance (CannotCombineTargets x y (Combine x y) ~ 'CanCombineTargets, SingI (Combine x y)) => Combines (RevertableProperty (MetaTypes x) (MetaTypes x')) (Property (MetaTypes y)) where combineWith sf tf (RevertableProperty x _) y = combineWith sf tf x y -instance (CannotCombineTargets x y (Combine x y) ~ 'CanCombineTargets, SingI (Combine x y)) => Combines (Property (Sing x)) (RevertableProperty (Sing y) (Sing y')) where +instance (CannotCombineTargets x y (Combine x y) ~ 'CanCombineTargets, SingI (Combine x y)) => Combines (Property (MetaTypes x)) (RevertableProperty (MetaTypes y) (MetaTypes 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 6edea291..7dafe422 100644 --- a/src/Propellor/Types/MetaTypes.hs +++ b/src/Propellor/Types/MetaTypes.hs @@ -10,7 +10,7 @@ module Propellor.Types.MetaTypes ( FreeBSD, HasInfo, type (+), - Sing, + MetaTypes, sing, SingI, IncludesInfo, @@ -36,15 +36,17 @@ data OS deriving (Show, Eq) -- | Any unix-like system -type UnixLike = Sing '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish, 'Targeting 'OSFreeBSD ] -type Debian = Sing '[ 'Targeting 'OSDebian ] +type UnixLike = MetaTypes '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish, 'Targeting 'OSFreeBSD ] +type Debian = MetaTypes '[ 'Targeting 'OSDebian ] +type Buntish = MetaTypes '[ 'Targeting 'OSBuntish ] +type FreeBSD = MetaTypes '[ 'Targeting 'OSFreeBSD ] -- | Debian and derivatives. -type DebianLike = Sing '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish ] -type Buntish = Sing '[ 'Targeting 'OSBuntish ] -type FreeBSD = Sing '[ 'Targeting 'OSFreeBSD ] +type DebianLike = Debian + Buntish -- | Used to indicate that a Property adds Info to the Host where it's used. -type HasInfo = Sing '[ 'WithInfo ] +type HasInfo = MetaTypes '[ 'WithInfo ] + +type MetaTypes = Sing -- | The data family of singleton types. data family Sing (x :: k) -- cgit v1.2.3 From 5d2d64678f506d23bdfddb3f7cc452ac1d7c42eb Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 25 Mar 2016 02:05:26 -0400 Subject: fix warnings --- src/Propellor/PrivData.hs | 6 +++--- src/Propellor/Property.hs | 7 +++---- src/Propellor/Types.hs | 5 +++-- 3 files changed, 9 insertions(+), 9 deletions(-) (limited to 'src/Propellor/Property.hs') diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs index 6f3d4771..bc61c538 100644 --- a/src/Propellor/PrivData.hs +++ b/src/Propellor/PrivData.hs @@ -81,7 +81,7 @@ withPrivData :: ( IsContext c , IsPrivDataSource s - , IncludesInfo metatypes ~ True + , IncludesInfo metatypes ~ 'True ) => s -> c @@ -94,7 +94,7 @@ withSomePrivData :: ( IsContext c , IsPrivDataSource s - , IncludesInfo metatypes ~ True + , IncludesInfo metatypes ~ 'True ) => [s] -> c @@ -106,7 +106,7 @@ withPrivData' :: ( IsContext c , IsPrivDataSource s - , IncludesInfo metatypes ~ True + , IncludesInfo metatypes ~ 'True ) => ((PrivDataField, PrivData) -> v) -> [s] diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs index c665b6a0..582b7cfb 100644 --- a/src/Propellor/Property.hs +++ b/src/Propellor/Property.hs @@ -56,7 +56,6 @@ 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 @@ -256,13 +255,13 @@ isNewerThan x y = do tightenTargets :: -- Note that this uses PolyKinds - ( (Targets old `NotSuperset` Targets new) ~ CanCombineTargets - , (NonTargets new `NotSuperset` NonTargets old) ~ CanCombineTargets + ( (Targets old `NotSuperset` Targets new) ~ 'CanCombineTargets + , (NonTargets new `NotSuperset` NonTargets old) ~ 'CanCombineTargets , SingI new ) => Property (MetaTypes old) -> Property (MetaTypes new) -tightenTargets (Property old d a i c) = Property sing d a i c +tightenTargets (Property _old d a i c) = Property sing d a i c {- diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs index f23a18dd..23716e58 100644 --- a/src/Propellor/Types.hs +++ b/src/Propellor/Types.hs @@ -28,6 +28,7 @@ module Propellor.Types , propertyDesc , propertyChildren , RevertableProperty(..) + , () , ChildProperty , IsProp(..) , Combines(..) @@ -153,7 +154,7 @@ addInfoProperty => Property metatypes -> Info -> Property (MetaTypes metatypes') -addInfoProperty (Property metatypes d a oldi c) newi = +addInfoProperty (Property _ d a oldi c) newi = Property sing d a (oldi <> newi) c {- @@ -269,7 +270,7 @@ class Combines x y where -> CombinedType x y instance (CannotCombineTargets x y (Combine x y) ~ 'CanCombineTargets, SingI (Combine x y)) => Combines (Property (MetaTypes x)) (Property (MetaTypes y)) where - combineWith f _ (Property t1 d1 a1 i1 c1) (Property _t2 d2 a2 i2 c2) = + combineWith f _ (Property _ d1 a1 i1 c1) (Property _ d2 a2 i2 c2) = Property sing d1 (f a1 a2) i1 (ChildProperty d2 a2 i2 c2 : c1) instance (CannotCombineTargets x y (Combine x y) ~ 'CanCombineTargets, CannotCombineTargets x' y' (Combine x' y') ~ 'CanCombineTargets, SingI (Combine x y), SingI (Combine x' y')) => Combines (RevertableProperty (MetaTypes x) (MetaTypes x')) (RevertableProperty (MetaTypes y) (MetaTypes y')) where combineWith sf tf (RevertableProperty s1 t1) (RevertableProperty s2 t2) = -- cgit v1.2.3 From 91d1833155a2e8be2c435d0a92a750cc9d2f30b5 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 25 Mar 2016 14:04:40 -0400 Subject: ported Property.List I wanted to keep propertyList [foo, bar] working, but had some difficulty making the type class approach work. Anyway, that's unlikely to be useful, since foo and bar probably have different types, or could easiy have their types updated breaking it. --- debian/changelog | 34 +++++++----- src/Propellor/Base.hs | 4 +- src/Propellor/Engine.hs | 16 ++++-- src/Propellor/EnsureProperty.hs | 2 +- src/Propellor/PrivData.hs | 2 +- src/Propellor/PropAccum.hs | 9 +-- src/Propellor/Property.hs | 4 +- src/Propellor/Property/Chroot.hs | 2 +- src/Propellor/Property/Concurrent.hs | 4 +- src/Propellor/Property/Docker.hs | 2 +- src/Propellor/Property/List.hs | 104 ++++++++++++----------------------- src/Propellor/Types.hs | 20 ++++--- 12 files changed, 93 insertions(+), 110 deletions(-) (limited to 'src/Propellor/Property.hs') diff --git a/debian/changelog b/debian/changelog index ead6585e..b27559bd 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,37 +1,43 @@ propellor (3.0.0) UNRELEASED; urgency=medium * Property types have been improved to indicate what systems they target. - This allows, eg, Property Debian to not be used on a FreeBSD system. + This prevents using eg, Property FreeBSD on a Debian system. Transition guide for this sweeping API change: + - Change "host name & foo & bar" + to "host name $ props & foo & bar" + - Similarly, Chroot and Docker need `props` to be used to combine + together the properies used inside them. + - And similarly, `propertyList` and `combineProperties` need `props` + to be used to combine together properties; lists of properties will + no longer work. - Change "Property NoInfo" to "Property UnixLike" - Change "Property HasInfo" to "Property (HasInfo + UnixLike)" - Change "RevertableProperty NoInfo" to "RevertableProperty UnixLike UnixLike" - Change "RevertableProperty HasInfo" to "RevertableProperty (HasInfo + UnixLike) UnixLike" - - GHC needs {-# LANGUAGE TypeOperators #-} to use these new type signatures. + - GHC needs {-# LANGUAGE TypeOperators #-} to use these fancy types. This is enabled by default for all modules in propellor.cabal. But if you are using propellor as a library, you may need to enable it manually. - If you know a property only works on a particular OS, like Debian or FreeBSD, use that instead of "UnixLike". For example: - "Property (HasInfo + Debian)" + "Property 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 + "Property (Debian + FreeBSD)" + - `ensureProperty` now needs to be passed information about the + property it's used in. + change this: foo = property desc $ ... ensureProperty bar + to this: foo = property' desc $ \o -> ... ensureProperty o 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 targets to only the OS that your more specific - property works on. For example: + tighten the type to only the OS that your more specific property works on. + For example: upgraded :: Property Debian upgraded = tightenTargets (cmdProperty "apt-get" ["upgrade"]) - - 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. + * 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. -- Joey Hess Thu, 24 Mar 2016 15:02:33 -0400 diff --git a/src/Propellor/Base.hs b/src/Propellor/Base.hs index e50adf10..4afad2ab 100644 --- a/src/Propellor/Base.hs +++ b/src/Propellor/Base.hs @@ -9,7 +9,7 @@ module Propellor.Base ( , module Propellor.Property.Cmd --, module Propellor.Property.List , module Propellor.Types.PrivData - --, module Propellor.PropAccum + , module Propellor.PropAccum , module Propellor.Info , module Propellor.PrivData --, module Propellor.Engine @@ -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/Engine.hs b/src/Propellor/Engine.hs index 2e914d67..62fad5af 100644 --- a/src/Propellor/Engine.hs +++ b/src/Propellor/Engine.hs @@ -2,10 +2,10 @@ {-# LANGUAGE GADTs #-} module Propellor.Engine ( - mainProperties, + -- mainProperties, runPropellor, ensureProperty, - ensureProperties, + ensureChildProperties, fromHost, fromHost', onlyProcess, @@ -29,6 +29,8 @@ import Propellor.Info import Propellor.Property import Utility.Exception +{- + -- | Gets the Properties of a Host, and ensures them all, -- with nice display of what's being done. mainProperties :: Host -> IO () @@ -42,6 +44,8 @@ mainProperties host = do where ps = map ignoreInfo $ hostProperties host +-} + -- | Runs a Propellor action with the specified host. -- -- If the Result is not FailedChange, any EndActions @@ -58,14 +62,14 @@ runEndAction host res (EndAction desc a) = actionMessageOn (hostName host) desc (ret, _s, _) <- runRWST (runWithHost (catchPropellor (a res))) host () return ret --- | Ensures a list of Properties, with a display of each as it runs. -ensureProperties :: [Property NoInfo] -> Propellor Result -ensureProperties ps = ensure ps NoChange +-- | Ensures the child properties, with a display of each as it runs. +ensureChildProperties :: [ChildProperty] -> Propellor Result +ensureChildProperties ps = ensure ps NoChange where ensure [] rs = return rs ensure (p:ls) rs = do hn <- asks hostName - r <- actionMessageOn hn (propertyDesc p) (ensureProperty p) + r <- actionMessageOn hn (getDesc p) (catchPropellor $ getSatisfy p) ensure ls (r <> rs) -- | Lifts an action into the context of a different host. diff --git a/src/Propellor/EnsureProperty.hs b/src/Propellor/EnsureProperty.hs index f42003c0..21f8acce 100644 --- a/src/Propellor/EnsureProperty.hs +++ b/src/Propellor/EnsureProperty.hs @@ -39,7 +39,7 @@ ensureProperty => OuterMetaTypes outer -> Property (MetaTypes inner) -> Propellor Result -ensureProperty _ = catchPropellor . propertySatisfy +ensureProperty _ = catchPropellor . getSatisfy -- The name of this was chosen to make type errors a more understandable. type family CannotUse_ensureProperty_WithInfo (l :: [a]) :: Bool diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs index bc61c538..5e6e0869 100644 --- a/src/Propellor/PrivData.hs +++ b/src/Propellor/PrivData.hs @@ -129,7 +129,7 @@ withPrivData' feed srclist c mkprop = addinfo $ mkprop $ \a -> return FailedChange addinfo p = Property undefined -- FIXME: should use sing here (propertyDesc p) - (propertySatisfy p) + (getSatisfy p) (propertyInfo p `addInfo` privset) (propertyChildren p) privset = PrivInfo $ S.fromList $ diff --git a/src/Propellor/PropAccum.hs b/src/Propellor/PropAccum.hs index fb38e260..8177b97b 100644 --- a/src/Propellor/PropAccum.hs +++ b/src/Propellor/PropAccum.hs @@ -36,8 +36,9 @@ host hn (Props i c) = Host hn c i -- metatypes and info. data Props metatypes = Props Info [ChildProperty] --- | Start constructing a Props. Properties can then be added to it using --- `(&)` etc. +-- | Start accumulating a list of properties. +-- +-- Properties can be added to it using `(&)` etc. props :: Props UnixLike props = Props mempty [] @@ -102,7 +103,7 @@ propagateContainer propagateContainer containername c prop = Property undefined (propertyDesc prop) - (propertySatisfy prop) + (getSatisfy prop) (propertyInfo prop) (propertyChildren prop ++ hostprops) where @@ -111,6 +112,6 @@ propagateContainer containername c prop = Property let i = mapInfo (forceHostContext containername) (propagatableInfo (propertyInfo p)) cs = map go (propertyChildren p) - in infoProperty (propertyDesc p) (propertySatisfy p) i cs + in infoProperty (propertyDesc p) (getSatisfy p) i cs -} diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs index 582b7cfb..8999d8d8 100644 --- a/src/Propellor/Property.hs +++ b/src/Propellor/Property.hs @@ -255,8 +255,8 @@ isNewerThan x y = do tightenTargets :: -- Note that this uses PolyKinds - ( (Targets old `NotSuperset` Targets new) ~ 'CanCombineTargets - , (NonTargets new `NotSuperset` NonTargets old) ~ 'CanCombineTargets + ( (Targets old `NotSuperset` Targets new) ~ 'CanCombine + , (NonTargets new `NotSuperset` NonTargets old) ~ 'CanCombine , SingI new ) => Property (MetaTypes old) diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs index 378836e8..fb05d659 100644 --- a/src/Propellor/Property/Chroot.hs +++ b/src/Propellor/Property/Chroot.hs @@ -148,7 +148,7 @@ propagateChrootInfo c@(Chroot location _ _) p = propagateContainer location c p' where p' = infoProperty (propertyDesc p) - (propertySatisfy p) + (getSatisfy p) (propertyInfo p <> chrootInfo c) (propertyChildren p) diff --git a/src/Propellor/Property/Concurrent.hs b/src/Propellor/Property/Concurrent.hs index 74afecc4..8d608a54 100644 --- a/src/Propellor/Property/Concurrent.hs +++ b/src/Propellor/Property/Concurrent.hs @@ -97,7 +97,7 @@ concurrentList getn d (PropList ps) = infoProperty d go mempty ps (p:rest) -> return (rest, Just p) case v of Nothing -> return r - -- This use of propertySatisfy does not lose any + -- This use of getSatisfy does not lose any -- Info asociated with the property, because -- concurrentList sets all the properties as -- children, and so propigates their info. @@ -105,7 +105,7 @@ concurrentList getn d (PropList ps) = infoProperty d go mempty ps hn <- asks hostName r' <- actionMessageOn hn (propertyDesc p) - (propertySatisfy p) + (getSatisfy p) worker q (r <> r') -- | Run an action with the number of capabiities increased as necessary to diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs index ebc0b301..c2c131c7 100644 --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -178,7 +178,7 @@ propagateContainerInfo ctr@(Container _ h) p = propagateContainer cn ctr p' where p' = infoProperty (propertyDesc p) - (propertySatisfy p) + (getSatisfy p) (propertyInfo p <> dockerinfo) (propertyChildren p) dockerinfo = dockerInfo $ diff --git a/src/Propellor/Property/List.hs b/src/Propellor/Property/List.hs index 74aa6ca6..b4a72fa8 100644 --- a/src/Propellor/Property/List.hs +++ b/src/Propellor/Property/List.hs @@ -1,86 +1,54 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} module Propellor.Property.List ( props, - PropertyList(..), - PropertyListType, - PropList(..), + Props, + propertyList, + combineProperties, ) where import Propellor.Types +import Propellor.Types.MetaTypes import Propellor.Engine import Propellor.PropAccum +import Propellor.Exception import Data.Monoid --- | Starts accumulating a list of properties. +-- | Combines a list of properties, resulting in a single property +-- that when run will run each property in the list in turn, +-- and print out the description of each as it's run. Does not stop +-- on failure; does propagate overall success/failure. +-- +-- For example: -- -- > propertyList "foo" $ props --- > & someproperty --- > ! oldproperty --- > & otherproperty -props :: PropList -props = PropList [] - -data PropList = PropList [Property HasInfo] - -instance PropAccum PropList where - PropList l `addProp` p = PropList (toProp p : l) - PropList l `addPropFront` p = PropList (l ++ [toProp p]) - getProperties (PropList l) = reverse l - -class PropertyList l where - -- | Combines a list of properties, resulting in a single property - -- that when run will run each property in the list in turn, - -- and print out the description of each as it's run. Does not stop - -- on failure; does propagate overall success/failure. - -- - -- Note that Property HasInfo and Property NoInfo are not the same - -- type, and so cannot be mixed in a list. To make a list of - -- mixed types, which can also include RevertableProperty, - -- use `props` - propertyList :: Desc -> l -> Property (PropertyListType l) - - -- | Combines a list of properties, resulting in one property that - -- ensures each in turn. Stops if a property fails. - combineProperties :: Desc -> l -> Property (PropertyListType l) - --- | Type level function to calculate whether a PropertyList has Info. -type family PropertyListType t -type instance PropertyListType [Property HasInfo] = HasInfo -type instance PropertyListType [Property NoInfo] = NoInfo -type instance PropertyListType [RevertableProperty NoInfo] = NoInfo -type instance PropertyListType [RevertableProperty HasInfo] = HasInfo -type instance PropertyListType PropList = HasInfo - -instance PropertyList [Property NoInfo] where - propertyList desc ps = simpleProperty desc (ensureProperties ps) ps - combineProperties desc ps = simpleProperty desc (combineSatisfy ps NoChange) ps - -instance PropertyList [Property HasInfo] where - -- It's ok to use ignoreInfo here, because the ps are made the - -- child properties of the property, and so their info is visible - -- that way. - propertyList desc ps = infoProperty desc (ensureProperties $ map ignoreInfo ps) mempty ps - combineProperties desc ps = infoProperty desc (combineSatisfy ps NoChange) mempty ps - -instance PropertyList [RevertableProperty HasInfo] where - propertyList desc ps = propertyList desc (map setupRevertableProperty ps) - combineProperties desc ps = combineProperties desc (map setupRevertableProperty ps) - -instance PropertyList [RevertableProperty NoInfo] where - propertyList desc ps = propertyList desc (map setupRevertableProperty ps) - combineProperties desc ps = combineProperties desc (map setupRevertableProperty ps) - -instance PropertyList PropList where - propertyList desc = propertyList desc . getProperties - combineProperties desc = combineProperties desc . getProperties - -combineSatisfy :: [Property i] -> Result -> Propellor Result +-- > & bar +-- > & baz +propertyList :: SingI metatypes => Desc -> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes) +propertyList desc (Props _i ps) = + property desc (ensureChildProperties cs) + `modifyChildren` (++ cs) + where + cs = map toProp ps + +-- | Combines a list of properties, resulting in one property that +-- ensures each in turn. Stops if a property fails. +combineProperties :: SingI metatypes => Desc -> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes) +combineProperties desc (Props _i ps) = + property desc (combineSatisfy cs NoChange) + `modifyChildren` (++ cs) + where + cs = map toProp ps + +combineSatisfy :: [ChildProperty] -> Result -> Propellor Result combineSatisfy [] rs = return rs -combineSatisfy (l:ls) rs = do - r <- ensureProperty $ ignoreInfo l +combineSatisfy (p:ps) rs = do + r <- catchPropellor $ getSatisfy p case r of FailedChange -> return FailedChange - _ -> combineSatisfy ls (r <> rs) + _ -> combineSatisfy ps (r <> rs) diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs index 42c12492..db05e100 100644 --- a/src/Propellor/Types.hs +++ b/src/Propellor/Types.hs @@ -14,6 +14,7 @@ module Propellor.Types , Info , Desc , MetaType(..) + , MetaTypes , OS(..) , UnixLike , Debian @@ -41,8 +42,6 @@ module Propellor.Types , module Propellor.Types.Dns , module Propellor.Types.Result , module Propellor.Types.ZFS - , propertySatisfy - , MetaTypes ) where import Data.Monoid @@ -169,12 +168,6 @@ ignoreInfo = -} --- | Gets the action that can be run to satisfy a Property. --- You should never run this action directly. Use --- 'Propellor.EnsureProperty.ensureProperty` instead. -propertySatisfy :: Property metatypes -> Propellor Result -propertySatisfy (Property _ _ a _ _) = a - -- | 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 @@ -214,34 +207,45 @@ setup undo = RevertableProperty setup undo class IsProp p where setDesc :: p -> Desc -> p getDesc :: p -> Desc + modifyChildren :: p -> ([ChildProperty] -> [ChildProperty]) -> p -- | Gets the info of the property, combined with all info -- of all children properties. getInfoRecursive :: p -> Info toProp :: 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 = propertyDesc + modifyChildren (Property t d a i c) f = Property t d a i (f c) getInfoRecursive (Property _ _ _ i c) = i <> mconcat (map getInfoRecursive c) toProp (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) getInfoRecursive (ChildProperty _ _ i c) = i <> mconcat (map getInfoRecursive c) toProp = id + getSatisfy (ChildProperty _ a _ _) = a instance IsProp (RevertableProperty setupmetatypes undometatypes) where -- | Sets the description of both sides. 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) -- toProp (RevertableProperty p1 _) = p1 -- | Return the Info of the currently active side. getInfoRecursive (RevertableProperty p1 _p2) = getInfoRecursive p1 toProp (RevertableProperty p1 _p2) = toProp p1 + getSatisfy (RevertableProperty p1 _) = getSatisfy p1 -- | Type level calculation of the type that results from combining two -- types of properties. -- cgit v1.2.3 From 9768434f5fa2f2ed0bbb0212763a76471186a3cd Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 25 Mar 2016 14:24:09 -0400 Subject: finished porting Property.User --- src/Propellor/Base.hs | 8 ++++---- src/Propellor/PropAccum.hs | 14 +++++++------- src/Propellor/Property.hs | 10 +++++----- src/Propellor/Property/List.hs | 10 +++++++--- src/Propellor/Property/User.hs | 29 +++++++++++++++++------------ 5 files changed, 40 insertions(+), 31 deletions(-) (limited to 'src/Propellor/Property.hs') diff --git a/src/Propellor/Base.hs b/src/Propellor/Base.hs index 4afad2ab..2a0f5cbc 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.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 diff --git a/src/Propellor/PropAccum.hs b/src/Propellor/PropAccum.hs index 8177b97b..91d7b80d 100644 --- a/src/Propellor/PropAccum.hs +++ b/src/Propellor/PropAccum.hs @@ -30,17 +30,17 @@ import Propellor.PrivData -- > ! oldproperty -- > & otherproperty host :: HostName -> Props metatypes -> Host -host hn (Props i c) = Host hn c i +host hn (Props c) = Host hn c (mconcat (map getInfoRecursive c)) -- | Props is a combination of a list of properties, with their combined --- metatypes and info. -data Props metatypes = Props Info [ChildProperty] +-- metatypes. +data Props metatypes = Props [ChildProperty] -- | Start accumulating a list of properties. -- -- Properties can be added to it using `(&)` etc. props :: Props UnixLike -props = Props mempty [] +props = Props [] infixl 1 & infixl 1 &^ @@ -62,7 +62,7 @@ type instance GetMetaTypes (RevertableProperty (MetaTypes t) undo) = MetaTypes t => Props (MetaTypes x) -> p -> Props (MetaTypes (Combine x y)) -Props i c & p = Props (i <> getInfoRecursive p) (c ++ [toProp p]) +Props c & p = Props (c ++ [toProp p]) -- | Adds a property before any other properties. (&^) @@ -74,7 +74,7 @@ Props i c & p = Props (i <> getInfoRecursive p) (c ++ [toProp p]) => Props (MetaTypes x) -> p -> Props (MetaTypes (Combine x y)) -Props i c &^ p = Props (i <> getInfoRecursive p) (toProp p : c) +Props c &^ p = Props (toProp p : c) -- | Adds a property in reverted form. (!) @@ -82,7 +82,7 @@ Props i c &^ p = Props (i <> getInfoRecursive p) (toProp p : c) => Props (MetaTypes x) -> RevertableProperty (MetaTypes y) (MetaTypes z) -> Props (MetaTypes (Combine x z)) -Props i c ! p = Props (i <> getInfoRecursive p) (c ++ [toProp (revert p)]) +Props c ! p = Props (c ++ [toProp (revert p)]) {- diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs index 8999d8d8..ba30209e 100644 --- a/src/Propellor/Property.hs +++ b/src/Propellor/Property.hs @@ -255,12 +255,12 @@ isNewerThan x y = do tightenTargets :: -- Note that this uses PolyKinds - ( (Targets old `NotSuperset` Targets new) ~ 'CanCombine - , (NonTargets new `NotSuperset` NonTargets old) ~ 'CanCombine - , SingI new + ( (Targets untightened `NotSuperset` Targets tightened) ~ 'CanCombine + , (NonTargets tightened `NotSuperset` NonTargets untightened) ~ 'CanCombine + , SingI tightened ) - => Property (MetaTypes old) - -> Property (MetaTypes new) + => Property (MetaTypes untightened) + -> Property (MetaTypes tightened) tightenTargets (Property _old d a i c) = Property sing d a i c {- diff --git a/src/Propellor/Property/List.hs b/src/Propellor/Property/List.hs index b4a72fa8..44916f23 100644 --- a/src/Propellor/Property/List.hs +++ b/src/Propellor/Property/List.hs @@ -7,18 +7,22 @@ module Propellor.Property.List ( props, Props, + toProps, propertyList, combineProperties, ) where import Propellor.Types import Propellor.Types.MetaTypes -import Propellor.Engine import Propellor.PropAccum +import Propellor.Engine import Propellor.Exception import Data.Monoid +toProps :: [Property (MetaTypes metatypes)] -> Props (MetaTypes metatypes) +toProps ps = Props (map toProp ps) + -- | Combines a list of properties, resulting in a single property -- that when run will run each property in the list in turn, -- and print out the description of each as it's run. Does not stop @@ -30,7 +34,7 @@ import Data.Monoid -- > & bar -- > & baz propertyList :: SingI metatypes => Desc -> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes) -propertyList desc (Props _i ps) = +propertyList desc (Props ps) = property desc (ensureChildProperties cs) `modifyChildren` (++ cs) where @@ -39,7 +43,7 @@ propertyList desc (Props _i ps) = -- | Combines a list of properties, resulting in one property that -- ensures each in turn. Stops if a property fails. combineProperties :: SingI metatypes => Desc -> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes) -combineProperties desc (Props _i ps) = +combineProperties desc (Props ps) = property desc (combineSatisfy cs NoChange) `modifyChildren` (++ cs) where diff --git a/src/Propellor/Property/User.hs b/src/Propellor/Property/User.hs index 8cbd11e4..76eae647 100644 --- a/src/Propellor/Property/User.hs +++ b/src/Propellor/Property/User.hs @@ -8,7 +8,7 @@ import qualified Propellor.Property.File as File data Eep = YesReallyDeleteHome accountFor :: User -> Property DebianLike -accountFor user@(User u) = check nohomedir go +accountFor user@(User u) = tightenTargets $ check nohomedir go `describe` ("account for " ++ u) where nohomedir = isNothing <$> catchMaybeIO (homedir user) @@ -22,7 +22,7 @@ systemAccountFor :: User -> Property DebianLike systemAccountFor user@(User u) = systemAccountFor' user Nothing (Just (Group u)) systemAccountFor' :: User -> Maybe FilePath -> Maybe Group -> Property DebianLike -systemAccountFor' (User u) mhome mgroup = check nouser go +systemAccountFor' (User u) mhome mgroup = tightenTargets $ check nouser go `describe` ("system account for " ++ u) where nouser = isNothing <$> catchMaybeIO (getUserEntryForName u) @@ -44,7 +44,7 @@ systemAccountFor' (User u) mhome mgroup = check nouser go -- | Removes user home directory!! Use with caution. nuked :: User -> Eep -> Property DebianLike -nuked user@(User u) _ = check hashomedir go +nuked user@(User u) _ = tightenTargets $ check hashomedir go `describe` ("nuked user " ++ u) where hashomedir = isJust <$> catchMaybeIO (homedir user) @@ -75,8 +75,10 @@ hasPassword :: User -> Property (HasInfo + DebianLike) hasPassword user = hasPassword' user hostContext hasPassword' :: IsContext c => User -> c -> Property (HasInfo + DebianLike) -hasPassword' (User u) context = go `requires` shadowConfig True +hasPassword' (User u) context = go + `requires` shadowConfig True where + go :: Property (HasInfo + UnixLike) go = withSomePrivData srcs context $ property (u ++ " has password") . setPassword srcs = @@ -105,8 +107,9 @@ chpasswd (User user) v ps = makeChange $ withHandle StdinHandle createProcessSuc hClose h lockedPassword :: User -> Property DebianLike -lockedPassword user@(User u) = check (not <$> isLockedPassword user) go - `describe` ("locked " ++ u ++ " password") +lockedPassword user@(User u) = tightenTargets $ + check (not <$> isLockedPassword user) go + `describe` ("locked " ++ u ++ " password") where go = cmdProperty "passwd" [ "--lock" @@ -131,7 +134,7 @@ homedir :: User -> IO FilePath homedir (User user) = homeDirectory <$> getUserEntryForName user hasGroup :: User -> Group -> Property DebianLike -hasGroup (User user) (Group group') = check test go +hasGroup (User user) (Group group') = tightenTargets $ check test go `describe` unwords ["user", user, "in group", group'] where test = not . elem group' . words <$> readProcess "groups" [user] @@ -150,7 +153,8 @@ hasDesktopGroups user@(User u) = property' desc $ \o -> do existinggroups <- map (fst . break (== ':')) . lines <$> liftIO (readFile "/etc/group") let toadd = filter (`elem` existinggroups) desktopgroups - ensureProperty o $ propertyList desc $ map (hasGroup user . Group) toadd + ensureProperty o $ propertyList desc $ toProps $ + map (hasGroup user . Group) toadd where desc = "user " ++ u ++ " is in standard desktop groups" -- This list comes from user-setup's debconf @@ -171,10 +175,10 @@ hasDesktopGroups user@(User u) = property' desc $ \o -> do -- | Controls whether shadow passwords are enabled or not. shadowConfig :: Bool -> Property DebianLike -shadowConfig True = check (not <$> shadowExists) +shadowConfig True = tightenTargets $ check (not <$> shadowExists) (cmdProperty "shadowconfig" ["on"]) `describe` "shadow passwords enabled" -shadowConfig False = check shadowExists +shadowConfig False = tightenTargets $ check shadowExists (cmdProperty "shadowconfig" ["off"]) `describe` "shadow passwords disabled" @@ -187,7 +191,7 @@ hasLoginShell :: User -> FilePath -> Property DebianLike hasLoginShell user loginshell = shellSetTo user loginshell `requires` shellEnabled loginshell shellSetTo :: User -> FilePath -> Property DebianLike -shellSetTo (User u) loginshell = check needchangeshell +shellSetTo (User u) loginshell = tightenTargets $ check needchangeshell (cmdProperty "chsh" ["--shell", loginshell, u]) `describe` (u ++ " has login shell " ++ loginshell) where @@ -197,4 +201,5 @@ shellSetTo (User u) loginshell = check needchangeshell -- | Ensures that /etc/shells contains a shell. shellEnabled :: FilePath -> Property DebianLike -shellEnabled loginshell = "/etc/shells" `File.containsLine` loginshell +shellEnabled loginshell = tightenTargets $ + "/etc/shells" `File.containsLine` loginshell -- cgit v1.2.3 From 1edce2b72614e2e8eceefde97436db024799ff20 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 25 Mar 2016 15:28:31 -0400 Subject: ported Property.Apt --- config-simple.hs | 4 +- src/Propellor/EnsureProperty.hs | 14 ++--- src/Propellor/Property.hs | 54 ++++++++---------- src/Propellor/Property/Apt.hs | 113 +++++++++++++++++++------------------ src/Propellor/Property/Service.hs | 10 ++-- src/Propellor/Types.hs | 23 ++++++++ src/Propellor/Types/ResultCheck.hs | 3 + 7 files changed, 121 insertions(+), 100 deletions(-) (limited to 'src/Propellor/Property.hs') diff --git a/config-simple.hs b/config-simple.hs index 21accd18..28b38409 100644 --- a/config-simple.hs +++ b/config-simple.hs @@ -25,7 +25,7 @@ hosts = -- An example host. mybox :: Host -mybox = host "mybox.example.com" +mybox = host "mybox.example.com" $ props & os (System (Debian Unstable) "amd64") & Apt.stdSourcesList & Apt.unattendedUpgrades @@ -40,7 +40,7 @@ mybox = host "mybox.example.com" -- A generic webserver in a Docker container. webserverContainer :: Docker.Container -webserverContainer = Docker.container "webserver" (Docker.latestImage "debian") +webserverContainer = Docker.container "webserver" (Docker.latestImage "debian") $ props & os (System (Debian (Stable "jessie")) "amd64") & Apt.stdSourcesList & Docker.publish "80:80" diff --git a/src/Propellor/EnsureProperty.hs b/src/Propellor/EnsureProperty.hs index 21f8acce..c4b5fde1 100644 --- a/src/Propellor/EnsureProperty.hs +++ b/src/Propellor/EnsureProperty.hs @@ -7,7 +7,7 @@ module Propellor.EnsureProperty ( ensureProperty , property' - , OuterMetaTypes + , OuterMetaTypes(..) ) where import Propellor.Types @@ -33,8 +33,8 @@ import Propellor.Exception -- with the property to be lost. ensureProperty :: - ( (Targets inner `NotSuperset` Targets outer) ~ 'CanCombine - , CannotUse_ensureProperty_WithInfo inner ~ 'True + ( Cannot_ensureProperty_WithInfo inner ~ 'True + , (Targets inner `NotSuperset` Targets outer) ~ 'CanCombine ) => OuterMetaTypes outer -> Property (MetaTypes inner) @@ -42,10 +42,10 @@ ensureProperty ensureProperty _ = catchPropellor . getSatisfy -- The name of this was chosen to make type errors a more understandable. -type family CannotUse_ensureProperty_WithInfo (l :: [a]) :: Bool -type instance CannotUse_ensureProperty_WithInfo '[] = 'True -type instance CannotUse_ensureProperty_WithInfo (t ': ts) = - Not (t `EqT` 'WithInfo) && CannotUse_ensureProperty_WithInfo ts +type family Cannot_ensureProperty_WithInfo (l :: [a]) :: Bool +type instance Cannot_ensureProperty_WithInfo '[] = 'True +type instance Cannot_ensureProperty_WithInfo (t ': ts) = + Not (t `EqT` 'WithInfo) && Cannot_ensureProperty_WithInfo ts -- | Constructs a property, like `property`, but provides its -- `OuterMetaTypes`. diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs index ba30209e..2ddec439 100644 --- a/src/Propellor/Property.hs +++ b/src/Propellor/Property.hs @@ -22,9 +22,9 @@ module Propellor.Property ( , Propellor , property , property' + , OuterMetaTypes , ensureProperty - , tightenTargets - --, withOS + , withOS , unsupportedOS , makeChange , noChange @@ -243,26 +243,6 @@ isNewerThan x y = do where mtime f = catchMaybeIO $ modificationTimeHiRes <$> getFileStatus f --- | Tightens the MetaType list of a Property, to contain fewer targets. --- --- Anything else in the MetaType list is passed through unchanged. --- --- For example, to make a property that uses apt-get, which is only --- available on DebianLike systems: --- --- > upgraded :: Property DebianLike --- > upgraded = tightenTargets $ cmdProperty "apt-get" ["upgrade"] -tightenTargets - :: - -- Note that this uses PolyKinds - ( (Targets untightened `NotSuperset` Targets tightened) ~ 'CanCombine - , (NonTargets tightened `NotSuperset` NonTargets untightened) ~ 'CanCombine - , SingI tightened - ) - => Property (MetaTypes untightened) - -> Property (MetaTypes tightened) -tightenTargets (Property _old d a i c) = Property sing d a i c - {- -- | Picks one of the two input properties to use, @@ -286,17 +266,29 @@ pickOS a@(Property ta ioa) b@(Property tb iob) = Property sing io -} --- | Makes a property that is satisfied differently depending on the host's --- operating system. +-- | Makes a property that is satisfied differently depending on specifics +-- of the host's operating system. -- --- Note that the operating system may not be declared for all hosts. +-- > myproperty :: Property Debian +-- > myproperty = withOS "foo installed" $ \o os -> case os of +-- > (Just (System (Debian (Stable release)) arch)) -> ensureProperty o ... +-- > (Just (System (Debian suite) arch)) -> ensureProperty o ... +-- > _ -> unsupportedOS -- --- > myproperty = withOS "foo installed" $ \o -> case o of --- > (Just (System (Debian suite) arch)) -> ... --- > (Just (System (Buntish release) arch)) -> ... --- > Nothing -> unsupportedOS ---withOS :: Desc -> (Maybe System -> Propellor Result) -> Property NoInfo ---withOS desc a = property desc $ a =<< getOS +-- Note that the operating system specifics may not be declared for all hosts, +-- which is where Nothing comes in. +withOS + :: (SingI metatypes) + => Desc + -> (OuterMetaTypes '[] -> Maybe System -> Propellor Result) + -> Property (MetaTypes metatypes) +withOS desc a = property desc $ a dummyoutermetatypes =<< getOS + where + -- Using this dummy value allows ensureProperty to be used + -- even though the inner property probably doesn't target everything + -- that the outer withOS property targets. + dummyoutermetatypes :: OuterMetaTypes ('[]) + dummyoutermetatypes = OuterMetaTypes sing -- | Throws an error, for use in `withOS` when a property is lacking -- support for an OS. diff --git a/src/Propellor/Property/Apt.hs b/src/Propellor/Property/Apt.hs index 7301a6ae..3dd7277e 100644 --- a/src/Propellor/Property/Apt.hs +++ b/src/Propellor/Property/Apt.hs @@ -80,37 +80,36 @@ securityUpdates suite -- -- Since the CDN is sometimes unreliable, also adds backup lines using -- kernel.org. -stdSourcesList :: Property NoInfo -stdSourcesList = withOS "standard sources.list" $ \o -> - case o of - (Just (System (Debian suite) _)) -> - ensureProperty $ stdSourcesListFor suite - _ -> error "os is not declared to be Debian" - -stdSourcesListFor :: DebianSuite -> Property NoInfo +stdSourcesList :: Property Debian +stdSourcesList = withOS "standard sources.list" $ \o os -> case os of + (Just (System (Debian suite) _)) -> + ensureProperty o $ stdSourcesListFor suite + _ -> unsupportedOS + +stdSourcesListFor :: DebianSuite -> Property Debian stdSourcesListFor suite = stdSourcesList' suite [] -- | Adds additional sources.list generators. -- -- Note that if a Property needs to enable an apt source, it's better -- to do so via a separate file in -stdSourcesList' :: DebianSuite -> [SourcesGenerator] -> Property NoInfo -stdSourcesList' suite more = setSourcesList +stdSourcesList' :: DebianSuite -> [SourcesGenerator] -> Property Debian +stdSourcesList' suite more = tightenTargets $ setSourcesList (concatMap (\gen -> gen suite) generators) `describe` ("standard sources.list for " ++ show suite) where generators = [debCdn, kernelOrg, securityUpdates] ++ more -setSourcesList :: [Line] -> Property NoInfo +setSourcesList :: [Line] -> Property DebianLike setSourcesList ls = sourcesList `File.hasContent` ls `onChange` update -setSourcesListD :: [Line] -> FilePath -> Property NoInfo +setSourcesListD :: [Line] -> FilePath -> Property DebianLike setSourcesListD ls basename = f `File.hasContent` ls `onChange` update where f = "/etc/apt/sources.list.d/" ++ basename ++ ".list" -runApt :: [String] -> UncheckedProperty NoInfo -runApt ps = cmdPropertyEnv "apt-get" ps noninteractiveEnv +runApt :: [String] -> UncheckedProperty DebianLike +runApt ps = tightenTargets $ cmdPropertyEnv "apt-get" ps noninteractiveEnv noninteractiveEnv :: [(String, String)] noninteractiveEnv = @@ -118,51 +117,51 @@ noninteractiveEnv = , ("APT_LISTCHANGES_FRONTEND", "none") ] -update :: Property NoInfo +update :: Property DebianLike update = runApt ["update"] `assume` MadeChange `describe` "apt update" -- | Have apt upgrade packages, adding new packages and removing old as -- necessary. -upgrade :: Property NoInfo +upgrade :: Property DebianLike upgrade = upgrade' "dist-upgrade" -upgrade' :: String -> Property NoInfo -upgrade' p = combineProperties ("apt " ++ p) - [ pendingConfigured - , runApt ["-y", p] +upgrade' :: String -> Property DebianLike +upgrade' p = combineProperties ("apt " ++ p) $ props + & pendingConfigured + & runApt ["-y", p] `assume` MadeChange - ] -- | Have apt upgrade packages, but never add new packages or remove -- old packages. Not suitable for upgrading acrocess major versions -- of the distribution. -safeUpgrade :: Property NoInfo +safeUpgrade :: Property DebianLike safeUpgrade = upgrade' "upgrade" -- | Have dpkg try to configure any packages that are not fully configured. -pendingConfigured :: Property NoInfo -pendingConfigured = cmdPropertyEnv "dpkg" ["--configure", "--pending"] noninteractiveEnv - `assume` MadeChange - `describe` "dpkg configured pending" +pendingConfigured :: Property DebianLike +pendingConfigured = tightenTargets $ + cmdPropertyEnv "dpkg" ["--configure", "--pending"] noninteractiveEnv + `assume` MadeChange + `describe` "dpkg configured pending" type Package = String -installed :: [Package] -> Property NoInfo +installed :: [Package] -> Property DebianLike installed = installed' ["-y"] -installed' :: [String] -> [Package] -> Property NoInfo +installed' :: [String] -> [Package] -> Property DebianLike installed' params ps = robustly $ check (isInstallable ps) go `describe` unwords ("apt installed":ps) where go = runApt (params ++ ["install"] ++ ps) -installedBackport :: [Package] -> Property NoInfo -installedBackport ps = withOS desc $ \o -> case o of +installedBackport :: [Package] -> Property DebianLike +installedBackport ps = withOS desc $ \o os -> case os of (Just (System (Debian suite) _)) -> case backportSuite suite of Nothing -> unsupportedOS - Just bs -> ensureProperty $ + Just bs -> ensureProperty o $ runApt (["install", "-t", bs, "-y"] ++ ps) `changesFile` dpkgStatus _ -> unsupportedOS @@ -170,14 +169,14 @@ installedBackport ps = withOS desc $ \o -> case o of desc = unwords ("apt installed backport":ps) -- | Minimal install of package, without recommends. -installedMin :: [Package] -> Property NoInfo +installedMin :: [Package] -> Property DebianLike installedMin = installed' ["--no-install-recommends", "-y"] -removed :: [Package] -> Property NoInfo +removed :: [Package] -> Property DebianLike removed ps = check (or <$> isInstalled' ps) (runApt (["-y", "remove"] ++ ps)) `describe` unwords ("apt removed":ps) -buildDep :: [Package] -> Property NoInfo +buildDep :: [Package] -> Property DebianLike buildDep ps = robustly $ go `changesFile` dpkgStatus `describe` unwords ("apt build-dep":ps) @@ -187,7 +186,7 @@ buildDep ps = robustly $ go -- | Installs the build deps for the source package unpacked -- in the specifed directory, with a dummy package also -- installed so that autoRemove won't remove them. -buildDepIn :: FilePath -> Property NoInfo +buildDepIn :: FilePath -> Property DebianLike buildDepIn dir = cmdPropertyEnv "sh" ["-c", cmd] noninteractiveEnv `changesFile` dpkgStatus `requires` installedMin ["devscripts", "equivs"] @@ -196,13 +195,13 @@ buildDepIn dir = cmdPropertyEnv "sh" ["-c", cmd] noninteractiveEnv -- | Package installation may fail becuse the archive has changed. -- Run an update in that case and retry. -robustly :: (Combines (Property i) (Property NoInfo)) => Property i -> Property i +robustly :: Property DebianLike -> Property DebianLike robustly p = adjustPropertySatisfy p $ \satisfy -> do r <- satisfy if r == FailedChange - -- Safe to use ignoreInfo because we're re-running - -- the same property. - then ensureProperty $ ignoreInfo $ p `requires` update + -- Safe to use getSatisfy because we're re-running + -- the same property as before. + then getSatisfy $ p `requires` update else return r isInstallable :: [Package] -> IO Bool @@ -228,13 +227,13 @@ isInstalled' ps = (mapMaybe parse . lines) <$> policy environ <- addEntry "LANG" "C" <$> getEnvironment readProcessEnv "apt-cache" ("policy":ps) (Just environ) -autoRemove :: Property NoInfo +autoRemove :: Property DebianLike autoRemove = runApt ["-y", "autoremove"] `changesFile` dpkgStatus `describe` "apt autoremove" -- | Enables unattended upgrades. Revert to disable. -unattendedUpgrades :: RevertableProperty NoInfo +unattendedUpgrades :: RevertableProperty DebianLike DebianLike unattendedUpgrades = enable disable where enable = setup True @@ -253,11 +252,12 @@ unattendedUpgrades = enable disable | enabled = "true" | otherwise = "false" - configure = withOS "unattended upgrades configured" $ \o -> - case o of + configure :: Property DebianLike + configure = withOS "unattended upgrades configured" $ \o os -> + case os of -- the package defaults to only upgrading stable (Just (System (Debian suite) _)) - | not (isStable suite) -> ensureProperty $ + | not (isStable suite) -> ensureProperty o $ "/etc/apt/apt.conf.d/50unattended-upgrades" `File.containsLine` ("Unattended-Upgrade::Origins-Pattern { \"o=Debian,a="++showSuite suite++"\"; };") @@ -269,10 +269,13 @@ type DebconfTemplateValue = String -- | Preseeds debconf values and reconfigures the package so it takes -- effect. -reConfigure :: Package -> [(DebconfTemplate, DebconfTemplateType, DebconfTemplateValue)] -> Property NoInfo -reConfigure package vals = reconfigure `requires` setselections - `describe` ("reconfigure " ++ package) +reConfigure :: Package -> [(DebconfTemplate, DebconfTemplateType, DebconfTemplateValue)] -> Property DebianLike +reConfigure package vals = tightenTargets $ + reconfigure + `requires` setselections + `describe` ("reconfigure " ++ package) where + setselections :: Property DebianLike setselections = property "preseed" $ if null vals then noChange @@ -289,7 +292,7 @@ reConfigure package vals = reconfigure `requires` setselections -- -- Assumes that there is a 1:1 mapping between service names and apt -- package names. -serviceInstalledRunning :: Package -> Property NoInfo +serviceInstalledRunning :: Package -> Property DebianLike serviceInstalledRunning svc = Service.running svc `requires` installed [svc] data AptKey = AptKey @@ -297,10 +300,10 @@ data AptKey = AptKey , pubkey :: String } -trustsKey :: AptKey -> RevertableProperty NoInfo +trustsKey :: AptKey -> RevertableProperty DebianLike DebianLike trustsKey k = trustsKey' k untrustKey k -trustsKey' :: AptKey -> Property NoInfo +trustsKey' :: AptKey -> Property DebianLike trustsKey' k = check (not <$> doesFileExist f) $ property desc $ makeChange $ do withHandle StdinHandle createProcessSuccess (proc "gpg" ["--no-default-keyring", "--keyring", f, "--import", "-"]) $ \h -> do @@ -311,21 +314,21 @@ trustsKey' k = check (not <$> doesFileExist f) $ property desc $ makeChange $ do desc = "apt trusts key " ++ keyname k f = aptKeyFile k -untrustKey :: AptKey -> Property NoInfo -untrustKey = File.notPresent . aptKeyFile +untrustKey :: AptKey -> Property DebianLike +untrustKey = tightenTargets . File.notPresent . aptKeyFile aptKeyFile :: AptKey -> FilePath aptKeyFile k = "/etc/apt/trusted.gpg.d" keyname k ++ ".gpg" -- | Cleans apt's cache of downloaded packages to avoid using up disk -- space. -cacheCleaned :: Property NoInfo -cacheCleaned = cmdProperty "apt-get" ["clean"] +cacheCleaned :: Property DebianLike +cacheCleaned = tightenTargets $ cmdProperty "apt-get" ["clean"] `assume` NoChange `describe` "apt cache cleaned" -- | Add a foreign architecture to dpkg and apt. -hasForeignArch :: String -> Property NoInfo +hasForeignArch :: String -> Property DebianLike hasForeignArch arch = check notAdded (add `before` update) `describe` ("dpkg has foreign architecture " ++ arch) where diff --git a/src/Propellor/Property/Service.hs b/src/Propellor/Property/Service.hs index 0e96ed4c..46f9e8ef 100644 --- a/src/Propellor/Property/Service.hs +++ b/src/Propellor/Property/Service.hs @@ -11,17 +11,17 @@ type ServiceName = String -- Note that due to the general poor state of init scripts, the best -- we can do is try to start the service, and if it fails, assume -- this means it's already running. -running :: ServiceName -> Property NoInfo +running :: ServiceName -> Property DebianLike running = signaled "start" "running" -restarted :: ServiceName -> Property NoInfo +restarted :: ServiceName -> Property DebianLike restarted = signaled "restart" "restarted" -reloaded :: ServiceName -> Property NoInfo +reloaded :: ServiceName -> Property DebianLike reloaded = signaled "reload" "reloaded" -signaled :: String -> Desc -> ServiceName -> Property NoInfo -signaled cmd desc svc = p `describe` (desc ++ " " ++ svc) +signaled :: String -> Desc -> ServiceName -> Property DebianLike +signaled cmd desc svc = tightenTargets $ p `describe` (desc ++ " " ++ svc) where p = scriptProperty ["service " ++ shellEscape svc ++ " " ++ cmd ++ " >/dev/null 2>&1 || true"] `assume` NoChange diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs index db05e100..7098c83f 100644 --- a/src/Propellor/Types.hs +++ b/src/Propellor/Types.hs @@ -42,6 +42,7 @@ module Propellor.Types , module Propellor.Types.Dns , module Propellor.Types.Result , module Propellor.Types.ZFS + , TightenTargets(..) ) where import Data.Monoid @@ -285,3 +286,25 @@ instance (CheckCombinable x y ~ 'CanCombine, SingI (Combine x y)) => Combines (R combineWith sf tf (RevertableProperty x _) y = combineWith sf tf x y instance (CheckCombinable x y ~ 'CanCombine, SingI (Combine x y)) => Combines (Property (MetaTypes x)) (RevertableProperty (MetaTypes y) (MetaTypes y')) where combineWith sf tf x (RevertableProperty y _) = combineWith sf tf x y + +class TightenTargets p where + -- | Tightens the MetaType list of a Property (or similar), + -- to contain fewer targets. + -- + -- For example, to make a property that uses apt-get, which is only + -- available on DebianLike systems: + -- + -- > upgraded :: Property DebianLike + -- > upgraded = tightenTargets $ cmdProperty "apt-get" ["upgrade"] + tightenTargets + :: + -- Note that this uses PolyKinds + ( (Targets untightened `NotSuperset` Targets tightened) ~ 'CanCombine + , (NonTargets tightened `NotSuperset` NonTargets untightened) ~ 'CanCombine + , SingI tightened + ) + => p (MetaTypes untightened) + -> p (MetaTypes tightened) + +instance TightenTargets Property where + tightenTargets (Property _ d a i c) = Property sing d a i c diff --git a/src/Propellor/Types/ResultCheck.hs b/src/Propellor/Types/ResultCheck.hs index 4c6524ee..f03c174f 100644 --- a/src/Propellor/Types/ResultCheck.hs +++ b/src/Propellor/Types/ResultCheck.hs @@ -22,6 +22,9 @@ import Data.Monoid -- and `FailedChange` is still an error. data UncheckedProperty i = UncheckedProperty (Property i) +instance TightenTargets UncheckedProperty where + tightenTargets (UncheckedProperty p) = UncheckedProperty (tightenTargets p) + -- | Use to indicate that a Property is unchecked. unchecked :: Property i -> UncheckedProperty i unchecked = UncheckedProperty -- cgit v1.2.3 From 860d1dd77e1789a91ed61bdceab667d94c9bd345 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 25 Mar 2016 17:36:52 -0400 Subject: cleanup warnings --- src/Propellor/EnsureProperty.hs | 24 ++++++++++++------------ src/Propellor/Property.hs | 14 +++++++------- src/Propellor/Property/Apt.hs | 14 +++++++------- src/Propellor/Types/MetaTypes.hs | 4 ++-- 4 files changed, 28 insertions(+), 28 deletions(-) (limited to 'src/Propellor/Property.hs') diff --git a/src/Propellor/EnsureProperty.hs b/src/Propellor/EnsureProperty.hs index c4b5fde1..c19dc025 100644 --- a/src/Propellor/EnsureProperty.hs +++ b/src/Propellor/EnsureProperty.hs @@ -7,7 +7,7 @@ module Propellor.EnsureProperty ( ensureProperty , property' - , OuterMetaTypes(..) + , OuterMetaTypesWitness(..) ) where import Propellor.Types @@ -17,14 +17,14 @@ import Propellor.Exception -- | For when code running in the Propellor monad needs to ensure a -- Property. -- --- Use `property'` to get the `OuterMetaTypes`. For example: +-- Use `property'` to get the `OuterMetaTypesWithness`. For example: -- -- > foo = Property Debian --- > foo = property' $ \o -> do --- > ensureProperty o (aptInstall "foo") +-- > foo = property' $ \w -> do +-- > ensureProperty w (aptInstall "foo") -- -- The type checker will prevent using ensureProperty with a property --- that does not support the target OSes needed by the OuterMetaTypes. +-- that does not support the target OSes needed by the OuterMetaTypesWitness. -- In the example above, aptInstall must support Debian, since foo -- is supposed to support Debian. -- @@ -36,7 +36,7 @@ ensureProperty ( Cannot_ensureProperty_WithInfo inner ~ 'True , (Targets inner `NotSuperset` Targets outer) ~ 'CanCombine ) - => OuterMetaTypes outer + => OuterMetaTypesWitness outer -> Property (MetaTypes inner) -> Propellor Result ensureProperty _ = catchPropellor . getSatisfy @@ -48,19 +48,19 @@ type instance Cannot_ensureProperty_WithInfo (t ': ts) = Not (t `EqT` 'WithInfo) && Cannot_ensureProperty_WithInfo ts -- | Constructs a property, like `property`, but provides its --- `OuterMetaTypes`. +-- `OuterMetaTypesWitness`. property' :: SingI metatypes => Desc - -> (OuterMetaTypes metatypes -> Propellor Result) + -> (OuterMetaTypesWitness metatypes -> Propellor Result) -> Property (MetaTypes metatypes) property' d a = - let p = Property sing d (a (outerMetaTypes p)) mempty mempty + let p = Property sing d (a (outerMetaTypesWitness p)) mempty mempty in p -- | Used to provide the metatypes of a Property to calls to -- 'ensureProperty` within it. -newtype OuterMetaTypes metatypes = OuterMetaTypes (MetaTypes metatypes) +newtype OuterMetaTypesWitness metatypes = OuterMetaTypesWitness (MetaTypes metatypes) -outerMetaTypes :: Property (MetaTypes l) -> OuterMetaTypes l -outerMetaTypes (Property metatypes _ _ _ _) = OuterMetaTypes metatypes +outerMetaTypesWitness :: Property (MetaTypes l) -> OuterMetaTypesWitness l +outerMetaTypesWitness (Property metatypes _ _ _ _) = OuterMetaTypesWitness metatypes diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs index 2ddec439..9fa29888 100644 --- a/src/Propellor/Property.hs +++ b/src/Propellor/Property.hs @@ -22,7 +22,7 @@ module Propellor.Property ( , Propellor , property , property' - , OuterMetaTypes + , OuterMetaTypesWitness , ensureProperty , withOS , unsupportedOS @@ -270,9 +270,9 @@ pickOS a@(Property ta ioa) b@(Property tb iob) = Property sing io -- of the host's operating system. -- -- > myproperty :: Property Debian --- > myproperty = withOS "foo installed" $ \o os -> case os of --- > (Just (System (Debian (Stable release)) arch)) -> ensureProperty o ... --- > (Just (System (Debian suite) arch)) -> ensureProperty o ... +-- > myproperty = withOS "foo installed" $ \w o -> case o of +-- > (Just (System (Debian (Stable release)) arch)) -> ensureProperty w ... +-- > (Just (System (Debian suite) arch)) -> ensureProperty w ... -- > _ -> unsupportedOS -- -- Note that the operating system specifics may not be declared for all hosts, @@ -280,15 +280,15 @@ pickOS a@(Property ta ioa) b@(Property tb iob) = Property sing io withOS :: (SingI metatypes) => Desc - -> (OuterMetaTypes '[] -> Maybe System -> Propellor Result) + -> (OuterMetaTypesWitness '[] -> Maybe System -> Propellor Result) -> Property (MetaTypes metatypes) withOS desc a = property desc $ a dummyoutermetatypes =<< getOS where -- Using this dummy value allows ensureProperty to be used -- even though the inner property probably doesn't target everything -- that the outer withOS property targets. - dummyoutermetatypes :: OuterMetaTypes ('[]) - dummyoutermetatypes = OuterMetaTypes sing + dummyoutermetatypes :: OuterMetaTypesWitness ('[]) + dummyoutermetatypes = OuterMetaTypesWitness sing -- | Throws an error, for use in `withOS` when a property is lacking -- support for an OS. diff --git a/src/Propellor/Property/Apt.hs b/src/Propellor/Property/Apt.hs index 9c3b05c4..c8ad92e4 100644 --- a/src/Propellor/Property/Apt.hs +++ b/src/Propellor/Property/Apt.hs @@ -81,9 +81,9 @@ securityUpdates suite -- Since the CDN is sometimes unreliable, also adds backup lines using -- kernel.org. stdSourcesList :: Property Debian -stdSourcesList = withOS "standard sources.list" $ \o os -> case os of +stdSourcesList = withOS "standard sources.list" $ \w o -> case o of (Just (System (Debian suite) _)) -> - ensureProperty o $ stdSourcesListFor suite + ensureProperty w $ stdSourcesListFor suite _ -> unsupportedOS stdSourcesListFor :: DebianSuite -> Property Debian @@ -158,10 +158,10 @@ installed' params ps = robustly $ check (isInstallable ps) go go = runApt (params ++ ["install"] ++ ps) installedBackport :: [Package] -> Property DebianLike -installedBackport ps = withOS desc $ \o os -> case os of +installedBackport ps = withOS desc $ \w o -> case o of (Just (System (Debian suite) _)) -> case backportSuite suite of Nothing -> unsupportedOS - Just bs -> ensureProperty o $ + Just bs -> ensureProperty w $ runApt (["install", "-t", bs, "-y"] ++ ps) `changesFile` dpkgStatus _ -> unsupportedOS @@ -247,11 +247,11 @@ unattendedUpgrades = enable disable | otherwise = "false" configure :: Property DebianLike - configure = withOS "unattended upgrades configured" $ \o os -> - case os of + configure = withOS "unattended upgrades configured" $ \w o -> + case o of -- the package defaults to only upgrading stable (Just (System (Debian suite) _)) - | not (isStable suite) -> ensureProperty o $ + | not (isStable suite) -> ensureProperty w $ "/etc/apt/apt.conf.d/50unattended-upgrades" `File.containsLine` ("Unattended-Upgrade::Origins-Pattern { \"o=Debian,a="++showSuite suite++"\"; };") diff --git a/src/Propellor/Types/MetaTypes.hs b/src/Propellor/Types/MetaTypes.hs index 6545c924..6033ec27 100644 --- a/src/Propellor/Types/MetaTypes.hs +++ b/src/Propellor/Types/MetaTypes.hs @@ -116,8 +116,8 @@ type family CheckCombinable (list1 :: [a]) (list2 :: [a]) :: CheckCombine -- one target, so can only happen if there's already been a type error. -- This special case lets the type checker show only the original type -- error, and not an extra error due to a later CheckCombinable constraint. -type instance CheckCombinable '[] list2 = CanCombine -type instance CheckCombinable list1 '[] = CanCombine +type instance CheckCombinable '[] list2 = 'CanCombine +type instance CheckCombinable list1 '[] = 'CanCombine type instance CheckCombinable (l1 ': list1) (l2 ': list2) = CheckCombinable' (Combine (l1 ': list1) (l2 ': list2)) type family CheckCombinable' (combinedlist :: [a]) :: CheckCombine -- cgit v1.2.3 From 0b0ea182ab3301ade8b87b1be1cdecc3464cd1da Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 27 Mar 2016 16:10:43 -0400 Subject: ported DiskImage Unfortunately, DiskImage needs to add properties to the Chroot it's presented with, and the metatypes are not included in the Chroot, so it can't guarantee that the properties it's adding match the OS in the Chroot. I partially worked around this by making the properties that DiskImage adds check the OS, so they don't assume Debian. It would be nicer to parameterize the Chroot type with the metatypes of the inner OS. I worked for several hours on a patch along those lines, but it doesn't quite compile. Failed at the final hurdle :/ The patch is below for later.. --- src/Propellor/Property/Chroot.hs 2016-03-27 16:06:44.285464820 -0400 +++ /home/joey/Chroot.hs 2016-03-27 15:32:29.073416143 -0400 @@ -1,9 +1,9 @@ -{-# LANGUAGE FlexibleContexts, GADTs, DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts, GADTs, DeriveDataTypeable, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances, DataKinds #-} module Propellor.Property.Chroot ( debootstrapped, bootstrapped, - provisioned, + --provisioned, Chroot(..), ChrootBootstrapper(..), Debootstrapped(..), @@ -11,7 +11,7 @@ noServices, inChroot, -- * Internal use - provisioned', + --provisioned', propagateChrootInfo, propellChroot, chain, @@ -20,6 +20,7 @@ import Propellor.Base import Propellor.Container +import Propellor.Types.MetaTypes import Propellor.Types.CmdLine import Propellor.Types.Chroot import Propellor.Types.Info @@ -38,27 +39,29 @@ -- | Specification of a chroot. Normally you'll use `debootstrapped` or -- `bootstrapped` to construct a Chroot value. -data Chroot where - Chroot :: ChrootBootstrapper b => FilePath -> b -> Host -> Chroot - -instance IsContainer Chroot where - containerProperties (Chroot _ _ h) = containerProperties h - containerInfo (Chroot _ _ h) = containerInfo h - setContainerProperties (Chroot loc b h) ps = Chroot loc b (setContainerProperties h ps) +-- +-- The inner and outer type variables are the metatypes of the inside of +-- the chroot and the system it runs in. +data Chroot inner outer where + Chroot :: ChrootBootstrapper b inner outer => FilePath -> b -> Host -> (inner, outer) -> Chroot inner outer + +instance IsContainer (Chroot inner outer) where + containerProperties (Chroot _ _ h _) = containerProperties h + containerInfo (Chroot _ _ h _) = containerInfo h -chrootSystem :: Chroot -> Maybe System +chrootSystem :: Chroot inner outer -> Maybe System chrootSystem = fromInfoVal . fromInfo . containerInfo -instance Show Chroot where - show c@(Chroot loc _ _) = "Chroot " ++ loc ++ " " ++ show (chrootSystem c) +instance Show (Chroot inner outer) where + show c@(Chroot loc _ _ _) = "Chroot " ++ loc ++ " " ++ show (chrootSystem c) -- | Class of things that can do initial bootstrapping of an operating -- System in a chroot. -class ChrootBootstrapper b where +class ChrootBootstrapper b inner outer 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 Linux) + buildchroot :: b -> Maybe System -> FilePath -> Either String (Property outer) -- | Use this to bootstrap a chroot by extracting a tarball. -- @@ -68,9 +71,8 @@ -- detect automatically. data ChrootTarball = ChrootTarball FilePath -instance ChrootBootstrapper ChrootTarball where - buildchroot (ChrootTarball tb) _ loc = Right $ - tightenTargets $ extractTarball loc tb +instance ChrootBootstrapper ChrootTarball UnixLike UnixLike where + buildchroot (ChrootTarball tb) _ loc = Right $ extractTarball loc tb extractTarball :: FilePath -> FilePath -> Property UnixLike extractTarball target src = check (unpopulated target) $ @@ -88,7 +90,7 @@ -- | Use this to bootstrap a chroot with debootstrap. data Debootstrapped = Debootstrapped Debootstrap.DebootstrapConfig -instance ChrootBootstrapper Debootstrapped where +instance ChrootBootstrapper Debootstrapped DebianLike Linux where buildchroot (Debootstrapped cf) system loc = case system of (Just s@(System (Debian _) _)) -> Right $ debootstrap s (Just s@(System (Buntish _) _)) -> Right $ debootstrap s @@ -107,13 +109,22 @@ -- > & osDebian Unstable "amd64" -- > & Apt.installed ["ghc", "haskell-platform"] -- > & ... -debootstrapped :: Debootstrap.DebootstrapConfig -> FilePath -> Chroot +-- debootstrapped :: Debootstrap.DebootstrapConfig -> FilePath -> Chroot DebianLike +debootstrapped + :: (SingI inner, SingI outer, ChrootBootstrapper Debootstrapped (MetaTypes inner) (MetaTypes outer)) + => Debootstrap.DebootstrapConfig + -> FilePath + -> Chroot (MetaTypes inner) (MetaTypes outer) debootstrapped conf = bootstrapped (Debootstrapped conf) -- | Defines a Chroot at the given location, bootstrapped with the -- specified ChrootBootstrapper. -bootstrapped :: ChrootBootstrapper b => b -> FilePath -> Chroot -bootstrapped bootstrapper location = Chroot location bootstrapper h +bootstrapped + :: (SingI inner, SingI outer, ChrootBootstrapper b (MetaTypes inner) (MetaTypes outer)) + => b + -> FilePath + -> Chroot (MetaTypes inner) (MetaTypes outer) +bootstrapped bootstrapper location = Chroot location bootstrapper h (sing, sing) where h = Host location [] mempty @@ -123,45 +134,79 @@ -- Reverting this property removes the chroot. Anything mounted inside it -- is first unmounted. Note that it does not ensure that any processes -- that might be running inside the chroot are stopped. -provisioned :: Chroot -> RevertableProperty (HasInfo + Linux) Linux +-- provisioned :: SingI outer => Chroot inner outer -> RevertableProperty (HasInfo + MetaTypes outer) Linux +provisioned + :: + ( SingI outer + , SingI metatypes + , Combines (Property (MetaTypes outer)) (Property (MetaTypes outer)) + , (HasInfo + outer) ~ MetaTypes metatypes + , CombinedType (Property (MetaTypes outer)) (Property (MetaTypes outer)) ~ Property outer + , IncludesInfo (MetaTypes metatypes) ~ 'True) + => Chroot inner outer -> RevertableProperty (HasInfo + outer) Linux provisioned c = provisioned' (propagateChrootInfo c) c False provisioned' - :: (Property Linux -> Property (HasInfo + Linux)) - -> Chroot + :: + ( Combines (Property (MetaTypes outer)) (Property (MetaTypes outer)) + , CombinedType (Property (MetaTypes outer)) (Property (MetaTypes outer)) ~ Property outer + , SingI outer + ) + => (Property outer -> Property (HasInfo + outer)) + -> Chroot inner outer -> Bool - -> RevertableProperty (HasInfo + Linux) Linux -provisioned' propigator c@(Chroot loc bootstrapper _) systemdonly = - (propigator $ setup `describe` chrootDesc c "exists") + -> RevertableProperty (HasInfo + outer) Linux +provisioned' propigator c systemdonly = + (propigator $ setup c systemdonly `describe` chrootDesc c "exists") - (teardown `describe` chrootDesc c "removed") - where - setup :: Property Linux - setup = propellChroot c (inChrootProcess (not systemdonly) c) systemdonly - `requires` built - - built = case buildchroot bootstrapper (chrootSystem c) loc of - Right p -> p - Left e -> cantbuild e - - cantbuild e = property (chrootDesc c "built") (error e) - - teardown :: Property Linux - teardown = check (not <$> unpopulated loc) $ - property ("removed " ++ loc) $ - makeChange (removeChroot loc) - -propagateChrootInfo :: Chroot -> Property Linux -> Property (HasInfo + Linux) -propagateChrootInfo c@(Chroot location _ _) p = propagateContainer location c $ - p `addInfoProperty` chrootInfo c + (teardown c `describe` chrootDesc c "removed") -chrootInfo :: Chroot -> Info -chrootInfo (Chroot loc _ h) = mempty `addInfo` +-- chroot removal code is currently linux specific.. +teardown :: Chroot inner outer -> Property Linux +teardown (Chroot loc _ _ _) = check (not <$> unpopulated loc) $ + property ("removed " ++ loc) $ + makeChange (removeChroot loc) + +setup + :: + ( SingI outer + , Combines (Property (MetaTypes outer)) (Property (MetaTypes outer)) + ) + => Chroot inner outer + -> Bool + -> CombinedType (Property (MetaTypes outer)) (Property (MetaTypes outer)) +setup c systemdonly = propellChroot c (inChrootProcess (not systemdonly) c) systemdonly + `requires` built c + +built :: (SingI outer, ChrootBootstrapper b inner outer) => Chroot inner outer -> Property (MetaTypes outer) +built c@(Chroot loc bootstrapper _ _) = + case buildchroot bootstrapper (chrootSystem c) loc of + Right p -> error "FOO" -- p + Left e -> error "FOO" -- cantbuild c e + +cantbuild :: Chroot inner outer -> String -> Property UnixLike +cantbuild c e = property (chrootDesc c "built") (error e) + +propagateChrootInfo + :: + ( SingI metatypes + , (HasInfo + outer) ~ MetaTypes metatypes + , IncludesInfo (MetaTypes metatypes) ~ 'True + ) + => Chroot inner outer + -> Property outer + -> Property (MetaTypes metatypes) +propagateChrootInfo c@(Chroot location _ _ _) p = + propagateContainer location c $ + p `addInfoProperty` chrootInfo c + +chrootInfo :: Chroot inner outer -> Info +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 UnixLike -propellChroot c@(Chroot loc _ _) mkproc systemdonly = property (chrootDesc c "provisioned") $ do +propellChroot :: SingI outer => Chroot inner outer -> ([String] -> IO (CreateProcess, IO ())) -> Bool -> Property (MetaTypes outer) +propellChroot c@(Chroot loc _ _ _) mkproc systemdonly = property (chrootDesc c "provisioned") $ do let d = localdir shimdir c let me = localdir "propellor" shim <- liftIO $ ifM (doesDirectoryExist d) @@ -199,8 +244,8 @@ liftIO cleanup return r -toChain :: HostName -> Chroot -> Bool -> IO CmdLine -toChain parenthost (Chroot loc _ _) systemdonly = do +toChain :: HostName -> Chroot inner outer -> Bool -> IO CmdLine +toChain parenthost (Chroot loc _ _ _) systemdonly = do onconsole <- isConsole <$> getMessageHandle return $ ChrootChain parenthost loc systemdonly onconsole @@ -224,8 +269,8 @@ putStrLn $ "\n" ++ show r chain _ _ = errorMessage "bad chain command" -inChrootProcess :: Bool -> Chroot -> [String] -> IO (CreateProcess, IO ()) -inChrootProcess keepprocmounted (Chroot loc _ _) cmd = do +inChrootProcess :: Bool -> Chroot inner outer -> [String] -> IO (CreateProcess, IO ()) +inChrootProcess keepprocmounted (Chroot loc _ _ _) cmd = do mountproc return (proc "chroot" (loc:cmd), cleanup) where @@ -244,26 +289,24 @@ provisioningLock :: FilePath -> FilePath provisioningLock containerloc = "chroot" mungeloc containerloc ++ ".lock" -shimdir :: Chroot -> FilePath -shimdir (Chroot loc _ _) = "chroot" mungeloc loc ++ ".shim" +shimdir :: Chroot inner outer -> FilePath +shimdir (Chroot loc _ _ _) = "chroot" mungeloc loc ++ ".shim" mungeloc :: FilePath -> String mungeloc = replace "/" "_" -chrootDesc :: Chroot -> String -> String -chrootDesc (Chroot loc _ _) desc = "chroot " ++ loc ++ " " ++ desc +chrootDesc :: Chroot inner outer -> String -> String +chrootDesc (Chroot loc _ _ _) desc = "chroot " ++ loc ++ " " ++ desc --- src/Propellor/Container.hs | 18 ++++++++- src/Propellor/PropAccum.hs | 12 ------ src/Propellor/Property.hs | 2 +- src/Propellor/Property/Chroot.hs | 11 +++-- src/Propellor/Property/Conductor.hs | 7 ++-- src/Propellor/Property/DiskImage.hs | 81 ++++++++++++++++++++++--------------- src/Propellor/Property/Grub.hs | 11 +++-- src/Propellor/Property/Ssh.hs | 2 +- src/Propellor/Types/MetaTypes.hs | 2 +- 9 files changed, 87 insertions(+), 59 deletions(-) (limited to 'src/Propellor/Property.hs') diff --git a/src/Propellor/Container.hs b/src/Propellor/Container.hs index 832faf9c..4cd46ae5 100644 --- a/src/Propellor/Container.hs +++ b/src/Propellor/Container.hs @@ -6,14 +6,28 @@ import Propellor.Types import Propellor.Types.MetaTypes import Propellor.Types.Info import Propellor.PrivData +import Propellor.PropAccum class IsContainer c where containerProperties :: c -> [ChildProperty] containerInfo :: c -> Info + setContainerProperties :: c -> [ChildProperty] -> c instance IsContainer Host where - containerProperties = hostProperties - containerInfo = hostInfo + containerProperties = hostProperties + containerInfo = hostInfo + setContainerProperties h ps = host (hostName h) (Props ps) + +-- | Note that the metatype of a container's properties is not retained, +-- so this defaults to UnixLike. So, using this with setContainerProps can +-- add properties to a container that conflict with properties already in it. +-- Use caution when using this; only add properties that do not have +-- restricted targets. +containerProps :: IsContainer c => c -> Props UnixLike +containerProps = Props . containerProperties + +setContainerProps :: IsContainer c => c -> Props metatypes -> c +setContainerProps c (Props ps) = setContainerProperties c ps -- | Adjust the provided Property, adding to its -- propertyChidren the properties of the provided container. diff --git a/src/Propellor/PropAccum.hs b/src/Propellor/PropAccum.hs index 1212ef7a..856f2e8e 100644 --- a/src/Propellor/PropAccum.hs +++ b/src/Propellor/PropAccum.hs @@ -12,8 +12,6 @@ module Propellor.PropAccum , (&) , (&^) , (!) - , hostProps - , modifyHostProps ) where import Propellor.Types @@ -32,16 +30,6 @@ import Prelude host :: HostName -> Props metatypes -> Host host hn (Props ps) = Host hn ps (mconcat (map getInfoRecursive ps)) --- | Note that the metatype of a Host's properties is not retained, --- so this defaults to UnixLike. So, using this with modifyHostProps can --- add properties to a Host that conflict with properties already in it. --- Use caution when using this. -hostProps :: Host -> Props UnixLike -hostProps = Props . hostProperties - -modifyHostProps :: Host -> Props metatypes -> Host -modifyHostProps h ps = host (hostName h) ps - -- | Props is a combination of a list of properties, with their combined -- metatypes. data Props metatypes = Props [ChildProperty] diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs index 9fa29888..70583edc 100644 --- a/src/Propellor/Property.hs +++ b/src/Propellor/Property.hs @@ -308,7 +308,7 @@ makeChange a = liftIO a >> return MadeChange noChange :: Propellor Result noChange = return NoChange -doNothing :: Property UnixLike +doNothing :: SingI t => Property (MetaTypes t) doNothing = property "noop property" noChange -- | Registers an action that should be run at the very end, after diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs index ddadc763..b29da7f9 100644 --- a/src/Propellor/Property/Chroot.hs +++ b/src/Propellor/Property/Chroot.hs @@ -44,6 +44,7 @@ data Chroot where instance IsContainer Chroot where containerProperties (Chroot _ _ h) = containerProperties h containerInfo (Chroot _ _ h) = containerInfo h + setContainerProperties (Chroot loc b h) ps = Chroot loc b (setContainerProperties h ps) chrootSystem :: Chroot -> Maybe System chrootSystem = fromInfoVal . fromInfo . containerInfo @@ -256,11 +257,13 @@ chrootDesc (Chroot loc _ _) desc = "chroot " ++ loc ++ " " ++ desc -- from being started, which is often something you want to prevent when -- building a chroot. -- --- This is accomplished by installing a script --- that does not let any daemons be started by packages that use +-- On Debian, 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 DebianLike DebianLike -noServices = tightenTargets setup tightenTargets teardown +-- +-- This property has no effect on non-Debian systems. +noServices :: RevertableProperty UnixLike UnixLike +noServices = setup teardown where f = "/usr/sbin/policy-rc.d" script = [ "#!/bin/sh", "exit 101" ] diff --git a/src/Propellor/Property/Conductor.hs b/src/Propellor/Property/Conductor.hs index 005fc804..ab747acc 100644 --- a/src/Propellor/Property/Conductor.hs +++ b/src/Propellor/Property/Conductor.hs @@ -74,6 +74,7 @@ module Propellor.Property.Conductor ( ) where import Propellor.Base +import Propellor.Container import Propellor.Spin (spin') import Propellor.PrivData.Paths import Propellor.Types.Info @@ -219,7 +220,7 @@ orchestrate hs = map go hs os = extractOrchestras hs removeold h = foldl removeold' h (oldconductorsof h) - removeold' h oldconductor = modifyHostProps h $ hostProps h + removeold' h oldconductor = setContainerProps h $ containerProps h ! conductedBy oldconductor oldconductors = zip hs (map (fromInfo . hostInfo) hs) @@ -234,7 +235,7 @@ orchestrate' h (Conducted _) = h orchestrate' h (Conductor c l) | sameHost h c = cont $ addConductorPrivData h (concatMap allHosts l) | any (sameHost h) (map topHost l) = cont $ - modifyHostProps h $ hostProps h + setContainerProps h $ containerProps h & conductedBy c | otherwise = cont h where @@ -268,7 +269,7 @@ conductorFor h = go -- Reverts conductorFor. notConductorFor :: Host -> Property (HasInfo + UnixLike) -notConductorFor h = doNothing +notConductorFor h = (doNothing :: Property UnixLike) `addInfoProperty` (toInfo (NotConductorFor [h])) `describe` desc `requires` undoRevertableProperty (conductorKnownHost h) diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index 48df7fab..8c027b05 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -2,6 +2,8 @@ -- -- This module is designed to be imported unqualified. +{-# LANGUAGE TypeFamilies #-} + module Propellor.Property.DiskImage ( -- * Partition specification module Propellor.Property.DiskImage.PartSpec, @@ -30,6 +32,7 @@ import Propellor.Property.Parted import Propellor.Property.Mount import Propellor.Property.Partition import Propellor.Property.Rsync +import Propellor.Container import Utility.Path import Data.List (isPrefixOf, isInfixOf, sortBy) @@ -51,7 +54,8 @@ type DiskImage = FilePath -- -- > import Propellor.Property.DiskImage -- --- > let chroot d = Chroot.debootstrapped (System (Debian Unstable) "amd64") mempty d +-- > let chroot d = Chroot.debootstrapped mempty d +-- > & osDebian Unstable "amd64" -- > & Apt.installed ["linux-image-amd64"] -- > & User.hasPassword (User "root") -- > & User.accountFor (User "demo") @@ -89,31 +93,44 @@ imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> Finaliz imageBuilt' rebuild img mkchroot tabletype final partspec = imageBuiltFrom img chrootdir tabletype final partspec `requires` Chroot.provisioned chroot - `requires` (cleanrebuild doNothing) + `requires` (cleanrebuild (doNothing :: Property UnixLike)) `describe` desc where desc = "built disk image " ++ img + cleanrebuild :: Property Linux cleanrebuild | rebuild = property desc $ do liftIO $ removeChroot chrootdir return MadeChange | otherwise = doNothing chrootdir = img ++ ".chroot" - chroot = mkchroot chrootdir - -- Before ensuring any other properties of the chroot, avoid - -- starting services. Reverted by imageFinalized. - &^ Chroot.noServices - -- First stage finalization. - & fst final - -- Avoid wasting disk image space on the apt cache - & Apt.cacheCleaned + chroot = + let c = mkchroot chrootdir + in setContainerProps c $ containerProps c + -- Before ensuring any other properties of the chroot, + -- avoid starting services. Reverted by imageFinalized. + &^ Chroot.noServices + -- First stage finalization. + & fst final + & cachesCleaned + +-- | This property is automatically added to the chroot when building a +-- disk image. It cleans any caches of information that can be omitted; +-- eg the apt cache on Debian. +cachesCleaned :: Property UnixLike +cachesCleaned = withOS "cache cleaned" $ \w o -> + let aptclean = ensureProperty w Apt.cacheCleaned + in case o of + (Just (System (Debian _) _)) -> aptclean + (Just (System (Buntish _) _)) -> aptclean + _ -> noChange -- | Builds a disk image from the contents of a chroot. -imageBuiltFrom :: DiskImage -> FilePath -> TableType -> Finalization -> [PartSpec] -> RevertableProperty Linux Linux +imageBuiltFrom :: DiskImage -> FilePath -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) UnixLike imageBuiltFrom img chrootdir tabletype final partspec = mkimg rmimg where desc = img ++ " built from " ++ chrootdir - mkimg = property desc $ do + mkimg = property' desc $ \w -> do -- unmount helper filesystems such as proc from the chroot -- before getting sizes liftIO $ unmountBelow chrootdir @@ -123,7 +140,7 @@ imageBuiltFrom img chrootdir tabletype final partspec = mkimg rmimg -- tie the knot! let (mnts, mntopts, parttable) = fitChrootSize tabletype partspec $ map (calcsz mnts) mnts - ensureProperty $ + ensureProperty w $ imageExists img (partTableSize parttable) `before` partitioned YesReallyDeleteDiskContents img parttable @@ -136,16 +153,17 @@ imageBuiltFrom img chrootdir tabletype final partspec = mkimg rmimg rmimg = File.notPresent img partitionsPopulated :: FilePath -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> Property Linux -partitionsPopulated chrootdir mnts mntopts devs = property desc $ mconcat $ zipWith3 go mnts mntopts devs +partitionsPopulated chrootdir mnts mntopts devs = property' desc $ \w -> + mconcat $ zipWith3 (go w) mnts mntopts devs where desc = "partitions populated from " ++ chrootdir - go Nothing _ _ = noChange - go (Just mnt) mntopt loopdev = withTmpDir "mnt" $ \tmpdir -> bracket + go _ Nothing _ _ = noChange + go w (Just mnt) mntopt loopdev = withTmpDir "mnt" $ \tmpdir -> bracket (liftIO $ mount "auto" (partitionLoopDev loopdev) tmpdir mntopt) (const $ liftIO $ umountLazy tmpdir) $ \ismounted -> if ismounted - then ensureProperty $ + then ensureProperty w $ syncDirFiltered (filtersfor mnt) (chrootdir ++ mnt) tmpdir else return FailedChange @@ -230,15 +248,15 @@ type Finalization = (Property Linux, (FilePath -> [LoopDev] -> Property Linux)) imageFinalized :: Finalization -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> PartTable -> Property Linux imageFinalized (_, final) mnts mntopts devs (PartTable _ parts) = - property "disk image finalized" $ + property' "disk image finalized" $ \w -> withTmpDir "mnt" $ \top -> - go top `finally` liftIO (unmountall top) + go w top `finally` liftIO (unmountall top) where - go top = do + go w top = do liftIO $ mountall top liftIO $ writefstab top liftIO $ allowservices top - ensureProperty $ final top devs + ensureProperty w $ final top devs -- Ordered lexographically by mount point, so / comes before /usr -- comes before /usr/local @@ -280,27 +298,26 @@ noFinalization = (doNothing, \_ _ -> doNothing) grubBooted :: Grub.BIOS -> Finalization grubBooted bios = (Grub.installed' bios, boots) where - boots mnt loopdevs = combineProperties "disk image boots using grub" + boots mnt loopdevs = combineProperties "disk image boots using grub" $ props -- bind mount host /dev so grub can access the loop devices - [ bindMount "/dev" (inmnt "/dev") - , mounted "proc" "proc" (inmnt "/proc") mempty - , mounted "sysfs" "sys" (inmnt "/sys") mempty + & bindMount "/dev" (inmnt "/dev") + & mounted "proc" "proc" (inmnt "/proc") mempty + & mounted "sysfs" "sys" (inmnt "/sys") mempty -- update the initramfs so it gets the uuid of the root partition - , inchroot "update-initramfs" ["-u"] + & inchroot "update-initramfs" ["-u"] `assume` MadeChange -- work around for http://bugs.debian.org/802717 - , check haveosprober $ inchroot "chmod" ["-x", osprober] - , inchroot "update-grub" [] + & check haveosprober (inchroot "chmod" ["-x", osprober]) + & inchroot "update-grub" [] `assume` MadeChange - , check haveosprober $ inchroot "chmod" ["+x", osprober] - , inchroot "grub-install" [wholediskloopdev] + & check haveosprober (inchroot "chmod" ["+x", osprober]) + & inchroot "grub-install" [wholediskloopdev] `assume` MadeChange -- sync all buffered changes out to the disk image -- may not be necessary, but seemed needed sometimes -- when using the disk image right away. - , cmdProperty "sync" [] + & cmdProperty "sync" [] `assume` NoChange - ] where -- cannot use since the filepath is absolute inmnt f = mnt ++ f diff --git a/src/Propellor/Property/Grub.hs b/src/Propellor/Property/Grub.hs index 09255587..b8dc5f9e 100644 --- a/src/Propellor/Property/Grub.hs +++ b/src/Propellor/Property/Grub.hs @@ -29,10 +29,15 @@ mkConfig = tightenTargets $ cmdProperty "update-grub" [] `assume` MadeChange -- | Installs grub; does not run update-grub. -installed' :: BIOS -> Property DebianLike -installed' bios = Apt.installed [pkg] `describe` "grub package installed" +installed' :: BIOS -> Property Linux +installed' bios = withOS "grub package installed" $ \w o -> + let apt = ensureProperty w (Apt.installed [debpkg]) + in case o of + (Just (System (Debian _) _)) -> apt + (Just (System (Buntish _) _)) -> apt + _ -> unsupportedOS where - pkg = case bios of + debpkg = case bios of PC -> "grub-pc" EFI64 -> "grub-efi-amd64" EFI32 -> "grub-efi-ia32" diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs index 05409593..7048de3b 100644 --- a/src/Propellor/Property/Ssh.hs +++ b/src/Propellor/Property/Ssh.hs @@ -173,7 +173,7 @@ hostKeys ctx l = go `before` cleanup removestale b = map (tightenTargets . File.notPresent . flip keyFile b) staletypes cleanup :: Property DebianLike cleanup - | null staletypes || null l = tightenTargets doNothing + | null staletypes || null l = doNothing | otherwise = combineProperties ("any other ssh host keys removed " ++ typelist staletypes) (toProps $ removestale True ++ removestale False) diff --git a/src/Propellor/Types/MetaTypes.hs b/src/Propellor/Types/MetaTypes.hs index ce2b1411..3e89e28d 100644 --- a/src/Propellor/Types/MetaTypes.hs +++ b/src/Propellor/Types/MetaTypes.hs @@ -36,7 +36,7 @@ type UnixLike = MetaTypes '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish, 'Targe -- | Any linux system type Linux = MetaTypes '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish ] -- | Debian and derivatives. -type DebianLike = Debian + Buntish +type DebianLike = MetaTypes '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish ] type Debian = MetaTypes '[ 'Targeting 'OSDebian ] type Buntish = MetaTypes '[ 'Targeting 'OSBuntish ] type FreeBSD = MetaTypes '[ 'Targeting 'OSFreeBSD ] -- cgit v1.2.3 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 'src/Propellor/Property.hs') 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.2.3 From 67f4a35f08caff9efd5ec930943a02217188cc79 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 28 Mar 2016 02:28:08 -0400 Subject: implemented pickOS Fell down the fromSing rabbit hole, followed by the OMH ghc doesh't work rabbit hole. Suboptimal. --- src/Propellor/Property.hs | 77 +++++++++++++++++++++++++++++++-------- src/Propellor/Types/MetaTypes.hs | 10 ++++- src/Propellor/Types/OS.hs | 8 +++- src/Propellor/Types/Singletons.hs | 36 +++++++++++++++++- 4 files changed, 111 insertions(+), 20 deletions(-) (limited to 'src/Propellor/Property.hs') diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs index 29a8ec0f..10730710 100644 --- a/src/Propellor/Property.hs +++ b/src/Propellor/Property.hs @@ -1,8 +1,11 @@ {-# LANGUAGE PackageImports #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE PolyKinds #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} module Propellor.Property ( -- * Property combinators @@ -24,6 +27,7 @@ module Propellor.Property ( , property' , OuterMetaTypesWitness , ensureProperty + , pickOS , withOS , unsupportedOS , makeChange @@ -49,6 +53,7 @@ import Control.Monad.IfElse import "mtl" Control.Monad.RWS.Strict import System.Posix.Files import qualified Data.Hash.MD5 as MD5 +import Data.List import Control.Applicative import Prelude @@ -56,6 +61,7 @@ import Propellor.Types import Propellor.Types.Core import Propellor.Types.ResultCheck import Propellor.Types.MetaTypes +import Propellor.Types.Singletons import Propellor.Info import Propellor.EnsureProperty import Utility.Exception @@ -244,28 +250,60 @@ isNewerThan x y = do where mtime f = catchMaybeIO $ modificationTimeHiRes <$> getFileStatus f -{- - -- | 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. +-- +-- The resulting property will use the description of the first property +-- no matter which property is used in the end. So, it's often a good +-- idea to change the description to something clearer. +-- +-- For example: +-- +-- > upgraded :: UnixLike +-- > upgraded = (Apt.upgraded `pickOS` Pkg.upgraded) +-- > `describe` "OS upgraded" +-- +-- If neither input property supports the targeted OS, calls +-- `unsupportedOS`. Using the example above on a Fedora system would +-- fail that way. +-- +-- (It would be better if this constrained its return type to the Union +-- of the targets of the inputs, but that does not seems to currently +-- be possible with ghc.) +{- For some reason, ghc does not like this type signature, or indeed the + - version of this that it emits. But this does compile! Until a type + - signature can be written down, cannot add the Union constraint. + - http://stackoverflow.com/questions/36256557/what-is-the-type-of-matches-m-s-m-fromsing-s pickOS :: - ( combined ~ Union a b - , SingI combined + ( Union a b ~ c + , SingI c + , DemoteRep 'KProxy ~ [MetaType] ) => Property (MetaTypes a) -> Property (MetaTypes b) - -> Property (MetaTypes 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 - + -> Property (MetaTypes c) -} +pickOS a b = c `addChildren` [toChildProperty a, toChildProperty b] + where + -- This use of getSatisfy is safe, because both a and b + -- are added as children, so their info will propigate. + --c :: (SingI c, Union a b ~ c) => Property (MetaTypes a) -> Property (MetaTypes b) -> Property (MetaTypes c) + c = withOS (getDesc a) $ \_ o -> + if matching o a + then getSatisfy a + else if matching o b + then getSatisfy b + else unsupportedOS + matching Nothing _ = False + matching (Just o) p = + Targeting (systemToTargetOS o) + `elem` + fromSing (proptype p) + proptype (Property t _ _ _ _) = t -- | Makes a property that is satisfied differently depending on specifics -- of the host's operating system. @@ -291,13 +329,20 @@ withOS desc a = property desc $ a dummyoutermetatypes =<< getOS dummyoutermetatypes :: OuterMetaTypesWitness ('[]) dummyoutermetatypes = OuterMetaTypesWitness sing +class UnsupportedOS a where + unsupportedOS :: a + -- | Throws an error, for use in `withOS` when a property is lacking -- support for an OS. -unsupportedOS :: Propellor a -unsupportedOS = go =<< getOS - where - go Nothing = error "Unknown host OS is not supported by this property." - go (Just o) = error $ "This property is not implemented for " ++ show o +instance UnsupportedOS (Propellor a) where + unsupportedOS = go =<< getOS + where + go Nothing = error "Unknown host OS is not supported by this property." + go (Just o) = error $ "This property is not implemented for " ++ show o + +-- | A property that always fails with an unsupported OS error. +instance UnsupportedOS (Property UnixLike) where + unsupportedOS = property "unsupportedOS" unsupportedOS -- | Undoes the effect of a RevertableProperty. revert :: RevertableProperty setup undo -> RevertableProperty undo setup diff --git a/src/Propellor/Types/MetaTypes.hs b/src/Propellor/Types/MetaTypes.hs index 39d6e725..e064d76f 100644 --- a/src/Propellor/Types/MetaTypes.hs +++ b/src/Propellor/Types/MetaTypes.hs @@ -23,6 +23,7 @@ module Propellor.Types.MetaTypes ( type (&&), Not, EqT, + Union, ) where import Propellor.Types.Singletons @@ -31,6 +32,7 @@ import Propellor.Types.OS data MetaType = Targeting TargetOS -- ^ A target OS of a Property | WithInfo -- ^ Indicates that a Property has associated Info + deriving (Show, Eq, Ord) -- | Any unix-like system type UnixLike = MetaTypes '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish, 'Targeting 'OSFreeBSD ] @@ -50,7 +52,7 @@ type instance IncludesInfo (MetaTypes l) = Elem 'WithInfo l type MetaTypes = Sing --- This boilerplatw would not be needed if the singletons library were +-- This boilerplate 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 OSDebianS :: Sing ('Targeting 'OSDebian) @@ -61,6 +63,12 @@ instance SingI ('Targeting 'OSDebian) where sing = OSDebianS instance SingI ('Targeting 'OSBuntish) where sing = OSBuntishS instance SingI ('Targeting 'OSFreeBSD) where sing = OSFreeBSDS instance SingI 'WithInfo where sing = WithInfoS +instance SingKind ('KProxy :: KProxy MetaType) where + type DemoteRep ('KProxy :: KProxy MetaType) = MetaType + fromSing OSDebianS = Targeting OSDebian + fromSing OSBuntishS = Targeting OSBuntish + fromSing OSFreeBSDS = Targeting OSFreeBSD + fromSing WithInfoS = WithInfo -- | Convenience type operator to combine two `MetaTypes` lists. -- diff --git a/src/Propellor/Types/OS.hs b/src/Propellor/Types/OS.hs index 84c9d87b..d7df5490 100644 --- a/src/Propellor/Types/OS.hs +++ b/src/Propellor/Types/OS.hs @@ -17,6 +17,7 @@ module Propellor.Types.OS ( userGroup, Port(..), fromPort, + systemToTargetOS, ) where import Network.BSD (HostName) @@ -39,7 +40,12 @@ data TargetOS = OSDebian | OSBuntish | OSFreeBSD - deriving (Show, Eq) + deriving (Show, Eq, Ord) + +systemToTargetOS :: System -> TargetOS +systemToTargetOS (System (Debian _) _) = OSDebian +systemToTargetOS (System (Buntish _) _) = OSBuntish +systemToTargetOS (System (FreeBSD _) _) = OSFreeBSD -- | Debian has several rolling suites, and a number of stable releases, -- such as Stable "jessie". diff --git a/src/Propellor/Types/Singletons.hs b/src/Propellor/Types/Singletons.hs index be777ecb..f2089ee8 100644 --- a/src/Propellor/Types/Singletons.hs +++ b/src/Propellor/Types/Singletons.hs @@ -1,6 +1,17 @@ -{-# LANGUAGE DataKinds, PolyKinds, TypeOperators, TypeFamilies, GADTs #-} +{-# LANGUAGE CPP, DataKinds, PolyKinds, TypeOperators, TypeFamilies, GADTs, UndecidableInstances #-} -module Propellor.Types.Singletons where +-- | Simple implementation of singletons, portable back to ghc 7.6.3 + +module Propellor.Types.Singletons ( + module Propellor.Types.Singletons, + KProxy(..) +) where + +#if __GLASGOW_HASKELL__ > 707 +import Data.Proxy (KProxy(..)) +#else +data KProxy (a :: *) = KProxy +#endif -- | The data family of singleton types. data family Sing (x :: k) @@ -15,3 +26,24 @@ data instance Sing (x :: [k]) where 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 + +data instance Sing (x :: Bool) where + TrueS :: Sing 'True + FalseS :: Sing 'False +instance SingI 'True where sing = TrueS +instance SingI 'False where sing = FalseS + +class (kparam ~ 'KProxy) => SingKind (kparam :: KProxy k) where + type DemoteRep kparam :: * + -- | From singleton to value. + fromSing :: Sing (a :: k) -> DemoteRep kparam + +instance SingKind ('KProxy :: KProxy a) => SingKind ('KProxy :: KProxy [a]) where + type DemoteRep ('KProxy :: KProxy [a]) = [DemoteRep ('KProxy :: KProxy a)] + fromSing Nil = [] + fromSing (Cons x xs) = fromSing x : fromSing xs + +instance SingKind ('KProxy :: KProxy Bool) where + type DemoteRep ('KProxy :: KProxy Bool) = Bool + fromSing FalseS = False + fromSing TrueS = True -- cgit v1.2.3 From d36fd00e1f42ed3adc1892baff6f12fe6ed946fb Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 28 Mar 2016 03:15:06 -0400 Subject: update --- src/Propellor.hs | 2 +- src/Propellor/Property.hs | 10 +++------- 2 files changed, 4 insertions(+), 8 deletions(-) (limited to 'src/Propellor/Property.hs') diff --git a/src/Propellor.hs b/src/Propellor.hs index e6a52948..a371ea44 100644 --- a/src/Propellor.hs +++ b/src/Propellor.hs @@ -39,7 +39,6 @@ module Propellor ( , (&) , (!) -- * Propertries - , describe -- | Properties are often combined together in your propellor -- configuration. For example: -- @@ -48,6 +47,7 @@ module Propellor ( , requires , before , onChange + , describe , module Propellor.Property -- | Everything you need to build your own properties, -- and useful property combinators diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs index 10730710..111756ff 100644 --- a/src/Propellor/Property.hs +++ b/src/Propellor/Property.hs @@ -269,13 +269,9 @@ isNewerThan x y = do -- If neither input property supports the targeted OS, calls -- `unsupportedOS`. Using the example above on a Fedora system would -- fail that way. --- --- (It would be better if this constrained its return type to the Union --- of the targets of the inputs, but that does not seems to currently --- be possible with ghc.) -{- For some reason, ghc does not like this type signature, or indeed the - - version of this that it emits. But this does compile! Until a type - - signature can be written down, cannot add the Union constraint. +{- I have not yet managed to write down a type signature for this + - that ghc will accept. Until a type signature can be written down, + - cannot add the Union constraint. - http://stackoverflow.com/questions/36256557/what-is-the-type-of-matches-m-s-m-fromsing-s pickOS :: -- cgit v1.2.3 From fe67b97f939239ad1712d4755c462965ba00c0e2 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 28 Mar 2016 03:46:37 -0400 Subject: slayed the type dragon --- src/Propellor/Property.hs | 23 +++++++++++------------ 1 file changed, 11 insertions(+), 12 deletions(-) (limited to 'src/Propellor/Property.hs') diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs index 111756ff..7878912b 100644 --- a/src/Propellor/Property.hs +++ b/src/Propellor/Property.hs @@ -1,11 +1,9 @@ {-# LANGUAGE PackageImports #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE PolyKinds #-} -{-# OPTIONS_GHC -fno-warn-missing-signatures #-} module Propellor.Property ( -- * Property combinators @@ -269,25 +267,26 @@ isNewerThan x y = do -- If neither input property supports the targeted OS, calls -- `unsupportedOS`. Using the example above on a Fedora system would -- fail that way. -{- I have not yet managed to write down a type signature for this - - that ghc will accept. Until a type signature can be written down, - - cannot add the Union constraint. - - http://stackoverflow.com/questions/36256557/what-is-the-type-of-matches-m-s-m-fromsing-s pickOS :: - ( Union a b ~ c + ( SingKind ('KProxy :: KProxy ka) + , SingKind ('KProxy :: KProxy kb) + , DemoteRep ('KProxy :: KProxy ka) ~ [MetaType] + , DemoteRep ('KProxy :: KProxy kb) ~ [MetaType] , SingI c - , DemoteRep 'KProxy ~ [MetaType] + -- Would be nice to have this constraint, but + -- union will not generate metatypes lists with the same + -- order of OS's as is used everywhere else. So, + -- would need a type-level sort. + --, Union a b ~ c ) - => Property (MetaTypes a) - -> Property (MetaTypes b) + => Property (MetaTypes (a :: ka)) + -> Property (MetaTypes (b :: kb)) -> Property (MetaTypes c) --} pickOS a b = c `addChildren` [toChildProperty a, toChildProperty b] where -- This use of getSatisfy is safe, because both a and b -- are added as children, so their info will propigate. - --c :: (SingI c, Union a b ~ c) => Property (MetaTypes a) -> Property (MetaTypes b) -> Property (MetaTypes c) c = withOS (getDesc a) $ \_ o -> if matching o a then getSatisfy a -- cgit v1.2.3 From 5f41492d8afe6ac6ee3cc280c3e2f252bcc91817 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 28 Mar 2016 04:46:21 -0400 Subject: propellor spin --- src/Propellor/Property.hs | 18 ++++++++---------- src/Propellor/Property/Apt.hs | 6 +++--- src/Propellor/Property/Debootstrap.hs | 19 +++++-------------- src/Propellor/Property/Grub.hs | 2 +- src/Propellor/Property/OS.hs | 2 +- src/Propellor/Property/Ssh.hs | 2 +- 6 files changed, 19 insertions(+), 30 deletions(-) (limited to 'src/Propellor/Property.hs') diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs index 7878912b..55c39ee2 100644 --- a/src/Propellor/Property.hs +++ b/src/Propellor/Property.hs @@ -28,6 +28,7 @@ module Propellor.Property ( , pickOS , withOS , unsupportedOS + , unsupportedOS' , makeChange , noChange , doNothing @@ -292,7 +293,7 @@ pickOS a b = c `addChildren` [toChildProperty a, toChildProperty b] then getSatisfy a else if matching o b then getSatisfy b - else unsupportedOS + else unsupportedOS' matching Nothing _ = False matching (Just o) p = Targeting (systemToTargetOS o) @@ -307,7 +308,7 @@ pickOS a b = c `addChildren` [toChildProperty a, toChildProperty b] -- > myproperty = withOS "foo installed" $ \w o -> case o of -- > (Just (System (Debian (Stable release)) arch)) -> ensureProperty w ... -- > (Just (System (Debian suite) arch)) -> ensureProperty w ... --- > _ -> unsupportedOS +-- > _ -> unsupportedOS' -- -- Note that the operating system specifics may not be declared for all hosts, -- which is where Nothing comes in. @@ -324,21 +325,18 @@ withOS desc a = property desc $ a dummyoutermetatypes =<< getOS dummyoutermetatypes :: OuterMetaTypesWitness ('[]) dummyoutermetatypes = OuterMetaTypesWitness sing -class UnsupportedOS a where - unsupportedOS :: a +-- | A property that always fails with an unsupported OS error. +unsupportedOS :: Property UnixLike +unsupportedOS = property "unsupportedOS" unsupportedOS' -- | Throws an error, for use in `withOS` when a property is lacking -- support for an OS. -instance UnsupportedOS (Propellor a) where - unsupportedOS = go =<< getOS +unsupportedOS' :: Propellor Result +unsupportedOS' = go =<< getOS where go Nothing = error "Unknown host OS is not supported by this property." go (Just o) = error $ "This property is not implemented for " ++ show o --- | A property that always fails with an unsupported OS error. -instance UnsupportedOS (Property UnixLike) where - unsupportedOS = property "unsupportedOS" unsupportedOS - -- | Undoes the effect of a RevertableProperty. revert :: RevertableProperty setup undo -> RevertableProperty undo setup revert (RevertableProperty p1 p2) = RevertableProperty p2 p1 diff --git a/src/Propellor/Property/Apt.hs b/src/Propellor/Property/Apt.hs index 2199d950..1a15f72c 100644 --- a/src/Propellor/Property/Apt.hs +++ b/src/Propellor/Property/Apt.hs @@ -84,7 +84,7 @@ stdSourcesList :: Property Debian stdSourcesList = withOS "standard sources.list" $ \w o -> case o of (Just (System (Debian suite) _)) -> ensureProperty w $ stdSourcesListFor suite - _ -> unsupportedOS + _ -> unsupportedOS' stdSourcesListFor :: DebianSuite -> Property Debian stdSourcesListFor suite = stdSourcesList' suite [] @@ -160,11 +160,11 @@ installed' params ps = robustly $ check (isInstallable ps) go installedBackport :: [Package] -> Property Debian installedBackport ps = withOS desc $ \w o -> case o of (Just (System (Debian suite) _)) -> case backportSuite suite of - Nothing -> unsupportedOS + Nothing -> unsupportedOS' Just bs -> ensureProperty w $ runApt (["install", "-t", bs, "-y"] ++ ps) `changesFile` dpkgStatus - _ -> unsupportedOS + _ -> unsupportedOS' where desc = unwords ("apt installed backport":ps) diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs index fd5f6c96..e0c56966 100644 --- a/src/Propellor/Property/Debootstrap.hs +++ b/src/Propellor/Property/Debootstrap.hs @@ -101,21 +101,12 @@ extractSuite (System (FreeBSD _) _) = Nothing installed :: RevertableProperty Linux Linux installed = install remove where - install = withOS "debootstrap installed" $ \w o -> - ifM (liftIO $ isJust <$> programPath) - ( return NoChange - , ensureProperty w (installon o) - ) - - installon (Just (System (Debian _) _)) = aptinstall - installon (Just (System (Buntish _) _)) = aptinstall - installon _ = sourceInstall + install = check (isJust <$> programPath) $ + (aptinstall `pickOS` sourceInstall) + `describe` "debootstrap installed" - remove = withOS "debootstrap removed" $ \w o -> - ensureProperty w (removefrom o) - removefrom (Just (System (Debian _) _)) = aptremove - removefrom (Just (System (Buntish _) _)) = aptremove - removefrom _ = sourceRemove + remove = (aptremove `pickOS` sourceRemove) + `describe` "debootstrap removed" aptinstall = Apt.installed ["debootstrap"] aptremove = Apt.removed ["debootstrap"] diff --git a/src/Propellor/Property/Grub.hs b/src/Propellor/Property/Grub.hs index 85d098ed..a03fc5a0 100644 --- a/src/Propellor/Property/Grub.hs +++ b/src/Propellor/Property/Grub.hs @@ -30,7 +30,7 @@ mkConfig = tightenTargets $ cmdProperty "update-grub" [] -- | Installs grub; does not run update-grub. installed' :: BIOS -> Property Linux -installed' bios = (aptinstall `pickOS` aptinstall) +installed' bios = (aptinstall `pickOS` unsupportedOS) `describe` "grub package installed" where aptinstall :: Property DebianLike diff --git a/src/Propellor/Property/OS.hs b/src/Propellor/Property/OS.hs index 72753248..7d0a10ca 100644 --- a/src/Propellor/Property/OS.hs +++ b/src/Propellor/Property/OS.hs @@ -89,7 +89,7 @@ cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $ debootstrap d (Just u@(System (Buntish _) _)) -> ensureProperty w $ debootstrap u - _ -> unsupportedOS + _ -> unsupportedOS' debootstrap :: System -> Property Linux debootstrap targetos = diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs index 7048de3b..369999b7 100644 --- a/src/Propellor/Property/Ssh.hs +++ b/src/Propellor/Property/Ssh.hs @@ -53,7 +53,7 @@ installed = withOS "ssh installed" $ \w o -> in case o of (Just (System (Debian _) _)) -> aptinstall (Just (System (Buntish _) _)) -> aptinstall - _ -> unsupportedOS + _ -> unsupportedOS' restarted :: Property DebianLike restarted = Service.restarted "ssh" -- cgit v1.2.3