From 3d6a0d8663d32344a9f0761a144bfcacf9667378 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 24 Mar 2016 16:57:46 -0400 Subject: converted to metatypes A few parts using ensureProperty need more work to compile --- src/Propellor/Property/File.hs | 30 +++++++++++++++--------------- 1 file changed, 15 insertions(+), 15 deletions(-) (limited to 'src/Propellor/Property/File.hs') diff --git a/src/Propellor/Property/File.hs b/src/Propellor/Property/File.hs index 3021617c..1f66dda2 100644 --- a/src/Propellor/Property/File.hs +++ b/src/Propellor/Property/File.hs @@ -9,14 +9,14 @@ import System.Exit type Line = String -- | Replaces all the content of a file. -hasContent :: FilePath -> [Line] -> Property NoInfo +hasContent :: FilePath -> [Line] -> Property UnixLike f `hasContent` newcontent = fileProperty ("replace " ++ f) (\_oldcontent -> newcontent) f -- | Replaces all the content of a file, ensuring that its modes do not -- allow it to be read or written by anyone other than the current user -hasContentProtected :: FilePath -> [Line] -> Property NoInfo +hasContentProtected :: FilePath -> [Line] -> Property UnixLike f `hasContentProtected` newcontent = fileProperty' writeFileProtected ("replace " ++ f) (\_oldcontent -> newcontent) f @@ -53,10 +53,10 @@ hasPrivContent' writer source f context = desc = "privcontent " ++ f -- | Ensures that a line is present in a file, adding it to the end if not. -containsLine :: FilePath -> Line -> Property NoInfo +containsLine :: FilePath -> Line -> Property UnixLike f `containsLine` l = f `containsLines` [l] -containsLines :: FilePath -> [Line] -> Property NoInfo +containsLines :: FilePath -> [Line] -> Property UnixLike f `containsLines` ls = fileProperty (f ++ " contains:" ++ show ls) go f where go content = content ++ filter (`notElem` content) ls @@ -64,27 +64,27 @@ f `containsLines` ls = fileProperty (f ++ " contains:" ++ show ls) go f -- | Ensures that a line is not present in a file. -- Note that the file is ensured to exist, so if it doesn't, an empty -- file will be written. -lacksLine :: FilePath -> Line -> Property NoInfo +lacksLine :: FilePath -> Line -> Property UnixLike f `lacksLine` l = fileProperty (f ++ " remove: " ++ l) (filter (/= l)) f -lacksLines :: FilePath -> [Line] -> Property NoInfo +lacksLines :: FilePath -> [Line] -> Property UnixLike f `lacksLines` ls = fileProperty (f ++ " remove: " ++ show [ls]) (filter (`notElem` ls)) f -- | Replaces the content of a file with the transformed content of another file -basedOn :: FilePath -> (FilePath, [Line] -> [Line]) -> Property NoInfo +basedOn :: FilePath -> (FilePath, [Line] -> [Line]) -> Property UnixLike f `basedOn` (f', a) = property desc $ go =<< (liftIO $ readFile 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 NoInfo +notPresent :: FilePath -> Property UnixLike notPresent f = check (doesFileExist f) $ property (f ++ " not present") $ makeChange $ nukeFile f -fileProperty :: Desc -> ([Line] -> [Line]) -> FilePath -> Property NoInfo +fileProperty :: Desc -> ([Line] -> [Line]) -> FilePath -> Property UnixLike fileProperty = fileProperty' writeFile -fileProperty' :: (FilePath -> String -> IO ()) -> Desc -> ([Line] -> [Line]) -> FilePath -> Property NoInfo +fileProperty' :: (FilePath -> String -> IO ()) -> Desc -> ([Line] -> [Line]) -> FilePath -> Property UnixLike fileProperty' writer desc a f = property desc $ go =<< liftIO (doesFileExist f) where go True = do @@ -103,7 +103,7 @@ fileProperty' writer desc a f = property desc $ go =<< liftIO (doesFileExist f) setOwnerAndGroup f' (fileOwner s) (fileGroup s) -- | Ensures a directory exists. -dirExists :: FilePath -> Property NoInfo +dirExists :: FilePath -> Property UnixLike dirExists d = check (not <$> doesDirectoryExist d) $ property (d ++ " exists") $ makeChange $ createDirectoryIfMissing True d @@ -113,7 +113,7 @@ newtype LinkTarget = LinkTarget FilePath -- | Creates or atomically updates a symbolic link. -- -- Does not overwrite regular files or directories. -isSymlinkedTo :: FilePath -> LinkTarget -> Property NoInfo +isSymlinkedTo :: FilePath -> LinkTarget -> Property UnixLike link `isSymlinkedTo` (LinkTarget target) = property desc $ go =<< (liftIO $ tryIO $ getSymbolicLinkStatus link) where @@ -135,7 +135,7 @@ link `isSymlinkedTo` (LinkTarget target) = property desc $ updateLink = createSymbolicLink target `viaStableTmp` link -- | Ensures that a file is a copy of another (regular) file. -isCopyOf :: FilePath -> FilePath -> Property NoInfo +isCopyOf :: FilePath -> FilePath -> Property UnixLike f `isCopyOf` f' = property desc $ go =<< (liftIO $ tryIO $ getFileStatus f') where desc = f ++ " is copy of " ++ f' @@ -156,7 +156,7 @@ f `isCopyOf` f' = property desc $ go =<< (liftIO $ tryIO $ getFileStatus f') [Param "--preserve=all", Param "--", File src, File dest] -- | Ensures that a file/dir has the specified owner and group. -ownerGroup :: FilePath -> User -> Group -> Property NoInfo +ownerGroup :: FilePath -> User -> Group -> Property UnixLike ownerGroup f (User owner) (Group group) = p `describe` (f ++ " owner " ++ og) where p = cmdProperty "chown" [og, f] @@ -164,7 +164,7 @@ ownerGroup f (User owner) (Group group) = p `describe` (f ++ " owner " ++ og) og = owner ++ ":" ++ group -- | Ensures that a file/dir has the specfied mode. -mode :: FilePath -> FileMode -> Property NoInfo +mode :: FilePath -> FileMode -> Property UnixLike mode f v = p `changesFile` f where p = property (f ++ " mode " ++ show v) $ do -- 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/File.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 3218e344d117701066ced6c13927318ea2938ad4 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 26 Mar 2016 14:28:38 -0400 Subject: more porting --- src/Propellor/Property/DebianMirror.hs | 20 +++++++++---------- src/Propellor/Property/Dns.hs | 35 ++++++++++++++++++---------------- src/Propellor/Property/DnsSec.hs | 12 +++++++----- src/Propellor/Property/Fail2Ban.hs | 8 ++++---- src/Propellor/Property/File.hs | 10 +++++----- src/Propellor/Property/Firewall.hs | 4 ++-- src/Propellor/Property/FreeBSD/Pkg.hs | 17 ++++++++++------- src/Propellor/Property/Git.hs | 23 +++++++++++----------- src/Propellor/Property/Grub.hs | 32 +++++++++++++++---------------- src/Propellor/Property/Network.hs | 1 - src/Propellor/Property/Parted.hs | 17 ++++++++--------- src/Propellor/Property/Partition.hs | 11 ++++++----- src/Propellor/Property/Rsync.hs | 6 +++--- 13 files changed, 101 insertions(+), 95 deletions(-) (limited to 'src/Propellor/Property/File.hs') diff --git a/src/Propellor/Property/DebianMirror.hs b/src/Propellor/Property/DebianMirror.hs index eea7b96f..b86d8e0b 100644 --- a/src/Propellor/Property/DebianMirror.hs +++ b/src/Propellor/Property/DebianMirror.hs @@ -119,19 +119,17 @@ debianMirrorKeyring k m = m { _debianMirrorKeyring = k } debianMirrorRsyncExtra :: [RsyncExtra] -> DebianMirror -> DebianMirror debianMirrorRsyncExtra r m = m { _debianMirrorRsyncExtra = r } -mirror :: DebianMirror -> Property NoInfo -mirror mirror' = propertyList - ("Debian mirror " ++ dir) - [ Apt.installed ["debmirror"] - , User.accountFor (User "debmirror") - , File.dirExists dir - , File.ownerGroup dir (User "debmirror") (Group "debmirror") - , check (not . and <$> mapM suitemirrored suites) +mirror :: DebianMirror -> Property DebianLike +mirror mirror' = propertyList ("Debian mirror " ++ dir) $ props + & Apt.installed ["debmirror"] + & User.accountFor (User "debmirror") + & File.dirExists dir + & File.ownerGroup dir (User "debmirror") (Group "debmirror") + & check (not . and <$> mapM suitemirrored suites) (cmdProperty "debmirror" args) `describe` "debmirror setup" - , Cron.niceJob ("debmirror_" ++ dir) (_debianMirrorCronTimes mirror') (User "debmirror") "/" $ - unwords ("/usr/bin/debmirror" : args) - ] + & Cron.niceJob ("debmirror_" ++ dir) (_debianMirrorCronTimes mirror') (User "debmirror") "/" + (unwords ("/usr/bin/debmirror" : args)) where dir = _debianMirrorDir mirror' suites = _debianMirrorSuites mirror' diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs index adc12930..a660a016 100644 --- a/src/Propellor/Property/Dns.hs +++ b/src/Propellor/Property/Dns.hs @@ -60,7 +60,7 @@ import Data.List -- -- In either case, the secondary dns server Host should have an ipv4 and/or -- ipv6 property defined. -primary :: [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty HasInfo +primary :: [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty (HasInfo + DebianLike) DebianLike primary hosts domain soa rs = setup cleanup where setup = setupPrimary zonefile id hosts domain soa rs @@ -70,7 +70,7 @@ primary hosts domain soa rs = setup cleanup zonefile = "/etc/bind/propellor/db." ++ domain -setupPrimary :: FilePath -> (FilePath -> FilePath) -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> Property HasInfo +setupPrimary :: FilePath -> (FilePath -> FilePath) -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> Property (HasInfo + DebianLike) setupPrimary zonefile mknamedconffile hosts domain soa rs = withwarnings baseprop `requires` servingZones @@ -80,9 +80,10 @@ setupPrimary zonefile mknamedconffile hosts domain soa rs = indomain = M.elems $ M.filterWithKey (\hn _ -> inDomain domain $ AbsDomain $ hn) hostmap (partialzone, zonewarnings) = genZone indomain hostmap domain soa - baseprop = infoProperty ("dns primary for " ++ domain) satisfy - (mempty `addInfo` addNamedConf conf) [] - satisfy = do + baseprop = primaryprop + `addInfoProperty` (toInfo (addNamedConf conf)) + primaryprop :: Property DebianLike + primaryprop = property ("dns primary for " ++ domain) $ do sshfps <- concat <$> mapM (genSSHFP domain) (M.elems hostmap) let zone = partialzone { zHosts = zHosts partialzone ++ rs ++ sshfps } @@ -120,11 +121,13 @@ setupPrimary zonefile mknamedconffile hosts domain soa rs = in z /= oldzone || oldserial < sSerial (zSOA zone) -cleanupPrimary :: FilePath -> Domain -> Property NoInfo +cleanupPrimary :: FilePath -> Domain -> Property DebianLike cleanupPrimary zonefile domain = check (doesFileExist zonefile) $ - property ("removed dns primary for " ++ domain) - (makeChange $ removeZoneFile zonefile) - `requires` namedConfWritten + go `requires` namedConfWritten + where + desc = "removed dns primary for " ++ domain + go :: Property DebianLike + go = property desc (makeChange $ removeZoneFile zonefile) -- | Primary dns server for a domain, secured with DNSSEC. -- @@ -152,7 +155,7 @@ cleanupPrimary zonefile domain = check (doesFileExist zonefile) $ -- This is different from the serial number used by 'primary', so if you -- want to later disable DNSSEC you will need to adjust the serial number -- passed to mkSOA to ensure it is larger. -signedPrimary :: Recurrance -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty HasInfo +signedPrimary :: Recurrance -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty (HasInfo + DebianLike) DebianLike signedPrimary recurrance hosts domain soa rs = setup cleanup where setup = combineProperties ("dns primary for " ++ domain ++ " (signed)") @@ -184,12 +187,12 @@ signedPrimary recurrance hosts domain soa rs = setup cleanup -- -- Note that if a host is declared to be a primary and a secondary dns -- server for the same domain, the primary server config always wins. -secondary :: [Host] -> Domain -> RevertableProperty HasInfo +secondary :: [Host] -> Domain -> RevertableProperty (HasInfo + DebianLike) DebianLike secondary hosts domain = secondaryFor (otherServers Master hosts domain) hosts domain -- | This variant is useful if the primary server does not have its DNS -- configured via propellor. -secondaryFor :: [HostName] -> [Host] -> Domain -> RevertableProperty HasInfo +secondaryFor :: [HostName] -> [Host] -> Domain -> RevertableProperty (HasInfo + DebianLike) DebianLike secondaryFor masters hosts domain = setup cleanup where setup = pureInfoProperty desc (addNamedConf conf) @@ -218,15 +221,15 @@ otherServers wantedtype hosts domain = -- | Rewrites the whole named.conf.local file to serve the zones -- configured by `primary` and `secondary`, and ensures that bind9 is -- running. -servingZones :: Property NoInfo +servingZones :: Property DebianLike servingZones = namedConfWritten `onChange` Service.reloaded "bind9" `requires` Apt.serviceInstalledRunning "bind9" -namedConfWritten :: Property NoInfo -namedConfWritten = property "named.conf configured" $ do +namedConfWritten :: Property DebianLike +namedConfWritten = property' "named.conf configured" $ \w -> do zs <- getNamedConf - ensureProperty $ + ensureProperty w $ hasContent namedConfFile $ concatMap confStanza $ M.elems zs diff --git a/src/Propellor/Property/DnsSec.hs b/src/Propellor/Property/DnsSec.hs index 1ba459e6..aa58dc60 100644 --- a/src/Propellor/Property/DnsSec.hs +++ b/src/Propellor/Property/DnsSec.hs @@ -7,13 +7,13 @@ import qualified Propellor.Property.File as File -- -- signedPrimary uses this, so this property does not normally need to be -- used directly. -keysInstalled :: Domain -> RevertableProperty HasInfo +keysInstalled :: Domain -> RevertableProperty (HasInfo + UnixLike) UnixLike keysInstalled domain = setup cleanup where - setup = propertyList "DNSSEC keys installed" $ + setup = propertyList "DNSSEC keys installed" $ toProps $ map installkey keys - cleanup = propertyList "DNSSEC keys removed" $ + cleanup = propertyList "DNSSEC keys removed" $ toProps $ map (File.notPresent . keyFn domain) keys installkey k = writer (keysrc k) (keyFn domain k) (Context domain) @@ -37,12 +37,14 @@ keysInstalled domain = setup cleanup -- -- signedPrimary uses this, so this property does not normally need to be -- used directly. -zoneSigned :: Domain -> FilePath -> RevertableProperty HasInfo +zoneSigned :: Domain -> FilePath -> RevertableProperty (HasInfo + UnixLike) UnixLike zoneSigned domain zonefile = setup cleanup where + setup :: Property (HasInfo + UnixLike) setup = check needupdate (forceZoneSigned domain zonefile) `requires` keysInstalled domain + cleanup :: Property UnixLike cleanup = File.notPresent (signedZoneFile zonefile) `before` File.notPresent dssetfile `before` revert (keysInstalled domain) @@ -63,7 +65,7 @@ zoneSigned domain zonefile = setup cleanup t2 <- getModificationTime f return (t2 >= t1) -forceZoneSigned :: Domain -> FilePath -> Property NoInfo +forceZoneSigned :: Domain -> FilePath -> Property UnixLike forceZoneSigned domain zonefile = property ("zone signed for " ++ domain) $ liftIO $ do salt <- take 16 <$> saltSha1 let p = proc "dnssec-signzone" diff --git a/src/Propellor/Property/Fail2Ban.hs b/src/Propellor/Property/Fail2Ban.hs index 716d376f..9f147943 100644 --- a/src/Propellor/Property/Fail2Ban.hs +++ b/src/Propellor/Property/Fail2Ban.hs @@ -5,24 +5,24 @@ import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Service as Service import Propellor.Property.ConfFile -installed :: Property NoInfo +installed :: Property DebianLike installed = Apt.serviceInstalledRunning "fail2ban" -reloaded :: Property NoInfo +reloaded :: Property DebianLike reloaded = Service.reloaded "fail2ban" type Jail = String -- | By default, fail2ban only enables the ssh jail, but many others -- are available to be enabled, for example "postfix-sasl" -jailEnabled :: Jail -> Property NoInfo +jailEnabled :: Jail -> Property DebianLike jailEnabled name = jailConfigured name "enabled" "true" `onChange` reloaded -- | Configures a jail. For example: -- -- > jailConfigured "sshd" "port" "2222" -jailConfigured :: Jail -> IniKey -> String -> Property NoInfo +jailConfigured :: Jail -> IniKey -> String -> Property UnixLike jailConfigured name key value = jailConfFile name `containsIniSetting` (name, key, value) diff --git a/src/Propellor/Property/File.hs b/src/Propellor/Property/File.hs index 2a74b5ed..e072fcaa 100644 --- a/src/Propellor/Property/File.hs +++ b/src/Propellor/Property/File.hs @@ -25,25 +25,25 @@ f `hasContentProtected` newcontent = fileProperty' writeFileProtected -- -- The file's permissions are preserved if the file already existed. -- Otherwise, they're set to 600. -hasPrivContent :: IsContext c => FilePath -> c -> Property HasInfo +hasPrivContent :: IsContext c => FilePath -> c -> Property (HasInfo + UnixLike) hasPrivContent f = hasPrivContentFrom (PrivDataSourceFile (PrivFile f) f) f -- | Like hasPrivContent, but allows specifying a source -- for PrivData, rather than using PrivDataSourceFile . -hasPrivContentFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property HasInfo +hasPrivContentFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property (HasInfo + UnixLike) hasPrivContentFrom = hasPrivContent' writeFileProtected -- | Leaves the file at its default or current mode, -- allowing "private" data to be read. -- -- Use with caution! -hasPrivContentExposed :: IsContext c => FilePath -> c -> Property HasInfo +hasPrivContentExposed :: IsContext c => FilePath -> c -> Property (HasInfo + UnixLike) hasPrivContentExposed f = hasPrivContentExposedFrom (PrivDataSourceFile (PrivFile f) f) f -hasPrivContentExposedFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property HasInfo +hasPrivContentExposedFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property (HasInfo + UnixLike) hasPrivContentExposedFrom = hasPrivContent' writeFile -hasPrivContent' :: (IsContext c, IsPrivDataSource s) => (FilePath -> String -> IO ()) -> s -> FilePath -> c -> Property HasInfo +hasPrivContent' :: (IsContext c, IsPrivDataSource s) => (FilePath -> String -> IO ()) -> s -> FilePath -> c -> Property (HasInfo + UnixLike) hasPrivContent' writer source f context = withPrivData source context $ \getcontent -> property' desc $ \o -> getcontent $ \privcontent -> diff --git a/src/Propellor/Property/Firewall.hs b/src/Propellor/Property/Firewall.hs index fa1f95d4..ce0befcd 100644 --- a/src/Propellor/Property/Firewall.hs +++ b/src/Propellor/Property/Firewall.hs @@ -26,10 +26,10 @@ import Propellor.Base import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Network as Network -installed :: Property NoInfo +installed :: Property DebianLike installed = Apt.installed ["iptables"] -rule :: Chain -> Table -> Target -> Rules -> Property NoInfo +rule :: Chain -> Table -> Target -> Rules -> Property Linux rule c tb tg rs = property ("firewall rule: " <> show r) addIpTable where r = Rule c tb tg rs diff --git a/src/Propellor/Property/FreeBSD/Pkg.hs b/src/Propellor/Property/FreeBSD/Pkg.hs index 6bbd2570..6c775b94 100644 --- a/src/Propellor/Property/FreeBSD/Pkg.hs +++ b/src/Propellor/Property/FreeBSD/Pkg.hs @@ -22,8 +22,8 @@ runPkg cmd args = in lines <$> readProcess p a -pkgCmdProperty :: String -> [String] -> UncheckedProperty NoInfo -pkgCmdProperty cmd args = +pkgCmdProperty :: String -> [String] -> UncheckedProperty FreeBSD +pkgCmdProperty cmd args = tightenTargets $ let (p, a) = pkgCommand cmd args in @@ -44,13 +44,14 @@ instance IsInfo PkgUpdate where pkgUpdated :: PkgUpdate -> Bool pkgUpdated (PkgUpdate _) = True -update :: Property HasInfo +update :: Property (HasInfo + FreeBSD) update = let upd = pkgCmd "update" [] go = ifM (pkgUpdated <$> askInfo) ((noChange), (liftIO upd >> return MadeChange)) in - infoProperty "pkg update has run" go (addInfo mempty (PkgUpdate "")) [] + (property "pkg update has run" go :: Property FreeBSD) + `addInfoProperty` (toInfo (PkgUpdate "")) newtype PkgUpgrade = PkgUpgrade String deriving (Typeable, Monoid, Show) @@ -60,17 +61,19 @@ instance IsInfo PkgUpgrade where pkgUpgraded :: PkgUpgrade -> Bool pkgUpgraded (PkgUpgrade _) = True -upgrade :: Property HasInfo +upgrade :: Property (HasInfo + FreeBSD) upgrade = let upd = pkgCmd "upgrade" [] go = ifM (pkgUpgraded <$> askInfo) ((noChange), (liftIO upd >> return MadeChange)) in - infoProperty "pkg upgrade has run" go (addInfo mempty (PkgUpgrade "")) [] `requires` update + (property "pkg upgrade has run" go :: Property FreeBSD) + `addInfoProperty` (toInfo (PkgUpdate "")) + `requires` update type Package = String -installed :: Package -> Property NoInfo +installed :: Package -> Property FreeBSD installed pkg = check (isInstallable pkg) $ pkgCmdProperty "install" [pkg] isInstallable :: Package -> IO Bool diff --git a/src/Propellor/Property/Git.hs b/src/Propellor/Property/Git.hs index a5ef5ab1..5d7c8b4d 100644 --- a/src/Propellor/Property/Git.hs +++ b/src/Propellor/Property/Git.hs @@ -11,7 +11,7 @@ import Data.List -- using git-daemon, run from inetd. -- -- Note that reverting this property does not remove or stop inetd. -daemonRunning :: FilePath -> RevertableProperty NoInfo +daemonRunning :: FilePath -> RevertableProperty DebianLike DebianLike daemonRunning exportdir = setup unsetup where setup = containsLine conf (mkl "tcp4") @@ -47,7 +47,7 @@ daemonRunning exportdir = setup unsetup , exportdir ] -installed :: Property NoInfo +installed :: Property DebianLike installed = Apt.installed ["git"] type RepoUrl = String @@ -61,8 +61,8 @@ type Branch = String -- it will be recursively deleted first. -- -- A branch can be specified, to check out. -cloned :: User -> RepoUrl -> FilePath -> Maybe Branch -> Property NoInfo -cloned owner url dir mbranch = check originurl (property desc checkout) +cloned :: User -> RepoUrl -> FilePath -> Maybe Branch -> Property DebianLike +cloned owner url dir mbranch = check originurl go `requires` installed where desc = "git cloned " ++ url ++ " to " ++ dir @@ -74,12 +74,13 @@ cloned owner url dir mbranch = check originurl (property desc checkout) return (v /= Just url) , return True ) - checkout = do + go :: Property DebianLike + go = property' desc $ \w -> do liftIO $ do whenM (doesDirectoryExist dir) $ removeDirectoryRecursive dir createDirectoryIfMissing True (takeDirectory dir) - ensureProperty $ userScriptProperty owner (catMaybes checkoutcmds) + ensureProperty w $ userScriptProperty owner (catMaybes checkoutcmds) `assume` MadeChange checkoutcmds = -- The catchMaybeIO (readProcess "git" ["rev-parse", "--re data GitShared = Shared Group | SharedAll | NotShared -bareRepo :: FilePath -> User -> GitShared -> Property NoInfo -bareRepo repo user gitshared = check (isRepo repo) $ propertyList ("git repo: " ++ repo) $ +bareRepo :: FilePath -> User -> GitShared -> Property UnixLike +bareRepo repo user gitshared = check (isRepo repo) $ propertyList ("git repo: " ++ repo) $ toProps $ dirExists repo : case gitshared of NotShared -> [ ownerGroup repo user (userGroup user) @@ -121,7 +122,7 @@ bareRepo repo user gitshared = check (isRepo repo) $ propertyList ("git repo: " isRepo repo' = isNothing <$> catchMaybeIO (readProcess "git" ["rev-parse", "--resolve-git-dir", repo']) -- | Set a key value pair in a git repo's configuration. -repoConfigured :: FilePath -> (String, String) -> Property NoInfo +repoConfigured :: FilePath -> (String, String) -> Property UnixLike repo `repoConfigured` (key, value) = check (not <$> alreadyconfigured) $ userScriptProperty (User "root") [ "cd " ++ repo @@ -141,7 +142,7 @@ getRepoConfig repo key = catchDefaultIO [] $ lines <$> readProcess "git" ["-C", repo, "config", key] -- | Whether a repo accepts non-fast-forward pushes. -repoAcceptsNonFFs :: FilePath -> RevertableProperty NoInfo +repoAcceptsNonFFs :: FilePath -> RevertableProperty UnixLike UnixLike repoAcceptsNonFFs repo = accepts refuses where accepts = repoConfigured repo ("receive.denyNonFastForwards", "false") @@ -152,7 +153,7 @@ repoAcceptsNonFFs repo = accepts refuses -- | Sets a bare repository's default branch, which will be checked out -- when cloning it. -bareRepoDefaultBranch :: FilePath -> String -> Property NoInfo +bareRepoDefaultBranch :: FilePath -> String -> Property UnixLike bareRepoDefaultBranch repo branch = userScriptProperty (User "root") [ "cd " ++ repo diff --git a/src/Propellor/Property/Grub.hs b/src/Propellor/Property/Grub.hs index 1b7f2a0a..09255587 100644 --- a/src/Propellor/Property/Grub.hs +++ b/src/Propellor/Property/Grub.hs @@ -19,17 +19,17 @@ data BIOS = PC | EFI64 | EFI32 | Coreboot | Xen -- bootloader. -- -- This includes running update-grub. -installed :: BIOS -> Property NoInfo +installed :: BIOS -> Property DebianLike installed bios = installed' bios `onChange` mkConfig -- Run update-grub, to generate the grub boot menu. It will be -- automatically updated when kernel packages are installed. -mkConfig :: Property NoInfo -mkConfig = cmdProperty "update-grub" [] +mkConfig :: Property DebianLike +mkConfig = tightenTargets $ cmdProperty "update-grub" [] `assume` MadeChange -- | Installs grub; does not run update-grub. -installed' :: BIOS -> Property NoInfo +installed' :: BIOS -> Property DebianLike installed' bios = Apt.installed [pkg] `describe` "grub package installed" where pkg = case bios of @@ -48,8 +48,8 @@ installed' bios = Apt.installed [pkg] `describe` "grub package installed" -- on the device; it always does the work to reinstall it. It's a good idea -- to arrange for this property to only run once, by eg making it be run -- onChange after OS.cleanInstallOnce. -boots :: OSDevice -> Property NoInfo -boots dev = cmdProperty "grub-install" [dev] +boots :: OSDevice -> Property Linux +boots dev = tightenTargets $ cmdProperty "grub-install" [dev] `assume` MadeChange `describe` ("grub boots " ++ dev) @@ -61,10 +61,10 @@ boots dev = cmdProperty "grub-install" [dev] -- -- The rootdev should be in the form "hd0", while the bootdev is in the form -- "xen/xvda". -chainPVGrub :: GrubDevice -> GrubDevice -> TimeoutSecs -> Property NoInfo -chainPVGrub rootdev bootdev timeout = combineProperties desc - [ File.dirExists "/boot/grub" - , "/boot/grub/menu.lst" `File.hasContent` +chainPVGrub :: GrubDevice -> GrubDevice -> TimeoutSecs -> Property DebianLike +chainPVGrub rootdev bootdev timeout = combineProperties desc $ props + & File.dirExists "/boot/grub" + & "/boot/grub/menu.lst" `File.hasContent` [ "default 1" , "timeout " ++ show timeout , "" @@ -73,12 +73,12 @@ chainPVGrub rootdev bootdev timeout = combineProperties desc , "kernel /boot/xen-shim" , "boot" ] - , "/boot/load.cf" `File.hasContent` + & "/boot/load.cf" `File.hasContent` [ "configfile (" ++ bootdev ++ ")/boot/grub/grub.cfg" ] - , installed Xen - , flip flagFile "/boot/xen-shim" $ scriptProperty ["grub-mkimage --prefix '(" ++ bootdev ++ ")/boot/grub' -c /boot/load.cf -O x86_64-xen /usr/lib/grub/x86_64-xen/*.mod > /boot/xen-shim"] - `assume` MadeChange - `describe` "/boot-xen-shim" - ] + & installed Xen + & flip flagFile "/boot/xen-shim" xenshim where desc = "chain PV-grub" + xenshim = scriptProperty ["grub-mkimage --prefix '(" ++ bootdev ++ ")/boot/grub' -c /boot/load.cf -O x86_64-xen /usr/lib/grub/x86_64-xen/*.mod > /boot/xen-shim"] + `assume` MadeChange + `describe` "/boot-xen-shim" diff --git a/src/Propellor/Property/Network.hs b/src/Propellor/Property/Network.hs index 46f5cef3..9ed9e591 100644 --- a/src/Propellor/Property/Network.hs +++ b/src/Propellor/Property/Network.hs @@ -2,7 +2,6 @@ module Propellor.Property.Network where import Propellor.Base import Propellor.Property.File -import Propellor.Types.MetaTypes import Data.Char diff --git a/src/Propellor/Property/Parted.hs b/src/Propellor/Property/Parted.hs index 5d6afa9c..bc8a256d 100644 --- a/src/Propellor/Property/Parted.hs +++ b/src/Propellor/Property/Parted.hs @@ -153,18 +153,17 @@ data Eep = YesReallyDeleteDiskContents -- The FilePath can be a block device (eg, \/dev\/sda), or a disk image file. -- -- This deletes any existing partitions in the disk! Use with EXTREME caution! -partitioned :: Eep -> FilePath -> PartTable -> Property NoInfo -partitioned eep disk (PartTable tabletype parts) = property desc $ do +partitioned :: Eep -> FilePath -> PartTable -> Property DebianLike +partitioned eep disk (PartTable tabletype parts) = property' desc $ \w -> do isdev <- liftIO $ isBlockDevice <$> getFileStatus disk - ensureProperty $ combineProperties desc - [ parted eep disk partedparams - , if isdev + ensureProperty w $ combineProperties desc $ props + & parted eep disk partedparams + & if isdev then formatl (map (\n -> disk ++ show n) [1 :: Int ..]) else Partition.kpartx disk (formatl . map Partition.partitionLoopDev) - ] where desc = disk ++ " partitioned" - formatl devs = combineProperties desc (map format (zip parts devs)) + formatl devs = combineProperties desc (toProps $ map format (zip parts devs)) partedparams = concat $ mklabel : mkparts (1 :: Integer) mempty parts [] format (p, dev) = Partition.formatted' (partMkFsOpts p) Partition.YesReallyFormatPartition (partFs p) dev @@ -193,12 +192,12 @@ partitioned eep disk (PartTable tabletype parts) = property desc $ do -- -- Parted is run in script mode, so it will never prompt for input. -- It is asked to use cylinder alignment for the disk. -parted :: Eep -> FilePath -> [String] -> Property NoInfo +parted :: Eep -> FilePath -> [String] -> Property DebianLike parted YesReallyDeleteDiskContents disk ps = p `requires` installed where p = cmdProperty "parted" ("--script":"--align":"cylinder":disk:ps) `assume` MadeChange -- | Gets parted installed. -installed :: Property NoInfo +installed :: Property DebianLike installed = Apt.installed ["parted"] diff --git a/src/Propellor/Property/Partition.hs b/src/Propellor/Property/Partition.hs index b2f50339..5aff4ba4 100644 --- a/src/Propellor/Property/Partition.hs +++ b/src/Propellor/Property/Partition.hs @@ -16,7 +16,7 @@ data Fs = EXT2 | EXT3 | EXT4 | BTRFS | REISERFS | XFS | FAT | VFAT | NTFS | Linu data Eep = YesReallyFormatPartition -- | Formats a partition. -formatted :: Eep -> Fs -> FilePath -> Property NoInfo +formatted :: Eep -> Fs -> FilePath -> Property DebianLike formatted = formatted' [] -- | Options passed to a mkfs.* command when making a filesystem. @@ -24,7 +24,7 @@ formatted = formatted' [] -- Eg, ["-m0"] type MkfsOpts = [String] -formatted' :: MkfsOpts -> Eep -> Fs -> FilePath -> Property NoInfo +formatted' :: MkfsOpts -> Eep -> Fs -> FilePath -> Property DebianLike formatted' opts YesReallyFormatPartition fs dev = cmdProperty cmd opts' `assume` MadeChange `requires` Apt.installed [pkg] @@ -64,17 +64,18 @@ isLoopDev' f -- within a disk image file. The resulting loop devices are passed to the -- property, which can operate on them. Always cleans up after itself, -- by removing the device maps after the property is run. -kpartx :: FilePath -> ([LoopDev] -> Property NoInfo) -> Property NoInfo +kpartx :: FilePath -> ([LoopDev] -> Property DebianLike) -> Property DebianLike kpartx diskimage mkprop = go `requires` Apt.installed ["kpartx"] where - go = property (propertyDesc (mkprop [])) $ do + go :: Property DebianLike + go = property' (propertyDesc (mkprop [])) $ \w -> do cleanup -- idempotency loopdevs <- liftIO $ kpartxParse <$> readProcess "kpartx" ["-avs", diskimage] bad <- liftIO $ filterM (not <$$> isLoopDev) loopdevs unless (null bad) $ error $ "kpartx output seems to include non-loop-devices (possible parse failure): " ++ show bad - r <- ensureProperty (mkprop loopdevs) + r <- ensureProperty w (mkprop loopdevs) cleanup return r cleanup = void $ liftIO $ boolSystem "kpartx" [Param "-d", File diskimage] diff --git a/src/Propellor/Property/Rsync.hs b/src/Propellor/Property/Rsync.hs index 0c77df58..b40396de 100644 --- a/src/Propellor/Property/Rsync.hs +++ b/src/Propellor/Property/Rsync.hs @@ -16,7 +16,7 @@ filesUnder d = Pattern (d ++ "/*") -- | Ensures that the Dest directory exists and has identical contents as -- the Src directory. -syncDir :: Src -> Dest -> Property NoInfo +syncDir :: Src -> Dest -> Property DebianLike syncDir = syncDirFiltered [] data Filter @@ -43,7 +43,7 @@ newtype Pattern = Pattern String -- Rsync checks each name to be transferred against its list of Filter -- rules, and the first matching one is acted on. If no matching rule -- is found, the file is processed. -syncDirFiltered :: [Filter] -> Src -> Dest -> Property NoInfo +syncDirFiltered :: [Filter] -> Src -> Dest -> Property DebianLike syncDirFiltered filters src dest = rsync $ [ "-av" -- Add trailing '/' to get rsync to sync the Dest directory, @@ -56,7 +56,7 @@ syncDirFiltered filters src dest = rsync $ , "--quiet" ] ++ map toRsync filters -rsync :: [String] -> Property NoInfo +rsync :: [String] -> Property DebianLike rsync ps = cmdProperty "rsync" ps `assume` MadeChange `requires` Apt.installed ["rsync"] -- cgit v1.2.3