From a1655d24bbb1db9caccdf93eae8110d746389ae2 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 28 Mar 2016 05:53:38 -0400 Subject: type safe targets for properties * Property types have been improved to indicate what systems they target. 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, `propertyList` and `combineProperties` need `props` to be used to combine together properties; they no longer accept lists of properties. (If you have such a list, use `toProps`.) - And similarly, Chroot, Docker, and Systemd container need `props` to be used to combine together the properies used inside them. - The `os` property is removed. Instead use `osDebian`, `osBuntish`, or `osFreeBSD`. These tell the type checker the target OS of a host. - 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 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 Debian" - It's also possible make a property support a set of OS's, for example: "Property (Debian + FreeBSD)" - Removed `infoProperty` and `simpleProperty` constructors, instead use `property` to construct a Property. - Due to the polymorphic type returned by `property`, additional type signatures tend to be needed when using it. For example, this will fail to type check, because the type checker cannot guess what type you intend the intermediate property "go" to have: foo :: Property UnixLike foo = go `requires` bar where go = property "foo" (return NoChange) To fix, specify the type of go: go :: Property UnixLike - `ensureProperty` now needs to be passed a witness to the type of the property it's used in. change this: foo = property desc $ ... ensureProperty bar to this: foo = property' desc $ \w -> ... ensureProperty w bar - General purpose properties like cmdProperty have type "Property UnixLike". When using that to run a command only available on Debian, you can tighten the type to only the OS that your more specific property works on. For example: upgraded :: Property Debian upgraded = tightenTargets (cmdProperty "apt-get" ["upgrade"]) - Several utility functions have been renamed: getInfo to fromInfo propertyInfo to getInfo propertyDesc to getDesc propertyChildren to getChildren * The new `pickOS` property combinator can be used to combine different properties, supporting different OS's, into one Property that chooses which to use based on the Host's OS. * Re-enabled -O0 in propellor.cabal to reign in ghc's memory use handling these complex new types. * Added dependency on concurrent-output; removed embedded copy. --- src/Propellor/Bootstrap.hs | 1 + src/Propellor/Container.hs | 62 ++++ src/Propellor/Engine.hs | 23 +- src/Propellor/EnsureProperty.hs | 70 ++++ src/Propellor/Info.hs | 108 ++++-- src/Propellor/PrivData.hs | 45 ++- src/Propellor/PropAccum.hs | 122 +++--- src/Propellor/Property.hs | 126 +++++-- src/Propellor/Property/Aiccu.hs | 16 +- src/Propellor/Property/Apache.hs | 54 +-- src/Propellor/Property/Apt.hs | 119 +++--- src/Propellor/Property/Chroot.hs | 99 ++--- src/Propellor/Property/Cmd.hs | 10 +- src/Propellor/Property/Concurrent.hs | 14 +- src/Propellor/Property/Conductor.hs | 57 +-- src/Propellor/Property/ConfFile.hs | 8 +- src/Propellor/Property/Cron.hs | 25 +- src/Propellor/Property/DebianMirror.hs | 20 +- src/Propellor/Property/Debootstrap.hs | 42 +-- src/Propellor/Property/DiskImage.hs | 92 +++-- src/Propellor/Property/Dns.hs | 45 +-- src/Propellor/Property/DnsSec.hs | 12 +- src/Propellor/Property/Docker.hs | 161 ++++---- src/Propellor/Property/Fail2Ban.hs | 8 +- src/Propellor/Property/File.hs | 49 +-- src/Propellor/Property/Firewall.hs | 4 +- src/Propellor/Property/FreeBSD/Pkg.hs | 17 +- src/Propellor/Property/FreeBSD/Poudriere.hs | 21 +- src/Propellor/Property/Git.hs | 23 +- src/Propellor/Property/Gpg.hs | 5 +- src/Propellor/Property/Group.hs | 2 +- src/Propellor/Property/Grub.hs | 39 +- .../Property/HostingProvider/CloudAtCost.hs | 33 +- .../Property/HostingProvider/DigitalOcean.hs | 11 +- src/Propellor/Property/HostingProvider/Linode.hs | 9 +- src/Propellor/Property/Hostname.hs | 21 +- src/Propellor/Property/Journald.hs | 16 +- src/Propellor/Property/Kerberos.hs | 29 +- src/Propellor/Property/LetsEncrypt.hs | 7 +- src/Propellor/Property/LightDM.hs | 6 +- src/Propellor/Property/List.hs | 111 +++--- src/Propellor/Property/Locale.hs | 38 +- src/Propellor/Property/Logcheck.hs | 4 +- src/Propellor/Property/Mount.hs | 17 +- src/Propellor/Property/Munin.hs | 8 +- src/Propellor/Property/Network.hs | 38 +- src/Propellor/Property/Nginx.hs | 14 +- src/Propellor/Property/OS.hs | 51 ++- src/Propellor/Property/Obnam.hs | 17 +- src/Propellor/Property/OpenId.hs | 6 +- src/Propellor/Property/Parted.hs | 17 +- src/Propellor/Property/Partition.hs | 12 +- src/Propellor/Property/Postfix.hs | 37 +- src/Propellor/Property/PropellorRepo.hs | 2 +- src/Propellor/Property/Prosody.hs | 12 +- src/Propellor/Property/Reboot.hs | 6 +- src/Propellor/Property/Rsync.hs | 6 +- src/Propellor/Property/Scheduled.hs | 13 +- src/Propellor/Property/Service.hs | 10 +- src/Propellor/Property/SiteSpecific/Branchable.hs | 2 +- .../Property/SiteSpecific/GitAnnexBuilder.hs | 103 +++--- src/Propellor/Property/SiteSpecific/GitHome.hs | 11 +- src/Propellor/Property/SiteSpecific/IABak.hs | 13 +- src/Propellor/Property/SiteSpecific/JoeySites.hs | 133 +++---- src/Propellor/Property/Ssh.hs | 193 +++++----- src/Propellor/Property/Sudo.hs | 9 +- src/Propellor/Property/Systemd.hs | 163 ++++---- src/Propellor/Property/Systemd/Core.hs | 2 +- src/Propellor/Property/Tor.hs | 44 +-- src/Propellor/Property/Unbound.hs | 8 +- src/Propellor/Property/User.hs | 63 ++-- src/Propellor/Property/Uwsgi.hs | 12 +- src/Propellor/Property/ZFS/Properties.hs | 12 +- src/Propellor/Spin.hs | 4 +- src/Propellor/Types.hs | 408 +++++++-------------- src/Propellor/Types/Core.hs | 106 ++++++ src/Propellor/Types/Info.hs | 15 +- src/Propellor/Types/MetaTypes.hs | 213 +++++++++++ src/Propellor/Types/OS.hs | 21 +- src/Propellor/Types/ResultCheck.hs | 3 + src/Propellor/Types/Singletons.hs | 49 +++ 81 files changed, 2134 insertions(+), 1503 deletions(-) create mode 100644 src/Propellor/Container.hs create mode 100644 src/Propellor/EnsureProperty.hs create mode 100644 src/Propellor/Types/Core.hs create mode 100644 src/Propellor/Types/MetaTypes.hs create mode 100644 src/Propellor/Types/Singletons.hs (limited to 'src/Propellor') diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs index 69eee66c..3b4c3106 100644 --- a/src/Propellor/Bootstrap.hs +++ b/src/Propellor/Bootstrap.hs @@ -90,6 +90,7 @@ depsCommand msys = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall]) , "libghc-exceptions-dev" , "libghc-stm-dev" , "libghc-text-dev" + , "libghc-concurrent-output-dev" , "make" ] fbsddeps = diff --git a/src/Propellor/Container.hs b/src/Propellor/Container.hs new file mode 100644 index 00000000..c4d6f864 --- /dev/null +++ b/src/Propellor/Container.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE DataKinds, TypeFamilies #-} + +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 + +class IsContainer c where + containerProperties :: c -> [ChildProperty] + containerInfo :: c -> Info + setContainerProperties :: c -> [ChildProperty] -> c + +instance IsContainer Host where + 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. +-- +-- The Info of the propertyChildren is adjusted to only include +-- info that should be propagated out to the Property. +-- +-- Any PrivInfo that uses HostContext is adjusted to use the name +-- of the container as its context. +propagateContainer + :: + -- Since the children being added probably have info, + -- require the Property's metatypes to have info. + ( IncludesInfo metatypes ~ 'True + , IsContainer c + ) + => String + -> c + -> Property metatypes + -> Property metatypes +propagateContainer containername c prop = prop + `addChildren` map convert (containerProperties c) + where + convert p = + let n = property (getDesc p) (getSatisfy p) :: Property UnixLike + n' = n + `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 2e914d67..f0035c40 100644 --- a/src/Propellor/Engine.hs +++ b/src/Propellor/Engine.hs @@ -1,11 +1,10 @@ {-# LANGUAGE PackageImports #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} module Propellor.Engine ( mainProperties, runPropellor, - ensureProperty, - ensureProperties, + ensureChildProperties, fromHost, fromHost', onlyProcess, @@ -23,24 +22,26 @@ 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, -- with nice display of what's being done. mainProperties :: Host -> IO () mainProperties host = do - ret <- runPropellor host $ - ensureProperties [ignoreInfo $ infoProperty "overall" (ensureProperties ps) mempty mempty] + ret <- runPropellor host $ ensureChildProperties [toChildProperty overall] messagesDone case ret of FailedChange -> exitWith (ExitFailure 1) _ -> exitWith ExitSuccess where - ps = map ignoreInfo $ hostProperties host + overall :: Property (MetaTypes '[]) + overall = property "overall" $ + ensureChildProperties (hostProperties host) -- | Runs a Propellor action with the specified host. -- @@ -58,14 +59,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 new file mode 100644 index 00000000..ce01d436 --- /dev/null +++ b/src/Propellor/EnsureProperty.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Propellor.EnsureProperty + ( ensureProperty + , property' + , OuterMetaTypesWitness(..) + ) where + +import Propellor.Types +import Propellor.Types.Core +import Propellor.Types.MetaTypes +import Propellor.Exception + +import Data.Monoid +import Prelude + +-- | For when code running in the Propellor monad needs to ensure a +-- Property. +-- +-- Use `property'` to get the `OuterMetaTypesWithness`. For example: +-- +-- > foo = Property Debian +-- > 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 OuterMetaTypesWitness. +-- 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 + :: + ( Cannot_ensureProperty_WithInfo inner ~ 'True + , (Targets inner `NotSuperset` Targets outer) ~ 'CanCombine + ) + => OuterMetaTypesWitness outer + -> Property (MetaTypes inner) + -> Propellor Result +ensureProperty _ = catchPropellor . getSatisfy + +-- The name of this was chosen to make type errors a more understandable. +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 +-- `OuterMetaTypesWitness`. +property' + :: SingI metatypes + => Desc + -> (OuterMetaTypesWitness metatypes -> Propellor Result) + -> Property (MetaTypes metatypes) +property' d a = + 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 OuterMetaTypesWitness metatypes = OuterMetaTypesWitness (MetaTypes metatypes) + +outerMetaTypesWitness :: Property (MetaTypes l) -> OuterMetaTypesWitness l +outerMetaTypesWitness (Property metatypes _ _ _ _) = OuterMetaTypesWitness metatypes diff --git a/src/Propellor/Info.hs b/src/Propellor/Info.hs index 7eb7d4a8..b87369c3 100644 --- a/src/Propellor/Info.hs +++ b/src/Propellor/Info.hs @@ -1,9 +1,30 @@ -{-# LANGUAGE PackageImports #-} - -module Propellor.Info where +{-# LANGUAGE PackageImports, TypeFamilies, DataKinds, PolyKinds #-} + +module Propellor.Info ( + osDebian, + osBuntish, + osFreeBSD, + setInfoProperty, + addInfoProperty, + pureInfoProperty, + pureInfoProperty', + askInfo, + getOS, + ipv4, + ipv6, + alias, + addDNS, + hostMap, + aliasMap, + findHost, + findHostNoAlias, + getAddresses, + hostAddresses, +) where import Propellor.Types import Propellor.Types.Info +import Propellor.Types.MetaTypes import "mtl" Control.Monad.Reader import qualified Data.Set as S @@ -13,21 +34,67 @@ import Data.Monoid import Control.Applicative import Prelude -pureInfoProperty :: (IsInfo v) => Desc -> v -> Property HasInfo -pureInfoProperty desc v = pureInfoProperty' desc (addInfo mempty v) - -pureInfoProperty' :: Desc -> Info -> Property HasInfo -pureInfoProperty' desc i = infoProperty ("has " ++ desc) (return NoChange) i mempty +-- | 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 = setInfoProperty p i + where + p :: Property UnixLike + p = property ("has " ++ desc) (return NoChange) -- | Gets a value from the host's Info. askInfo :: (IsInfo v) => Propellor v -askInfo = asks (getInfo . hostInfo) +askInfo = asks (fromInfo . hostInfo) + +-- | Specifies that a host's operating system is Debian, +-- and further indicates the suite and architecture. +-- +-- This provides info for other Properties, so they can act +-- conditionally on the details of the OS. +-- +-- It also lets the type checker know that all the properties of the +-- host must support Debian. +-- +-- > & osDebian (Stable "jessie") "amd64" +osDebian :: DebianSuite -> Architecture -> Property (HasInfo + Debian) +osDebian suite arch = tightenTargets $ os (System (Debian suite) arch) --- | Specifies the operating system of a host. +-- | Specifies that a host's operating system is a well-known Debian +-- derivative founded by a space tourist. -- --- This only provides info for other Properties, so they can act --- conditionally on the os. -os :: System -> Property HasInfo +-- (The actual name of this distribution is not used in Propellor per +-- ) +osBuntish :: Release -> Architecture -> Property (HasInfo + Buntish) +osBuntish release arch = tightenTargets $ os (System (Buntish release) arch) + +-- | Specifies that a host's operating system is FreeBSD +-- and further indicates the release and architecture. +osFreeBSD :: FreeBSDRelease -> Architecture -> Property (HasInfo + FreeBSD) +osFreeBSD release arch = tightenTargets $ os (System (FreeBSD release) arch) + +os :: System -> Property (HasInfo + UnixLike) os system = pureInfoProperty ("Operating " ++ show system) (InfoVal system) -- Gets the operating system of a host, if it has been specified. @@ -43,11 +110,11 @@ getOS = fromInfoVal <$> askInfo -- When propellor --spin is used to deploy a host, it checks -- if the host's IP Property matches the DNS. If the DNS is missing or -- out of date, the host will instead be contacted directly by IP address. -ipv4 :: String -> Property HasInfo +ipv4 :: String -> Property (HasInfo + UnixLike) ipv4 = addDNS . Address . IPv4 -- | Indicate that a host has an AAAA record in the DNS. -ipv6 :: String -> Property HasInfo +ipv6 :: String -> Property (HasInfo + UnixLike) ipv6 = addDNS . Address . IPv6 -- | Indicates another name for the host in the DNS. @@ -56,14 +123,14 @@ ipv6 = addDNS . Address . IPv6 -- to use their address, rather than using a CNAME. This avoids various -- problems with CNAMEs, and also means that when multiple hosts have the -- same alias, a DNS round-robin is automatically set up. -alias :: Domain -> Property HasInfo +alias :: Domain -> Property (HasInfo + UnixLike) alias d = pureInfoProperty' ("alias " ++ d) $ mempty `addInfo` toAliasesInfo [d] -- A CNAME is added here, but the DNS setup code converts it to an -- IP address when that makes sense. `addInfo` (toDnsInfo $ S.singleton $ CNAME $ AbsDomain d) -addDNS :: Record -> Property HasInfo +addDNS :: Record -> Property (HasInfo + UnixLike) addDNS r = pureInfoProperty (rdesc r) (toDnsInfo (S.singleton r)) where rdesc (CNAME d) = unwords ["alias", ddesc d] @@ -86,7 +153,7 @@ hostMap l = M.fromList $ zip (map hostName l) l aliasMap :: [Host] -> M.Map HostName Host aliasMap = M.fromList . concat . - map (\h -> map (\aka -> (aka, h)) $ fromAliasesInfo $ getInfo $ hostInfo h) + map (\h -> map (\aka -> (aka, h)) $ fromAliasesInfo $ fromInfo $ hostInfo h) findHost :: [Host] -> HostName -> Maybe Host findHost l hn = (findHostNoAlias l hn) <|> (findAlias l hn) @@ -98,10 +165,7 @@ findAlias :: [Host] -> HostName -> Maybe Host findAlias l hn = M.lookup hn (aliasMap l) getAddresses :: Info -> [IPAddr] -getAddresses = mapMaybe getIPAddr . S.toList . fromDnsInfo . getInfo +getAddresses = mapMaybe getIPAddr . S.toList . fromDnsInfo . fromInfo hostAddresses :: HostName -> [Host] -> [IPAddr] hostAddresses hn hosts = maybe [] (getAddresses . hostInfo) (findHost hosts hn) - -addHostInfo ::IsInfo v => Host -> v -> Host -addHostInfo h v = h { hostInfo = addInfo (hostInfo h) v } diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs index bc09f0c6..d3bb3a6d 100644 --- a/src/Propellor/PrivData.hs +++ b/src/Propellor/PrivData.hs @@ -2,6 +2,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} module Propellor.PrivData ( withPrivData, @@ -40,6 +42,7 @@ import Prelude import Propellor.Types import Propellor.Types.PrivData +import Propellor.Types.MetaTypes import Propellor.Types.Info import Propellor.Message import Propellor.Info @@ -75,29 +78,41 @@ import Utility.FileSystemEncoding -- being used, which is necessary to ensure that the privdata is sent to -- the remote host by propellor. withPrivData - :: (IsContext c, IsPrivDataSource s, IsProp (Property i)) + :: + ( IsContext c + , IsPrivDataSource s + , IncludesInfo metatypes ~ 'True + ) => s -> c - -> (((PrivData -> Propellor Result) -> Propellor Result) -> Property i) - -> Property HasInfo + -> (((PrivData -> Propellor Result) -> Propellor Result) -> Property metatypes) + -> Property metatypes withPrivData s = withPrivData' snd [s] -- Like withPrivData, but here any one of a list of PrivDataFields can be used. withSomePrivData - :: (IsContext c, IsPrivDataSource s, IsProp (Property i)) + :: + ( IsContext c + , IsPrivDataSource s + , IncludesInfo metatypes ~ 'True + ) => [s] -> c - -> ((((PrivDataField, PrivData) -> Propellor Result) -> Propellor Result) -> Property i) - -> Property HasInfo + -> ((((PrivDataField, PrivData) -> Propellor Result) -> Propellor Result) -> Property metatypes) + -> Property metatypes withSomePrivData = withPrivData' id withPrivData' - :: (IsContext c, IsPrivDataSource s, IsProp (Property i)) + :: + ( IsContext c + , IsPrivDataSource s + , IncludesInfo metatypes ~ 'True + ) => ((PrivDataField, PrivData) -> v) -> [s] -> c - -> (((v -> Propellor Result) -> Propellor Result) -> Property i) - -> Property HasInfo + -> (((v -> Propellor Result) -> Propellor Result) -> Property metatypes) + -> Property metatypes withPrivData' feed srclist c mkprop = addinfo $ mkprop $ \a -> maybe missing (a . feed) =<< getM get fieldlist where @@ -112,11 +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 = infoProperty - (propertyDesc p) - (propertySatisfy p) - (propertyInfo p `addInfo` privset) - (propertyChildren p) + addinfo p = p `addInfoProperty` (toInfo privset) privset = PrivInfo $ S.fromList $ map (\s -> (privDataField s, describePrivDataSource s, hc)) srclist fieldnames = map show fieldlist @@ -132,7 +143,7 @@ showSet = concatMap go , Just "" ] -addPrivData :: (PrivDataField, Maybe PrivDataSourceDesc, HostContext) -> Property HasInfo +addPrivData :: (PrivDataField, Maybe PrivDataSourceDesc, HostContext) -> Property (HasInfo + UnixLike) addPrivData v = pureInfoProperty (show v) (PrivInfo (S.singleton v)) {- Gets the requested field's value, in the specified context if it's @@ -150,7 +161,7 @@ filterPrivData :: Host -> PrivMap -> PrivMap filterPrivData host = M.filterWithKey (\k _v -> S.member k used) where used = S.map (\(f, _, c) -> (f, mkHostContext c (hostName host))) $ - fromPrivInfo $ getInfo $ hostInfo host + fromPrivInfo $ fromInfo $ hostInfo host getPrivData :: PrivDataField -> Context -> PrivMap -> Maybe PrivData getPrivData field context m = do @@ -234,7 +245,7 @@ mkUsedByMap = M.unionsWith (++) . map (\h -> mkPrivDataMap h $ const [hostName h mkPrivDataMap :: Host -> (Maybe PrivDataSourceDesc -> a) -> M.Map (PrivDataField, Context) a mkPrivDataMap host mkv = M.fromList $ map (\(f, d, c) -> ((f, mkHostContext c (hostName host)), mkv d)) - (S.toList $ fromPrivInfo $ getInfo $ hostInfo host) + (S.toList $ fromPrivInfo $ fromInfo $ hostInfo host) setPrivDataTo :: PrivDataField -> Context -> PrivData -> IO () setPrivDataTo field context (PrivData value) = do diff --git a/src/Propellor/PropAccum.hs b/src/Propellor/PropAccum.hs index 85a30af5..d9fa8ec7 100644 --- a/src/Propellor/PropAccum.hs +++ b/src/Propellor/PropAccum.hs @@ -1,88 +1,86 @@ -{-# LANGUAGE PackageImports, FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DataKinds #-} module Propellor.PropAccum ( host - , PropAccum(..) + , Props(..) + , props , (&) , (&^) , (!) - , propagateContainer ) where -import Data.Monoid - import Propellor.Types +import Propellor.Types.MetaTypes +import Propellor.Types.Core import Propellor.Property -import Propellor.Types.Info -import Propellor.PrivData --- | Starts accumulating the properties of a Host. +import Data.Monoid +import Prelude + +-- | Defines a host and its properties. -- --- > host "example.com" +-- > host "example.com" $ props -- > & someproperty -- > ! oldproperty -- > & otherproperty -host :: HostName -> Host -host hn = Host hn [] mempty +host :: HostName -> Props metatypes -> Host +host hn (Props ps) = Host hn ps (mconcat (map getInfoRecursive ps)) --- | Something that can accumulate properties. -class PropAccum h where - -- | Adds a property. - addProp :: IsProp p => h -> p -> h +-- | Start accumulating a list of properties. +-- +-- Properties can be added to it using `(&)` etc. +props :: Props UnixLike +props = Props [] - -- | Like addProp, but adds the property at the front of the list. - addPropFront :: IsProp p => h -> p -> h +infixl 1 & +infixl 1 &^ +infixl 1 ! - getProperties :: h -> [Property HasInfo] +type family GetMetaTypes x +type instance GetMetaTypes (Property (MetaTypes t)) = MetaTypes t +type instance GetMetaTypes (RevertableProperty (MetaTypes t) undo) = MetaTypes t --- | Adds a property to a `Host` or other `PropAccum` +-- | Adds a property to a Props. -- -- Can add Properties and RevertableProperties -(&) :: (PropAccum h, IsProp p) => h -> p -> h -(&) = addProp +(&) + :: + ( IsProp p + , MetaTypes y ~ GetMetaTypes p + , CheckCombinable x y ~ 'CanCombine + ) + => Props (MetaTypes x) + -> p + -> Props (MetaTypes (Combine x y)) +Props c & p = Props (c ++ [toChildProperty p]) -- | Adds a property before any other properties. -(&^) :: (PropAccum h, IsProp p) => h -> p -> h -(&^) = addPropFront +(&^) + :: + ( IsProp p + , MetaTypes y ~ GetMetaTypes p + , CheckCombinable x y ~ 'CanCombine + ) + => Props (MetaTypes x) + -> p + -> Props (MetaTypes (Combine x y)) +Props c &^ p = Props (toChildProperty p : c) -- | Adds a property in reverted form. -(!) :: IsProp (RevertableProperty i) => PropAccum h => h -> RevertableProperty i -> h -h ! p = h & revert p +(!) + :: (CheckCombinable x z ~ 'CanCombine) + => Props (MetaTypes x) + -> RevertableProperty (MetaTypes y) (MetaTypes z) + -> Props (MetaTypes (Combine x z)) +Props c ! p = Props (c ++ [toChildProperty (revert p)]) -infixl 1 & -infixl 1 &^ -infixl 1 ! - -instance PropAccum Host where - (Host hn ps is) `addProp` p = Host hn (ps ++ [toProp p]) - (is <> getInfoRecursive p) - (Host hn ps is) `addPropFront` p = Host hn (toProp p : ps) - (getInfoRecursive p <> is) - getProperties = hostProperties - --- | Adjust the provided Property, adding to its --- propertyChidren the properties of the provided container. --- --- The Info of the propertyChildren is adjusted to only include --- info that should be propagated out to the Property. --- --- Any PrivInfo that uses HostContext is adjusted to use the name --- of the container as its context. -propagateContainer - :: (PropAccum container) - => String - -> container - -> Property HasInfo - -> Property HasInfo -propagateContainer containername c prop = infoProperty - (propertyDesc prop) - (propertySatisfy prop) - (propertyInfo prop) - (propertyChildren prop ++ hostprops) - where - hostprops = map go $ getProperties c - go p = - let i = mapInfo (forceHostContext containername) - (propagatableInfo (propertyInfo p)) - cs = map go (propertyChildren p) - in infoProperty (propertyDesc p) (propertySatisfy p) i cs +-- addPropsHost :: Host -> [Prop] -> Host +-- addPropsHost (Host hn ps i) p = Host hn ps' i' +-- where +-- ps' = ps ++ [toChildProperty p] +-- i' = i <> getInfoRecursive p diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs index b6b8dc0d..55c39ee2 100644 --- a/src/Propellor/Property.hs +++ b/src/Propellor/Property.hs @@ -1,5 +1,9 @@ {-# LANGUAGE PackageImports #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PolyKinds #-} module Propellor.Property ( -- * Property combinators @@ -18,9 +22,13 @@ module Propellor.Property ( -- * Constructing properties , Propellor , property + , property' + , OuterMetaTypesWitness , ensureProperty + , pickOS , withOS , unsupportedOS + , unsupportedOS' , makeChange , noChange , doNothing @@ -44,22 +52,21 @@ 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 import Propellor.Types +import Propellor.Types.Core import Propellor.Types.ResultCheck +import Propellor.Types.MetaTypes +import Propellor.Types.Singletons import Propellor.Info -import Propellor.Exception +import Propellor.EnsureProperty 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. @@ -164,13 +171,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 @@ -249,28 +249,96 @@ isNewerThan x y = do where mtime f = catchMaybeIO $ modificationTimeHiRes <$> getFileStatus f --- | Makes a property that is satisfied differently depending on the host's --- operating system. +-- | 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. -- --- Note that the operating system may not be declared for all hosts. +-- 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. -- --- > 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 +-- 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. +pickOS + :: + ( SingKind ('KProxy :: KProxy ka) + , SingKind ('KProxy :: KProxy kb) + , DemoteRep ('KProxy :: KProxy ka) ~ [MetaType] + , DemoteRep ('KProxy :: KProxy kb) ~ [MetaType] + , SingI c + -- 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 :: 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 = 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. +-- +-- > myproperty :: Property Debian +-- > 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, +-- which is where Nothing comes in. +withOS + :: (SingI metatypes) + => Desc + -> (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 :: OuterMetaTypesWitness ('[]) + dummyoutermetatypes = OuterMetaTypesWitness sing + +-- | 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. -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 +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 -- | 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 +347,7 @@ makeChange a = liftIO a >> return MadeChange noChange :: Propellor Result noChange = return NoChange -doNothing :: Property NoInfo +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/Aiccu.hs b/src/Propellor/Property/Aiccu.hs index 47841a7b..1b28759c 100644 --- a/src/Propellor/Property/Aiccu.hs +++ b/src/Propellor/Property/Aiccu.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TypeFamilies #-} + -- | Maintainer: Jelmer Vernooij module Propellor.Property.Aiccu ( @@ -14,10 +16,10 @@ import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Service as Service import qualified Propellor.Property.File as File -installed :: Property NoInfo +installed :: Property DebianLike installed = Apt.installed ["aiccu"] -restarted :: Property NoInfo +restarted :: Property DebianLike restarted = Service.restarted "aiccu" confPath :: FilePath @@ -41,12 +43,12 @@ config u t p = -- | Configures an ipv6 tunnel using sixxs.net, with the given TunneId -- and sixx.net UserName. -hasConfig :: TunnelId -> UserName -> Property HasInfo -hasConfig t u = prop `onChange` restarted +hasConfig :: TunnelId -> UserName -> Property (HasInfo + DebianLike) +hasConfig t u = prop `onChange` restarted where + prop :: Property (HasInfo + UnixLike) prop = withSomePrivData [(Password (u++"/"++t)), (Password u)] (Context "aiccu") $ - property "aiccu configured" . writeConfig - writeConfig :: (((PrivDataField, PrivData) -> Propellor Result) -> Propellor Result) -> Propellor Result - writeConfig getpassword = getpassword $ ensureProperty . go + property' "aiccu configured" . writeConfig + writeConfig getpassword w = getpassword $ ensureProperty w . go go (Password u', p) = confPath `File.hasContentProtected` config u' t p go (f, _) = error $ "Unexpected type of privdata: " ++ show f diff --git a/src/Propellor/Property/Apache.hs b/src/Propellor/Property/Apache.hs index e107cb9f..f321143f 100644 --- a/src/Propellor/Property/Apache.hs +++ b/src/Propellor/Property/Apache.hs @@ -6,50 +6,50 @@ import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Service as Service import qualified Propellor.Property.LetsEncrypt as LetsEncrypt -installed :: Property NoInfo +installed :: Property DebianLike installed = Apt.installed ["apache2"] -restarted :: Property NoInfo +restarted :: Property DebianLike restarted = Service.restarted "apache2" -reloaded :: Property NoInfo +reloaded :: Property DebianLike reloaded = Service.reloaded "apache2" type ConfigLine = String type ConfigFile = [ConfigLine] -siteEnabled :: Domain -> ConfigFile -> RevertableProperty NoInfo +siteEnabled :: Domain -> ConfigFile -> RevertableProperty DebianLike DebianLike siteEnabled domain cf = siteEnabled' domain cf siteDisabled domain -siteEnabled' :: Domain -> ConfigFile -> Property NoInfo -siteEnabled' domain cf = combineProperties ("apache site enabled " ++ domain) - [ siteAvailable domain cf +siteEnabled' :: Domain -> ConfigFile -> Property DebianLike +siteEnabled' domain cf = combineProperties ("apache site enabled " ++ domain) $ props + & siteAvailable domain cf `requires` installed `onChange` reloaded - , check (not <$> isenabled) + & check (not <$> isenabled) (cmdProperty "a2ensite" ["--quiet", domain]) `requires` installed `onChange` reloaded - ] where isenabled = boolSystem "a2query" [Param "-q", Param "-s", Param domain] -siteDisabled :: Domain -> Property NoInfo +siteDisabled :: Domain -> Property DebianLike siteDisabled domain = combineProperties ("apache site disabled " ++ domain) - (map File.notPresent (siteCfg domain)) + (toProps $ map File.notPresent (siteCfg domain)) `onChange` (cmdProperty "a2dissite" ["--quiet", domain] `assume` MadeChange) `requires` installed `onChange` reloaded -siteAvailable :: Domain -> ConfigFile -> Property NoInfo +siteAvailable :: Domain -> ConfigFile -> Property DebianLike siteAvailable domain cf = combineProperties ("apache site available " ++ domain) $ - map (`File.hasContent` (comment:cf)) (siteCfg domain) + toProps $ map tightenTargets $ + map (`File.hasContent` (comment:cf)) (siteCfg domain) where comment = "# deployed with propellor, do not modify" -modEnabled :: String -> RevertableProperty NoInfo +modEnabled :: String -> RevertableProperty DebianLike DebianLike modEnabled modname = enable disable where enable = check (not <$> isenabled) @@ -68,7 +68,7 @@ modEnabled modname = enable disable -- -- Note that ports are also specified inside a site's config file, -- so that also needs to be changed. -listenPorts :: [Port] -> Property NoInfo +listenPorts :: [Port] -> Property DebianLike listenPorts ps = "/etc/apache2/ports.conf" `File.hasContent` map portline ps `onChange` restarted where @@ -89,7 +89,7 @@ siteCfg domain = -- -- This was off by default in apache 2.2.22. Newver versions enable -- it by default. This property uses the filename used by the old version. -multiSSL :: Property NoInfo +multiSSL :: Property DebianLike multiSSL = check (doesDirectoryExist "/etc/apache2/conf.d") $ "/etc/apache2/conf.d/ssl" `File.hasContent` [ "NameVirtualHost *:443" @@ -129,11 +129,11 @@ type WebRoot = FilePath -- | A basic virtual host, publishing a directory, and logging to -- the combined apache log file. Not https capable. -virtualHost :: Domain -> Port -> WebRoot -> RevertableProperty NoInfo +virtualHost :: Domain -> Port -> WebRoot -> RevertableProperty DebianLike DebianLike virtualHost domain port docroot = virtualHost' domain port docroot [] -- | Like `virtualHost` but with additional config lines added. -virtualHost' :: Domain -> Port -> WebRoot -> [ConfigLine] -> RevertableProperty NoInfo +virtualHost' :: Domain -> Port -> WebRoot -> [ConfigLine] -> RevertableProperty DebianLike DebianLike virtualHost' domain port docroot addedcfg = siteEnabled domain $ [ "" , "ServerName " ++ domain ++ ":" ++ fromPort port @@ -159,11 +159,11 @@ virtualHost' domain port docroot addedcfg = siteEnabled domain $ -- -- Note that reverting this property does not remove the certificate from -- letsencrypt's cert store. -httpsVirtualHost :: Domain -> WebRoot -> LetsEncrypt.AgreeTOS -> RevertableProperty NoInfo +httpsVirtualHost :: Domain -> WebRoot -> LetsEncrypt.AgreeTOS -> RevertableProperty DebianLike DebianLike httpsVirtualHost domain docroot letos = httpsVirtualHost' domain docroot letos [] -- | Like `httpsVirtualHost` but with additional config lines added. -httpsVirtualHost' :: Domain -> WebRoot -> LetsEncrypt.AgreeTOS -> [ConfigLine] -> RevertableProperty NoInfo +httpsVirtualHost' :: Domain -> WebRoot -> LetsEncrypt.AgreeTOS -> [ConfigLine] -> RevertableProperty DebianLike DebianLike httpsVirtualHost' domain docroot letos addedcfg = setup teardown where setup = setuphttp @@ -185,13 +185,13 @@ httpsVirtualHost' domain docroot letos addedcfg = setup teardown , "RewriteRule ^/(.*) https://" ++ domain ++ "/$1 [L,R,NE]" ] setuphttps = LetsEncrypt.letsEncrypt letos domain docroot - `onChange` combineProperties (domain ++ " ssl cert installed") - [ File.dirExists (takeDirectory cf) - , File.hasContent cf sslvhost - `onChange` reloaded - -- always reload since the cert has changed - , reloaded - ] + `onChange` postsetuphttps + postsetuphttps = combineProperties (domain ++ " ssl cert installed") $ props + & File.dirExists (takeDirectory cf) + & File.hasContent cf sslvhost + `onChange` reloaded + -- always reload since the cert has changed + & reloaded where cf = sslconffile "letsencrypt" sslvhost = vhost (Port 443) diff --git a/src/Propellor/Property/Apt.hs b/src/Propellor/Property/Apt.hs index 7301a6ae..1a15f72c 100644 --- a/src/Propellor/Property/Apt.hs +++ b/src/Propellor/Property/Apt.hs @@ -75,42 +75,41 @@ securityUpdates suite in [l, srcLine l] | otherwise = [] --- | Makes sources.list have a standard content using the mirror CDN, +-- | Makes sources.list have a standard content using the Debian mirror CDN, -- with the Debian suite configured by the os. -- -- 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" $ \w o -> case o of + (Just (System (Debian suite) _)) -> + ensureProperty w $ 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,66 +117,66 @@ 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 Debian +installedBackport ps = withOS desc $ \w o -> case o of (Just (System (Debian suite) _)) -> case backportSuite suite of - Nothing -> unsupportedOS - Just bs -> ensureProperty $ + Nothing -> unsupportedOS' + Just bs -> ensureProperty w $ runApt (["install", "-t", bs, "-y"] ++ ps) `changesFile` dpkgStatus - _ -> unsupportedOS + _ -> unsupportedOS' where 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,14 +195,8 @@ 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 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 - else return r +robustly :: Property DebianLike -> Property DebianLike +robustly p = p `fallback` (update `before` p) isInstallable :: [Package] -> IO Bool isInstallable ps = do @@ -228,13 +221,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 +246,12 @@ unattendedUpgrades = enable disable | enabled = "true" | otherwise = "false" - configure = withOS "unattended upgrades configured" $ \o -> + configure :: Property DebianLike + 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 $ + | not (isStable suite) -> ensureProperty w $ "/etc/apt/apt.conf.d/50unattended-upgrades" `File.containsLine` ("Unattended-Upgrade::Origins-Pattern { \"o=Debian,a="++showSuite suite++"\"; };") @@ -269,10 +263,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 +286,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 +294,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 +308,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/Chroot.hs b/src/Propellor/Property/Chroot.hs index 378836e8..09047ce5 100644 --- a/src/Propellor/Property/Chroot.hs +++ b/src/Propellor/Property/Chroot.hs @@ -19,9 +19,11 @@ module Propellor.Property.Chroot ( ) where import Propellor.Base +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 @@ -40,24 +42,24 @@ import System.Console.Concurrent 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) + chrootSystem :: Chroot -> Maybe System -chrootSystem (Chroot _ _ h) = fromInfoVal (getInfo (hostInfo h)) +chrootSystem = fromInfoVal . fromInfo . containerInfo instance Show Chroot where show c@(Chroot loc _ _) = "Chroot " ++ loc ++ " " ++ show (chrootSystem c) -instance PropAccum Chroot where - (Chroot l c h) `addProp` p = Chroot l c (h & p) - (Chroot l c h) `addPropFront` p = Chroot l c (h `addPropFront` p) - getProperties (Chroot _ _ h) = hostProperties h - -- | Class of things that can do initial bootstrapping of an operating -- System in a chroot. class ChrootBootstrapper b where -- | Do initial bootstrapping of an operating system in a chroot. -- If the operating System is not supported, return -- Left error message. - buildchroot :: b -> Maybe System -> FilePath -> Either String (Property HasInfo) + buildchroot :: b -> Maybe System -> FilePath -> Either String (Property Linux) -- | Use this to bootstrap a chroot by extracting a tarball. -- @@ -68,14 +70,14 @@ class ChrootBootstrapper b where data ChrootTarball = ChrootTarball FilePath instance ChrootBootstrapper ChrootTarball where - buildchroot (ChrootTarball tb) _ loc = Right $ extractTarball loc tb - -extractTarball :: FilePath -> FilePath -> Property HasInfo -extractTarball target src = toProp . - check (unpopulated target) $ - cmdProperty "tar" params - `assume` MadeChange - `requires` File.dirExists target + buildchroot (ChrootTarball tb) _ loc = Right $ + tightenTargets $ extractTarball loc tb + +extractTarball :: FilePath -> FilePath -> Property UnixLike +extractTarball target src = check (unpopulated target) $ + cmdProperty "tar" params + `assume` MadeChange + `requires` File.dirExists target where params = [ "-C" @@ -92,28 +94,27 @@ instance ChrootBootstrapper Debootstrapped where (Just s@(System (Debian _) _)) -> Right $ debootstrap s (Just s@(System (Buntish _) _)) -> Right $ debootstrap s (Just (System (FreeBSD _) _)) -> Left "FreeBSD not supported by debootstrap." - Nothing -> Left "Cannot debootstrap; `os` property not specified" + Nothing -> Left "Cannot debootstrap; OS not specified" where debootstrap s = Debootstrap.built loc s cf -- | Defines a Chroot at the given location, built with debootstrap. -- -- Properties can be added to configure the Chroot. At a minimum, --- add the `os` property to specify the operating system to bootstrap. +-- add a property such as `osDebian` to specify the operating system +-- to bootstrap. -- --- > debootstrapped Debootstrap.BuildD "/srv/chroot/ghc-dev" --- > & os (System (Debian Unstable) "amd64") +-- > debootstrapped Debootstrap.BuildD "/srv/chroot/ghc-dev" $ props +-- > & osDebian Unstable "amd64" -- > & Apt.installed ["ghc", "haskell-platform"] -- > & ... -debootstrapped :: Debootstrap.DebootstrapConfig -> FilePath -> Chroot +debootstrapped :: Debootstrap.DebootstrapConfig -> FilePath -> Props metatypes -> Chroot 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 - where - h = Host location [] mempty +bootstrapped :: ChrootBootstrapper b => b -> FilePath -> Props metatypes -> Chroot +bootstrapped bootstrapper location ps = Chroot location bootstrapper (host location ps) -- | Ensures that the chroot exists and is provisioned according to its -- properties. @@ -121,43 +122,44 @@ bootstrapped bootstrapper location = Chroot location bootstrapper h -- 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 +provisioned :: Chroot -> RevertableProperty (HasInfo + Linux) Linux provisioned c = provisioned' (propagateChrootInfo c) c False -provisioned' :: (Property HasInfo -> Property HasInfo) -> Chroot -> Bool -> RevertableProperty HasInfo +provisioned' + :: (Property Linux -> Property (HasInfo + Linux)) + -> Chroot + -> Bool + -> RevertableProperty (HasInfo + Linux) Linux provisioned' propigator c@(Chroot loc bootstrapper _) systemdonly = - (propigator $ propertyList (chrootDesc c "exists") [setup]) + (propigator $ setup `describe` chrootDesc c "exists") - (propertyList (chrootDesc c "removed") [teardown]) + (teardown `describe` chrootDesc c "removed") where + setup :: Property Linux setup = propellChroot c (inChrootProcess (not systemdonly) c) systemdonly - `requires` toProp built + `requires` built built = case buildchroot bootstrapper (chrootSystem c) loc of Right p -> p Left e -> cantbuild e - cantbuild e = infoProperty (chrootDesc c "built") (error e) mempty [] + cantbuild e = property (chrootDesc c "built") (error e) + teardown :: Property Linux teardown = check (not <$> unpopulated loc) $ property ("removed " ++ loc) $ makeChange (removeChroot loc) -propagateChrootInfo :: (IsProp (Property i)) => Chroot -> Property i -> Property HasInfo -propagateChrootInfo c@(Chroot location _ _) p = propagateContainer location c p' - where - p' = infoProperty - (propertyDesc p) - (propertySatisfy p) - (propertyInfo p <> chrootInfo c) - (propertyChildren p) +propagateChrootInfo :: Chroot -> Property Linux -> Property (HasInfo + Linux) +propagateChrootInfo c@(Chroot location _ _) p = propagateContainer location c $ + p `setInfoProperty` chrootInfo c chrootInfo :: Chroot -> 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 NoInfo +propellChroot :: Chroot -> ([String] -> IO (CreateProcess, IO ())) -> Bool -> Property UnixLike propellChroot c@(Chroot loc _ _) mkproc systemdonly = property (chrootDesc c "provisioned") $ do let d = localdir shimdir c let me = localdir "propellor" @@ -205,7 +207,7 @@ chain :: [Host] -> CmdLine -> IO () chain hostlist (ChrootChain hn loc systemdonly onconsole) = case findHostNoAlias hostlist hn of Nothing -> errorMessage ("cannot find host " ++ hn) - Just parenthost -> case M.lookup loc (_chroots $ getInfo $ hostInfo parenthost) of + Just parenthost -> case M.lookup loc (_chroots $ fromInfo $ hostInfo parenthost) of Nothing -> errorMessage ("cannot find chroot " ++ loc ++ " on host " ++ hn) Just h -> go h where @@ -213,11 +215,10 @@ chain hostlist (ChrootChain hn loc systemdonly onconsole) = changeWorkingDirectory localdir when onconsole forceConsole onlyProcess (provisioningLock loc) $ do - r <- runPropellor (setInChroot h) $ ensureProperties $ + r <- runPropellor (setInChroot h) $ ensureChildProperties $ if systemdonly - then [Systemd.installed] - else map ignoreInfo $ - hostProperties h + then [toChildProperty Systemd.installed] + else hostProperties h flushConcurrentOutput putStrLn $ "\n" ++ show r chain _ _ = errorMessage "bad chain command" @@ -255,15 +256,17 @@ 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 NoInfo +-- +-- 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" ] - setup = combineProperties "no services started" + setup = combineProperties "no services started" $ toProps [ File.hasContent f script , File.mode f (combineModes (readModes ++ executeModes)) ] diff --git a/src/Propellor/Property/Cmd.hs b/src/Propellor/Property/Cmd.hs index 6da2e643..6b84acb5 100644 --- a/src/Propellor/Property/Cmd.hs +++ b/src/Propellor/Property/Cmd.hs @@ -58,10 +58,10 @@ import Utility.Process (createProcess, CreateProcess, waitForProcess) -- | A property that can be satisfied by running a command. -- -- The command must exit 0 on success. -cmdProperty :: String -> [String] -> UncheckedProperty NoInfo +cmdProperty :: String -> [String] -> UncheckedProperty UnixLike cmdProperty cmd params = cmdProperty' cmd params id -cmdProperty' :: String -> [String] -> (CreateProcess -> CreateProcess) -> UncheckedProperty NoInfo +cmdProperty' :: String -> [String] -> (CreateProcess -> CreateProcess) -> UncheckedProperty UnixLike cmdProperty' cmd params mkprocess = unchecked $ property desc $ liftIO $ cmdResult <$> boolSystem' cmd (map Param params) mkprocess where @@ -74,7 +74,7 @@ cmdResult True = NoChange -- | A property that can be satisfied by running a command, -- with added environment variables in addition to the standard -- environment. -cmdPropertyEnv :: String -> [String] -> [(String, String)] -> UncheckedProperty NoInfo +cmdPropertyEnv :: String -> [String] -> [(String, String)] -> UncheckedProperty UnixLike cmdPropertyEnv cmd params env = unchecked $ property desc $ liftIO $ do env' <- addEntries env <$> getEnvironment cmdResult <$> boolSystemEnv cmd (map Param params) (Just env') @@ -85,14 +85,14 @@ cmdPropertyEnv cmd params env = unchecked $ property desc $ liftIO $ do type Script = [String] -- | A property that can be satisfied by running a script. -scriptProperty :: Script -> UncheckedProperty NoInfo +scriptProperty :: Script -> UncheckedProperty UnixLike scriptProperty script = cmdProperty "sh" ["-c", shellcmd] where shellcmd = intercalate " ; " ("set -e" : script) -- | A property that can satisfied by running a script -- as user (cd'd to their home directory). -userScriptProperty :: User -> Script -> UncheckedProperty NoInfo +userScriptProperty :: User -> Script -> UncheckedProperty UnixLike userScriptProperty (User user) script = cmdProperty "su" ["--shell", "/bin/sh", "-c", shellcmd, user] where shellcmd = intercalate " ; " ("set -e" : "cd" : script) diff --git a/src/Propellor/Property/Concurrent.hs b/src/Propellor/Property/Concurrent.hs index 74afecc4..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 @@ -77,8 +79,8 @@ concurrently p1 p2 = (combineWith go go p1 p2) -- -- The above example will run foo and bar concurrently, and once either of -- those 2 properties finishes, will start running baz. -concurrentList :: IO Int -> Desc -> PropList -> Property HasInfo -concurrentList getn d (PropList ps) = infoProperty d go mempty ps +concurrentList :: SingI metatypes => IO Int -> Desc -> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes) +concurrentList getn d (Props ps) = property d go `addChildren` ps where go = do n <- liftIO getn @@ -97,15 +99,11 @@ 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 - -- Info asociated with the property, because - -- concurrentList sets all the properties as - -- children, and so propigates their info. Just p -> do hn <- asks hostName r' <- actionMessageOn hn - (propertyDesc p) - (propertySatisfy p) + (getDesc 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/Conductor.hs b/src/Propellor/Property/Conductor.hs index 0d275b91..8aa18d20 100644 --- a/src/Propellor/Property/Conductor.hs +++ b/src/Propellor/Property/Conductor.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleInstances, DeriveDataTypeable, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances, DeriveDataTypeable, GeneralizedNewtypeDeriving, TypeFamilies #-} -- | This module adds conductors to propellor. A conductor is a Host that -- is responsible for running propellor on other hosts @@ -73,7 +73,8 @@ module Propellor.Property.Conductor ( Conductable(..), ) where -import Propellor.Base hiding (os) +import Propellor.Base +import Propellor.Container import Propellor.Spin (spin') import Propellor.PrivData.Paths import Propellor.Types.Info @@ -82,21 +83,22 @@ 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 + 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 (map (toProp . conducts) hs) + propertyList desc (toProps $ map (setupRevertableProperty . conducts) hs) - propertyList desc (map (toProp . revert . conducts) hs) + propertyList desc (toProps $ map (undoRevertableProperty . conducts) hs) where desc = cdesc $ unwords $ map hostName hs @@ -126,7 +128,7 @@ mkOrchestra = fromJust . go S.empty where go seen h | S.member (hostName h) seen = Nothing -- break loop - | otherwise = Just $ case getInfo (hostInfo h) of + | otherwise = Just $ case fromInfo (hostInfo h) of ConductorFor [] -> Conducted h ConductorFor l -> let seen' = S.insert (hostName h) seen @@ -214,14 +216,15 @@ orchestrate :: [Host] -> [Host] orchestrate hs = map go hs where go h - | isOrchestrated (getInfo (hostInfo h)) = h + | isOrchestrated (fromInfo (hostInfo h)) = h | otherwise = foldl orchestrate' (removeold h) (map (deloop h) os) os = extractOrchestras hs removeold h = foldl removeold' h (oldconductorsof h) - removeold' h oldconductor = h & revert (conductedBy oldconductor) + removeold' h oldconductor = setContainerProps h $ containerProps h + ! conductedBy oldconductor - oldconductors = zip hs (map (getInfo . hostInfo) hs) + oldconductors = zip hs (map (fromInfo . hostInfo) hs) oldconductorsof h = flip mapMaybe oldconductors $ \(oldconductor, NotConductorFor l) -> if any (sameHost h) l @@ -232,7 +235,9 @@ orchestrate' :: Host -> Orchestra -> Host 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 $ h & conductedBy c + | any (sameHost h) (map topHost l) = cont $ + setContainerProps h $ containerProps h + & conductedBy c | otherwise = cont h where cont h' = foldl orchestrate' h' l @@ -240,14 +245,16 @@ orchestrate' h (Conductor c l) -- The host this property is added to becomes the conductor for the -- specified Host. Note that `orchestrate` must be used for this property -- to have any effect. -conductorFor :: Host -> Property HasInfo -conductorFor h = infoProperty desc go (addInfo mempty (ConductorFor [h])) [] - `requires` toProp (conductorKnownHost h) +conductorFor :: Host -> Property (HasInfo + UnixLike) +conductorFor h = go + `setInfoProperty` (toInfo (ConductorFor [h])) + `requires` setupRevertableProperty (conductorKnownHost h) `requires` Ssh.installed where desc = cdesc (hostName h) - go = ifM (isOrchestrated <$> askInfo) + go :: Property UnixLike + go = property desc $ ifM (isOrchestrated <$> askInfo) ( do pm <- liftIO $ filterPrivData h <$> readPrivDataFile privDataLocal @@ -262,13 +269,15 @@ conductorFor h = infoProperty desc go (addInfo mempty (ConductorFor [h])) [] ) -- Reverts conductorFor. -notConductorFor :: Host -> Property HasInfo -notConductorFor h = infoProperty desc (return NoChange) (addInfo mempty (NotConductorFor [h])) [] - `requires` toProp (revert (conductorKnownHost h)) +notConductorFor :: Host -> Property (HasInfo + UnixLike) +notConductorFor h = (doNothing :: Property UnixLike) + `setInfoProperty` (toInfo (NotConductorFor [h])) + `describe` desc + `requires` undoRevertableProperty (conductorKnownHost h) where desc = "not " ++ cdesc (hostName h) -conductorKnownHost :: Host -> RevertableProperty NoInfo +conductorKnownHost :: Host -> RevertableProperty UnixLike UnixLike conductorKnownHost h = mk Ssh.knownHost @@ -287,10 +296,10 @@ addConductorPrivData h hs = h { hostInfo = hostInfo h <> i } i = mempty `addInfo` mconcat (map privinfo hs) `addInfo` Orchestrated (Any True) - privinfo h' = forceHostContext (hostName h') $ getInfo (hostInfo h') + privinfo h' = forceHostContext (hostName h') $ fromInfo (hostInfo h') -- Use this property to let the specified conductor ssh in and run propellor. -conductedBy :: Host -> RevertableProperty NoInfo +conductedBy :: Host -> RevertableProperty UnixLike UnixLike conductedBy h = (setup teardown) `describe` ("conducted by " ++ hostName h) where diff --git a/src/Propellor/Property/ConfFile.hs b/src/Propellor/Property/ConfFile.hs index dac4e564..270e04f1 100644 --- a/src/Propellor/Property/ConfFile.hs +++ b/src/Propellor/Property/ConfFile.hs @@ -37,7 +37,7 @@ adjustSection -> AdjustSection -> InsertSection -> FilePath - -> Property NoInfo + -> Property UnixLike adjustSection desc start past adjust insert = fileProperty desc go where go ls = let (pre, wanted, post) = foldl' find ([], [], []) ls @@ -68,7 +68,7 @@ adjustIniSection -> AdjustSection -> InsertSection -> FilePath - -> Property NoInfo + -> Property UnixLike adjustIniSection desc header = adjustSection desc @@ -77,7 +77,7 @@ adjustIniSection desc header = -- | Ensures that a .ini file exists and contains a section -- with a key=value setting. -containsIniSetting :: FilePath -> (IniSection, IniKey, String) -> Property NoInfo +containsIniSetting :: FilePath -> (IniSection, IniKey, String) -> Property UnixLike containsIniSetting f (header, key, value) = adjustIniSection (f ++ " section [" ++ header ++ "] contains " ++ key ++ "=" ++ value) @@ -93,7 +93,7 @@ containsIniSetting f (header, key, value) = isKeyVal x = (filter (/= ' ') . takeWhile (/= '=')) x `elem` [key, '#':key] -- | Ensures that a .ini file does not contain the specified section. -lacksIniSection :: FilePath -> IniSection -> Property NoInfo +lacksIniSection :: FilePath -> IniSection -> Property UnixLike lacksIniSection f header = adjustIniSection (f ++ " lacks section [" ++ header ++ "]") diff --git a/src/Propellor/Property/Cron.hs b/src/Propellor/Property/Cron.hs index 365e2903..0966a7e5 100644 --- a/src/Propellor/Property/Cron.hs +++ b/src/Propellor/Property/Cron.hs @@ -27,9 +27,11 @@ data Times -- job file. -- -- The cron job's output will only be emailed if it exits nonzero. -job :: Desc -> Times -> User -> FilePath -> String -> Property NoInfo -job desc times (User u) cddir command = combineProperties ("cronned " ++ desc) - [ cronjobfile `File.hasContent` +job :: Desc -> Times -> User -> FilePath -> String -> Property DebianLike +job desc times (User u) cddir command = combineProperties ("cronned " ++ desc) $ props + & Apt.serviceInstalledRunning "cron" + & Apt.installed ["util-linux", "moreutils"] + & cronjobfile `File.hasContent` [ case times of Times _ -> "" _ -> "#!/bin/sh\nset -e" @@ -44,22 +46,19 @@ job desc times (User u) cddir command = combineProperties ("cronned " ++ desc) "root" -> "chronic " ++ shellEscape scriptfile _ -> "chronic su " ++ u ++ " -c " ++ shellEscape scriptfile ] - , case times of + & case times of Times _ -> doNothing _ -> cronjobfile `File.mode` combineModes (readModes ++ executeModes) -- Use a separate script because it makes the cron job name -- prettier in emails, and also allows running the job manually. - , scriptfile `File.hasContent` + & scriptfile `File.hasContent` [ "#!/bin/sh" , "# Generated by propellor" , "set -e" , "flock -n " ++ shellEscape cronjobfile ++ " sh -c " ++ shellEscape cmdline ] - , scriptfile `File.mode` combineModes (readModes ++ executeModes) - ] - `requires` Apt.serviceInstalledRunning "cron" - `requires` Apt.installed ["util-linux", "moreutils"] + & scriptfile `File.mode` combineModes (readModes ++ executeModes) where cmdline = "cd " ++ cddir ++ " && ( " ++ command ++ " )" cronjobfile = "/etc" cronjobdir name @@ -75,13 +74,13 @@ job desc times (User u) cddir command = combineProperties ("cronned " ++ desc) | otherwise = '_' -- | Installs a cron job, and runs it niced and ioniced. -niceJob :: Desc -> Times -> User -> FilePath -> String -> Property NoInfo +niceJob :: Desc -> Times -> User -> FilePath -> String -> Property DebianLike niceJob desc times user cddir command = job desc times user cddir ("nice ionice -c 3 sh -c " ++ shellEscape command) -- | Installs a cron job to run propellor. -runPropellor :: Times -> Property NoInfo -runPropellor times = withOS "propellor cron job" $ \o -> - ensureProperty $ +runPropellor :: Times -> Property UnixLike +runPropellor times = withOS "propellor cron job" $ \w o -> + ensureProperty w $ niceJob "propellor" times (User "root") localdir (bootstrapPropellorCommand o ++ "; ./propellor") 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/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs index 5716be38..e0c56966 100644 --- a/src/Propellor/Property/Debootstrap.hs +++ b/src/Propellor/Property/Debootstrap.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} - module Propellor.Property.Debootstrap ( Url, DebootstrapConfig(..), @@ -48,14 +46,15 @@ toParams (c1 :+ c2) = toParams c1 <> toParams c2 -- -- The System can be any OS and architecture that debootstrap -- and the kernel support. -built :: FilePath -> System -> DebootstrapConfig -> Property HasInfo -built target system config = built' (toProp installed) target system config +built :: FilePath -> System -> DebootstrapConfig -> Property Linux +built target system config = built' (setupRevertableProperty installed) target system config -built' :: (Combines (Property NoInfo) (Property i)) => Property i -> FilePath -> System -> DebootstrapConfig -> Property (CInfo NoInfo i) +built' :: Property Linux -> FilePath -> System -> DebootstrapConfig -> Property Linux built' installprop target system@(System _ arch) config = check (unpopulated target <||> ispartial) setupprop `requires` installprop where + setupprop :: Property Linux setupprop = property ("debootstrapped " ++ target) $ liftIO $ do createDirectoryIfMissing True target -- Don't allow non-root users to see inside the chroot, @@ -99,39 +98,34 @@ extractSuite (System (FreeBSD _) _) = Nothing -- When necessary, falls back to installing debootstrap from source. -- Note that installation from source is done by downloading the tarball -- from a Debian mirror, with no cryptographic verification. -installed :: RevertableProperty NoInfo +installed :: RevertableProperty Linux Linux installed = install remove where - install = withOS "debootstrap installed" $ \o -> - ifM (liftIO $ isJust <$> programPath) - ( return NoChange - , ensureProperty (installon o) - ) + install = check (isJust <$> programPath) $ + (aptinstall `pickOS` sourceInstall) + `describe` "debootstrap installed" - installon (Just (System (Debian _) _)) = aptinstall - installon (Just (System (Buntish _) _)) = aptinstall - installon _ = sourceInstall - - remove = withOS "debootstrap removed" $ ensureProperty . removefrom - 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"] -sourceInstall :: Property NoInfo -sourceInstall = property "debootstrap installed from source" (liftIO sourceInstall') +sourceInstall :: Property Linux +sourceInstall = go `requires` perlInstalled `requires` arInstalled + where + go :: Property Linux + go = property "debootstrap installed from source" (liftIO sourceInstall') -perlInstalled :: Property NoInfo +perlInstalled :: Property Linux perlInstalled = check (not <$> inPath "perl") $ property "perl installed" $ liftIO $ toResult . isJust <$> firstM id [ yumInstall "perl" ] -arInstalled :: Property NoInfo +arInstalled :: Property Linux arInstalled = check (not <$> inPath "ar") $ property "ar installed" $ liftIO $ toResult . isJust <$> firstM id [ yumInstall "binutils" @@ -175,7 +169,7 @@ sourceInstall' = withTmpDir "debootstrap" $ \tmpd -> do return MadeChange _ -> errorMessage "debootstrap tar file did not contain exactly one dirctory" -sourceRemove :: Property NoInfo +sourceRemove :: Property Linux sourceRemove = property "debootstrap not installed from source" $ liftIO $ ifM (doesDirectoryExist sourceInstallDir) ( do diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index 6200f856..718768c2 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") @@ -76,44 +80,54 @@ type DiskImage = FilePath -- chroot while the disk image is being built, which should prevent any -- daemons that are included from being started on the system that is -- building the disk image. -imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty HasInfo +imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) Linux imageBuilt = imageBuilt' False -- | Like 'built', but the chroot is deleted and rebuilt from scratch each -- time. This is more expensive, but useful to ensure reproducible results -- when the properties of the chroot have been changed. -imageRebuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty HasInfo +imageRebuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) Linux imageRebuilt = imageBuilt' True -imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty HasInfo +imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) Linux 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 = "cache cleaned" ==> (Apt.cacheCleaned `pickOS` skipit) + where + skipit = doNothing :: Property UnixLike -- | Builds a disk image from the contents of a chroot. -imageBuiltFrom :: DiskImage -> FilePath -> TableType -> Finalization -> [PartSpec] -> RevertableProperty NoInfo +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 +137,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 @@ -135,17 +149,18 @@ imageBuiltFrom img chrootdir tabletype final partspec = mkimg rmimg imageFinalized final mnts mntopts devs parttable rmimg = File.notPresent img -partitionsPopulated :: FilePath -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> Property NoInfo -partitionsPopulated chrootdir mnts mntopts devs = property desc $ mconcat $ zipWith3 go mnts mntopts devs +partitionsPopulated :: FilePath -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> Property Linux +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 @@ -203,7 +218,7 @@ getMountSz szm l (Just mntpt) = -- If the file doesn't exist, or is too small, creates a new one, full of 0's. -- -- If the file is too large, truncates it down to the specified size. -imageExists :: FilePath -> ByteSize -> Property NoInfo +imageExists :: FilePath -> ByteSize -> Property Linux imageExists img sz = property ("disk image exists" ++ img) $ liftIO $ do ms <- catchMaybeIO $ getFileStatus img case ms of @@ -226,19 +241,19 @@ imageExists img sz = property ("disk image exists" ++ img) $ liftIO $ do -- -- It's ok if the second property leaves additional things mounted -- in the partition tree. -type Finalization = (Property NoInfo, (FilePath -> [LoopDev] -> Property NoInfo)) +type Finalization = (Property Linux, (FilePath -> [LoopDev] -> Property Linux)) -imageFinalized :: Finalization -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> PartTable -> Property NoInfo +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 +295,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/Dns.hs b/src/Propellor/Property/Dns.hs index adc12930..2e2710a6 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 + `setInfoProperty` (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) @@ -210,7 +213,7 @@ otherServers :: DnsServerType -> [Host] -> Domain -> [HostName] otherServers wantedtype hosts domain = M.keys $ M.filter wanted $ hostMap hosts where - wanted h = case M.lookup domain (fromNamedConfMap $ getInfo $ hostInfo h) of + wanted h = case M.lookup domain (fromNamedConfMap $ fromInfo $ hostInfo h) of Nothing -> False Just conf -> confDnsServerType conf == wantedtype && confDomain conf == domain @@ -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 @@ -465,7 +468,7 @@ genZone inzdomain hostmap zdomain soa = -- So we can just use the IPAddrs. addcnames :: Host -> [Either WarningMessage (BindDomain, Record)] addcnames h = concatMap gen $ filter (inDomain zdomain) $ - mapMaybe getCNAME $ S.toList $ fromDnsInfo $ getInfo info + mapMaybe getCNAME $ S.toList $ fromDnsInfo $ fromInfo info where info = hostInfo h gen c = case getAddresses info of @@ -480,7 +483,7 @@ genZone inzdomain hostmap zdomain soa = where info = hostInfo h l = zip (repeat $ AbsDomain $ hostName h) - (S.toList $ S.filter (\r -> isNothing (getIPAddr r) && isNothing (getCNAME r)) (fromDnsInfo $ getInfo info)) + (S.toList $ S.filter (\r -> isNothing (getIPAddr r) && isNothing (getCNAME r)) (fromDnsInfo $ fromInfo info)) -- Simplifies the list of hosts. Remove duplicate entries. -- Also, filter out any CHAMES where the same domain has an @@ -515,7 +518,7 @@ addNamedConf conf = NamedConfMap (M.singleton domain conf) domain = confDomain conf getNamedConf :: Propellor (M.Map Domain NamedConf) -getNamedConf = asks $ fromNamedConfMap . getInfo . hostInfo +getNamedConf = asks $ fromNamedConfMap . fromInfo . hostInfo -- | Generates SSHFP records for hosts in the domain (or with CNAMES -- in the domain) that have configured ssh public keys. @@ -528,7 +531,7 @@ genSSHFP domain h = concatMap mk . concat <$> (gen =<< get) gen = liftIO . mapM genSSHFP' . M.elems . fromMaybe M.empty mk r = mapMaybe (\d -> if inDomain domain d then Just (d, r) else Nothing) (AbsDomain hostname : cnames) - cnames = mapMaybe getCNAME $ S.toList $ fromDnsInfo $ getInfo info + cnames = mapMaybe getCNAME $ S.toList $ fromDnsInfo $ fromInfo info hostname = hostName h info = hostInfo h diff --git a/src/Propellor/Property/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/Docker.hs b/src/Propellor/Property/Docker.hs index ebc0b301..2ef97438 100644 --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts, TypeSynonymInstances, FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts, TypeSynonymInstances, FlexibleInstances, TypeFamilies #-} -- | Docker support for propellor -- @@ -48,8 +48,10 @@ 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 import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Cmd as Cmd @@ -66,16 +68,17 @@ import Data.List.Utils import qualified Data.Map as M import System.Console.Concurrent -installed :: Property NoInfo +installed :: Property DebianLike installed = Apt.installed ["docker.io"] -- | Configures docker with an authentication file, so that images can be -- pushed to index.docker.io. Optional. -configured :: Property HasInfo +configured :: Property (HasInfo + DebianLike) configured = prop `requires` installed where + prop :: Property (HasInfo + DebianLike) prop = withPrivData src anyContext $ \getcfg -> - property "docker configured" $ getcfg $ \cfg -> ensureProperty $ + property' "docker configured" $ \w -> getcfg $ \cfg -> ensureProperty w $ "/root/.dockercfg" `File.hasContent` privDataLines cfg src = PrivDataSourceFileFromCommand DockerAuthentication "/root/.dockercfg" "docker login" @@ -88,6 +91,11 @@ type ContainerName = String -- | A docker container. data Container = Container Image Host +instance IsContainer Container where + containerProperties (Container _ h) = containerProperties h + containerInfo (Container _ h) = containerInfo h + setContainerProperties (Container i h) ps = Container i (setContainerProperties h ps) + class HasImage a where getImageName :: a -> Image @@ -97,22 +105,17 @@ instance HasImage Image where instance HasImage Container where getImageName (Container i _) = i -instance PropAccum Container where - (Container i h) `addProp` p = Container i (h `addProp` p) - (Container i h) `addPropFront` p = Container i (h `addPropFront` p) - getProperties (Container _ h) = hostProperties h - -- | Defines a Container with a given name, image, and properties. --- Properties can be added to configure the Container. +-- Add properties to configure the Container. -- --- > container "web-server" "debian" +-- > container "web-server" (latestImage "debian") $ props -- > & publish "80:80" -- > & Apt.installed {"apache2"] -- > & ... -container :: ContainerName -> Image -> Container -container cn image = Container image (Host cn [] info) +container :: ContainerName -> Image -> Props metatypes -> Container +container cn image (Props ps) = Container image (Host cn ps info) where - info = dockerInfo mempty + info = dockerInfo mempty <> mconcat (map getInfoRecursive ps) -- | Ensures that a docker container is set up and running. -- @@ -124,7 +127,7 @@ container cn image = Container image (Host cn [] info) -- -- Reverting this property ensures that the container is stopped and -- removed. -docked :: Container -> RevertableProperty HasInfo +docked :: Container -> RevertableProperty (HasInfo + Linux) (HasInfo + Linux) docked ctr@(Container _ h) = (propagateContainerInfo ctr (go "docked" setup)) @@ -132,11 +135,12 @@ docked ctr@(Container _ h) = where cn = hostName h - go desc a = property (desc ++ " " ++ cn) $ do + go desc a = property' (desc ++ " " ++ cn) $ \w -> do hn <- asks hostName let cid = ContainerId hn cn - ensureProperties [a cid (mkContainerInfo cid ctr)] + ensureProperty w $ a cid (mkContainerInfo cid ctr) + setup :: ContainerId -> ContainerInfo -> Property Linux setup cid (ContainerInfo image runparams) = provisionContainer cid `requires` @@ -144,8 +148,9 @@ docked ctr@(Container _ h) = `requires` installed + teardown :: ContainerId -> ContainerInfo -> Property Linux teardown cid (ContainerInfo image _runparams) = - combineProperties ("undocked " ++ fromContainerId cid) + combineProperties ("undocked " ++ fromContainerId cid) $ toProps [ stoppedContainer cid , property ("cleaned up " ++ fromContainerId cid) $ liftIO $ report <$> mapM id @@ -155,32 +160,32 @@ docked ctr@(Container _ h) = ] -- | Build the image from a directory containing a Dockerfile. -imageBuilt :: HasImage c => FilePath -> c -> Property NoInfo -imageBuilt directory ctr = describe built msg +imageBuilt :: HasImage c => FilePath -> c -> Property Linux +imageBuilt directory ctr = built `describe` msg where msg = "docker image " ++ (imageIdentifier image) ++ " built from " ++ directory - built = Cmd.cmdProperty' dockercmd ["build", "--tag", imageIdentifier image, "./"] workDir - `assume` MadeChange + built :: Property Linux + built = tightenTargets $ + Cmd.cmdProperty' dockercmd ["build", "--tag", imageIdentifier image, "./"] workDir + `assume` MadeChange workDir p = p { cwd = Just directory } image = getImageName ctr -- | Pull the image from the standard Docker Hub registry. -imagePulled :: HasImage c => c -> Property NoInfo -imagePulled ctr = describe pulled msg +imagePulled :: HasImage c => c -> Property Linux +imagePulled ctr = pulled `describe` msg where msg = "docker image " ++ (imageIdentifier image) ++ " pulled" - pulled = Cmd.cmdProperty dockercmd ["pull", imageIdentifier image] - `assume` MadeChange + pulled :: Property Linux + pulled = tightenTargets $ + Cmd.cmdProperty dockercmd ["pull", imageIdentifier image] + `assume` MadeChange image = getImageName ctr -propagateContainerInfo :: (IsProp (Property i)) => Container -> Property i -> Property HasInfo -propagateContainerInfo ctr@(Container _ h) p = propagateContainer cn ctr p' +propagateContainerInfo :: Container -> Property (HasInfo + Linux) -> Property (HasInfo + Linux) +propagateContainerInfo ctr@(Container _ h) p = propagateContainer cn ctr $ + p `addInfoProperty` dockerinfo where - p' = infoProperty - (propertyDesc p) - (propertySatisfy p) - (propertyInfo p <> dockerinfo) - (propertyChildren p) dockerinfo = dockerInfo $ mempty { _dockerContainers = M.singleton cn h } cn = hostName h @@ -191,8 +196,8 @@ mkContainerInfo cid@(ContainerId hn _cn) (Container img h) = where runparams = map (\(DockerRunParam mkparam) -> mkparam hn) (_dockerRunParams info) - info = getInfo $ hostInfo h' - h' = h + info = fromInfo $ hostInfo h' + h' = setContainerProps h $ containerProps h -- Restart by default so container comes up on -- boot or when docker is upgraded. &^ restartAlways @@ -209,14 +214,15 @@ mkContainerInfo cid@(ContainerId hn _cn) (Container img h) = -- that were not set up using propellor. -- -- Generally, should come after the properties for the desired containers. -garbageCollected :: Property NoInfo -garbageCollected = propertyList "docker garbage collected" - [ gccontainers - , gcimages - ] +garbageCollected :: Property Linux +garbageCollected = propertyList "docker garbage collected" $ props + & gccontainers + & gcimages where + gccontainers :: Property Linux gccontainers = property "docker containers garbage collected" $ liftIO $ report <$> (mapM removeContainer =<< listContainers AllContainers) + gcimages :: Property Linux gcimages = property "docker images garbage collected" $ liftIO $ report <$> (mapM removeImage =<< listImages) @@ -225,8 +231,8 @@ garbageCollected = propertyList "docker garbage collected" -- Currently, this consists of making pam_loginuid lines optional in -- the pam config, to work around -- which affects docker 1.2.0. -tweaked :: Property NoInfo -tweaked = cmdProperty "sh" +tweaked :: Property Linux +tweaked = tightenTargets $ cmdProperty "sh" [ "-c" , "sed -ri 's/^session\\s+required\\s+pam_loginuid.so$/session optional pam_loginuid.so/' /etc/pam.d/*" ] @@ -239,10 +245,11 @@ tweaked = cmdProperty "sh" -- other GRUB_CMDLINE_LINUX_DEFAULT settings. -- -- Only takes effect after reboot. (Not automated.) -memoryLimited :: Property NoInfo -memoryLimited = "/etc/default/grub" `File.containsLine` cfg - `describe` "docker memory limited" - `onChange` (cmdProperty "update-grub" [] `assume` MadeChange) +memoryLimited :: Property DebianLike +memoryLimited = tightenTargets $ + "/etc/default/grub" `File.containsLine` cfg + `describe` "docker memory limited" + `onChange` (cmdProperty "update-grub" [] `assume` MadeChange) where cmdline = "cgroup_enable=memory swapaccount=1" cfg = "GRUB_CMDLINE_LINUX_DEFAULT=\""++cmdline++"\"" @@ -300,15 +307,15 @@ instance ImageIdentifier ImageUID where imageIdentifier (ImageUID uid) = uid -- | Set custom dns server for container. -dns :: String -> Property HasInfo +dns :: String -> Property (HasInfo + Linux) dns = runProp "dns" -- | Set container host name. -hostname :: String -> Property HasInfo +hostname :: String -> Property (HasInfo + Linux) hostname = runProp "hostname" -- | Set name of container. -name :: String -> Property HasInfo +name :: String -> Property (HasInfo + Linux) name = runProp "name" class Publishable p where @@ -322,15 +329,15 @@ instance Publishable String where toPublish = id -- | Publish a container's port to the host -publish :: Publishable p => p -> Property HasInfo +publish :: Publishable p => p -> Property (HasInfo + Linux) publish = runProp "publish" . toPublish -- | Expose a container's port without publishing it. -expose :: String -> Property HasInfo +expose :: String -> Property (HasInfo + Linux) expose = runProp "expose" -- | Username or UID for container. -user :: String -> Property HasInfo +user :: String -> Property (HasInfo + Linux) user = runProp "user" class Mountable p where @@ -346,17 +353,17 @@ instance Mountable String where toMount = id -- | Mount a volume -volume :: Mountable v => v -> Property HasInfo +volume :: Mountable v => v -> Property (HasInfo + Linux) volume = runProp "volume" . toMount -- | Mount a volume from the specified container into the current -- container. -volumes_from :: ContainerName -> Property HasInfo +volumes_from :: ContainerName -> Property (HasInfo + Linux) volumes_from cn = genProp "volumes-from" $ \hn -> fromContainerId (ContainerId hn cn) -- | Work dir inside the container. -workdir :: String -> Property HasInfo +workdir :: String -> Property (HasInfo + Linux) workdir = runProp "workdir" -- | Memory limit for container. @@ -364,18 +371,18 @@ workdir = runProp "workdir" -- -- Note: Only takes effect when the host has the memoryLimited property -- enabled. -memory :: String -> Property HasInfo +memory :: String -> Property (HasInfo + Linux) memory = runProp "memory" -- | CPU shares (relative weight). -- -- By default, all containers run at the same priority, but you can tell -- the kernel to give more CPU time to a container using this property. -cpuShares :: Int -> Property HasInfo +cpuShares :: Int -> Property (HasInfo + Linux) cpuShares = runProp "cpu-shares" . show -- | Link with another container on the same host. -link :: ContainerName -> ContainerAlias -> Property HasInfo +link :: ContainerName -> ContainerAlias -> Property (HasInfo + Linux) link linkwith calias = genProp "link" $ \hn -> fromContainerId (ContainerId hn linkwith) ++ ":" ++ calias @@ -387,24 +394,24 @@ type ContainerAlias = String -- propellor; as well as keeping badly behaved containers running, -- it ensures that containers get started back up after reboot or -- after docker is upgraded. -restartAlways :: Property HasInfo +restartAlways :: Property (HasInfo + Linux) restartAlways = runProp "restart" "always" -- | Docker will restart the container if it exits nonzero. -- If a number is provided, it will be restarted only up to that many -- times. -restartOnFailure :: Maybe Int -> Property HasInfo +restartOnFailure :: Maybe Int -> Property (HasInfo + Linux) restartOnFailure Nothing = runProp "restart" "on-failure" restartOnFailure (Just n) = runProp "restart" ("on-failure:" ++ show n) -- | Makes docker not restart a container when it exits -- Note that this includes not restarting it on boot! -restartNever :: Property HasInfo +restartNever :: Property (HasInfo + Linux) restartNever = runProp "restart" "no" -- | Set environment variable with a tuple composed by the environment -- variable name and its value. -environment :: (String, String) -> Property HasInfo +environment :: (String, String) -> Property (HasInfo + Linux) environment (k, v) = runProp "env" $ k ++ "=" ++ v -- | A container is identified by its name, and the host @@ -441,9 +448,9 @@ myContainerSuffix = ".propellor" containerDesc :: (IsProp (Property i)) => ContainerId -> Property i -> Property i containerDesc cid p = p `describe` desc where - desc = "container " ++ fromContainerId cid ++ " " ++ propertyDesc p + desc = "container " ++ fromContainerId cid ++ " " ++ getDesc p -runningContainer :: ContainerId -> Image -> [RunParam] -> Property NoInfo +runningContainer :: ContainerId -> Image -> [RunParam] -> Property Linux runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ property "running" $ do l <- liftIO $ listContainers RunningContainers if cid `elem` l @@ -507,6 +514,7 @@ runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ prope retry (n-1) a _ -> return v + go :: ImageIdentifier i => i -> Propellor Result go img = liftIO $ do clearProvisionedFlag cid createDirectoryIfMissing True (takeDirectory $ identFile cid) @@ -558,7 +566,7 @@ init s = case toContainerId s of -- | Once a container is running, propellor can be run inside -- it to provision it. -provisionContainer :: ContainerId -> Property NoInfo +provisionContainer :: ContainerId -> Property Linux provisionContainer cid = containerDesc cid $ property "provisioned" $ liftIO $ do let shim = Shim.file (localdir "propellor") (localdir shimdir cid) let params = ["--continue", show $ toChain cid] @@ -580,16 +588,14 @@ chain hostlist hn s = case toContainerId s of Nothing -> errorMessage "bad container id" Just cid -> case findHostNoAlias hostlist hn of Nothing -> errorMessage ("cannot find host " ++ hn) - Just parenthost -> case M.lookup (containerName cid) (_dockerContainers $ getInfo $ hostInfo parenthost) of + Just parenthost -> case M.lookup (containerName cid) (_dockerContainers $ fromInfo $ hostInfo parenthost) of Nothing -> errorMessage ("cannot find container " ++ containerName cid ++ " docked on host " ++ hn) Just h -> go cid h where go cid h = do changeWorkingDirectory localdir onlyProcess (provisioningLock cid) $ do - r <- runPropellor h $ ensureProperties $ - map ignoreInfo $ - hostProperties h + r <- runPropellor h $ ensureChildProperties $ hostProperties h flushConcurrentOutput putStrLn $ "\n" ++ show r @@ -599,15 +605,16 @@ stopContainer cid = boolSystem dockercmd [Param "stop", Param $ fromContainerId startContainer :: ContainerId -> IO Bool startContainer cid = boolSystem dockercmd [Param "start", Param $ fromContainerId cid ] -stoppedContainer :: ContainerId -> Property NoInfo -stoppedContainer cid = containerDesc cid $ property desc $ +stoppedContainer :: ContainerId -> Property Linux +stoppedContainer cid = containerDesc cid $ property' desc $ \w -> ifM (liftIO $ elem cid <$> listContainers RunningContainers) - ( liftIO cleanup `after` ensureProperty - (property desc $ liftIO $ toResult <$> stopContainer cid) + ( liftIO cleanup `after` ensureProperty w stop , return NoChange ) where desc = "stopped" + stop :: Property Linux + stop = property desc $ liftIO $ toResult <$> stopContainer cid cleanup = do nukeFile $ identFile cid removeDirectoryRecursive $ shimdir cid @@ -651,14 +658,14 @@ listContainers status = listImages :: IO [ImageUID] listImages = map ImageUID . lines <$> readProcess dockercmd ["images", "--all", "--quiet"] -runProp :: String -> RunParam -> Property HasInfo -runProp field val = pureInfoProperty (param) $ +runProp :: String -> RunParam -> Property (HasInfo + Linux) +runProp field val = tightenTargets $ pureInfoProperty (param) $ mempty { _dockerRunParams = [DockerRunParam (\_ -> "--"++param)] } where param = field++"="++val -genProp :: String -> (HostName -> RunParam) -> Property HasInfo -genProp field mkval = pureInfoProperty field $ +genProp :: String -> (HostName -> RunParam) -> Property (HasInfo + Linux) +genProp field mkval = tightenTargets $ pureInfoProperty field $ mempty { _dockerRunParams = [DockerRunParam (\hn -> "--"++field++"=" ++ mkval hn)] } dockerInfo :: DockerInfo -> Info 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 3021617c..e072fcaa 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 @@ -25,38 +25,38 @@ 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 $ getcontent $ \privcontent -> - ensureProperty $ fileProperty' writer desc + property' desc $ \o -> getcontent $ \privcontent -> + ensureProperty o $ fileProperty' writer desc (\_oldcontent -> privDataLines privcontent) f where 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,28 @@ 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 -f `basedOn` (f', a) = property desc $ go =<< (liftIO $ readFile f') +basedOn :: FilePath -> (FilePath, [Line] -> [Line]) -> Property UnixLike +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 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 +104,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 +114,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 +136,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 +157,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 +165,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 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..704c1db9 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) + `setInfoProperty` (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) + `setInfoProperty` (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/FreeBSD/Poudriere.hs b/src/Propellor/Property/FreeBSD/Poudriere.hs index 5467c668..fcad9e87 100644 --- a/src/Propellor/Property/FreeBSD/Poudriere.hs +++ b/src/Propellor/Property/FreeBSD/Poudriere.hs @@ -26,20 +26,23 @@ instance IsInfo PoudriereConfigured where poudriereConfigured :: PoudriereConfigured -> Bool poudriereConfigured (PoudriereConfigured _) = True -setConfigured :: Property HasInfo -setConfigured = pureInfoProperty "Poudriere Configured" (PoudriereConfigured "") +setConfigured :: Property (HasInfo + FreeBSD) +setConfigured = tightenTargets $ + pureInfoProperty "Poudriere Configured" (PoudriereConfigured "") -poudriere :: Poudriere -> Property HasInfo +poudriere :: Poudriere -> Property (HasInfo + FreeBSD) poudriere conf@(Poudriere _ _ _ _ _ _ zfs) = prop `requires` Pkg.installed "poudriere" `before` setConfigured where - confProp = File.containsLines poudriereConfigPath (toLines conf) + confProp :: Property FreeBSD + confProp = tightenTargets $ + File.containsLines poudriereConfigPath (toLines conf) setZfs (PoudriereZFS z p) = ZFS.zfsSetProperties z p `describe` "Configuring Poudriere with ZFS" - prop :: CombinedType (Property NoInfo) (Property NoInfo) + prop :: Property FreeBSD prop | isJust zfs = ((setZfs $ fromJust zfs) `before` confProp) - | otherwise = propertyList "Configuring Poudriere without ZFS" [confProp] + | otherwise = confProp `describe` "Configuring Poudriere without ZFS" poudriereCommand :: String -> [String] -> (String, [String]) poudriereCommand cmd args = ("poudriere", cmd:args) @@ -58,8 +61,8 @@ listJails = mapMaybe (headMaybe . take 1 . words) jailExists :: Jail -> IO Bool jailExists (Jail name _ _) = isInfixOf [name] <$> listJails -jail :: Jail -> Property NoInfo -jail j@(Jail name version arch) = +jail :: Jail -> Property FreeBSD +jail j@(Jail name version arch) = tightenTargets $ let chk = do c <- poudriereConfigured <$> askInfo @@ -70,7 +73,7 @@ jail j@(Jail name version arch) = createJail = cmdProperty cmd args in check chk createJail - `describe` unwords ["Create poudriere jail", name] + `describe` unwords ["Create poudriere jail", name] data JailInfo = JailInfo String 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/Gpg.hs b/src/Propellor/Property/Gpg.hs index bd710ca7..74e9df5a 100644 --- a/src/Propellor/Property/Gpg.hs +++ b/src/Propellor/Property/Gpg.hs @@ -6,7 +6,7 @@ import Utility.FileSystemEncoding import System.PosixCompat -installed :: Property NoInfo +installed :: Property DebianLike installed = Apt.installed ["gnupg"] -- A numeric id, or a description of the key, in a form understood by gpg. @@ -22,11 +22,12 @@ data GpgKeyType = GpgPubKey | GpgPrivKey -- -- Recommend only using this for low-value dedicated role keys. -- No attempt has been made to scrub the key out of memory once it's used. -keyImported :: GpgKeyId -> User -> Property HasInfo +keyImported :: GpgKeyId -> User -> Property (HasInfo + DebianLike) keyImported key@(GpgKeyId keyid) user@(User u) = prop `requires` installed where desc = u ++ " has gpg key " ++ show keyid + prop :: Property (HasInfo + DebianLike) prop = withPrivData src (Context keyid) $ \getkey -> property desc $ getkey $ \key' -> do let keylines = privDataLines key' diff --git a/src/Propellor/Property/Group.hs b/src/Propellor/Property/Group.hs index f91ef1c2..58e49a86 100644 --- a/src/Propellor/Property/Group.hs +++ b/src/Propellor/Property/Group.hs @@ -4,7 +4,7 @@ import Propellor.Base type GID = Int -exists :: Group -> Maybe GID -> Property NoInfo +exists :: Group -> Maybe GID -> Property UnixLike exists (Group group') mgid = check test (cmdProperty "addgroup" (args mgid)) `describe` unwords ["group", group'] where diff --git a/src/Propellor/Property/Grub.hs b/src/Propellor/Property/Grub.hs index 1b7f2a0a..a03fc5a0 100644 --- a/src/Propellor/Property/Grub.hs +++ b/src/Propellor/Property/Grub.hs @@ -19,20 +19,23 @@ 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 = Apt.installed [pkg] `describe` "grub package installed" +installed' :: BIOS -> Property Linux +installed' bios = (aptinstall `pickOS` unsupportedOS) + `describe` "grub package installed" where - pkg = case bios of + aptinstall :: Property DebianLike + aptinstall = Apt.installed [debpkg] + debpkg = case bios of PC -> "grub-pc" EFI64 -> "grub-efi-amd64" EFI32 -> "grub-efi-ia32" @@ -48,8 +51,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 +64,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 +76,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/HostingProvider/CloudAtCost.hs b/src/Propellor/Property/HostingProvider/CloudAtCost.hs index bfe3ae17..5c4788e2 100644 --- a/src/Propellor/Property/HostingProvider/CloudAtCost.hs +++ b/src/Propellor/Property/HostingProvider/CloudAtCost.hs @@ -6,19 +6,24 @@ import qualified Propellor.Property.File as File import qualified Propellor.Property.User as User -- Clean up a system as installed by cloudatcost.com -decruft :: Property NoInfo -decruft = propertyList "cloudatcost cleanup" - [ Hostname.sane - , "worked around grub/lvm boot bug #743126" ==> +decruft :: Property DebianLike +decruft = propertyList "cloudatcost cleanup" $ props + & Hostname.sane + & grubbugfix + & nukecruft + where + grubbugfix :: Property DebianLike + grubbugfix = tightenTargets $ "/etc/default/grub" `File.containsLine` "GRUB_DISABLE_LINUX_UUID=true" - `onChange` (cmdProperty "update-grub" [] `assume` MadeChange) - `onChange` (cmdProperty "update-initramfs" ["-u"] `assume` MadeChange) - , combineProperties "nuked cloudatcost cruft" - [ File.notPresent "/etc/rc.local" - , File.notPresent "/etc/init.d/S97-setup.sh" - , File.notPresent "/zang-debian.sh" - , File.notPresent "/bin/npasswd" - , User.nuked (User "user") User.YesReallyDeleteHome - ] - ] + `describe` "worked around grub/lvm boot bug #743126" + `onChange` (cmdProperty "update-grub" [] `assume` MadeChange) + `onChange` (cmdProperty "update-initramfs" ["-u"] `assume` MadeChange) + nukecruft :: Property Linux + nukecruft = tightenTargets $ + combineProperties "nuked cloudatcost cruft" $ props + & File.notPresent "/etc/rc.local" + & File.notPresent "/etc/init.d/S97-setup.sh" + & File.notPresent "/zang-debian.sh" + & File.notPresent "/bin/npasswd" + & User.nuked (User "user") User.YesReallyDeleteHome diff --git a/src/Propellor/Property/HostingProvider/DigitalOcean.hs b/src/Propellor/Property/HostingProvider/DigitalOcean.hs index f49b86b3..c1e0ffc9 100644 --- a/src/Propellor/Property/HostingProvider/DigitalOcean.hs +++ b/src/Propellor/Property/HostingProvider/DigitalOcean.hs @@ -18,16 +18,15 @@ import Data.List -- If the power is cycled, the non-distro kernel still boots up. -- So, this property also checks if the running kernel is present in /boot, -- and if not, reboots immediately into a distro kernel. -distroKernel :: Property NoInfo -distroKernel = propertyList "digital ocean distro kernel hack" - [ Apt.installed ["grub-pc", "kexec-tools", "file"] - , "/etc/default/kexec" `File.containsLines` +distroKernel :: Property DebianLike +distroKernel = propertyList "digital ocean distro kernel hack" $ props + & Apt.installed ["grub-pc", "kexec-tools", "file"] + & "/etc/default/kexec" `File.containsLines` [ "LOAD_KEXEC=true" , "USE_GRUB_CONFIG=true" ] `describe` "kexec configured" - , check (not <$> runningInstalledKernel) Reboot.now + & check (not <$> runningInstalledKernel) Reboot.now `describe` "running installed kernel" - ] runningInstalledKernel :: IO Bool runningInstalledKernel = do diff --git a/src/Propellor/Property/HostingProvider/Linode.hs b/src/Propellor/Property/HostingProvider/Linode.hs index 274412a0..71719d87 100644 --- a/src/Propellor/Property/HostingProvider/Linode.hs +++ b/src/Propellor/Property/HostingProvider/Linode.hs @@ -8,12 +8,13 @@ import Utility.FileMode -- | Linode's pv-grub-x86_64 does not currently support booting recent -- Debian kernels compressed with xz. This sets up pv-grub chaining to enable -- it. -chainPVGrub :: Grub.TimeoutSecs -> Property NoInfo +chainPVGrub :: Grub.TimeoutSecs -> Property DebianLike chainPVGrub = Grub.chainPVGrub "hd0" "xen/xvda" -- | Linode disables mlocate's cron job's execute permissions, -- presumably to avoid disk IO. This ensures it's executable. -mlocateEnabled :: Property NoInfo -mlocateEnabled = "/etc/cron.daily/mlocate" - `File.mode` combineModes (readModes ++ executeModes) +mlocateEnabled :: Property DebianLike +mlocateEnabled = tightenTargets $ + "/etc/cron.daily/mlocate" + `File.mode` combineModes (readModes ++ executeModes) diff --git a/src/Propellor/Property/Hostname.hs b/src/Propellor/Property/Hostname.hs index 7ab350ae..e1342d91 100644 --- a/src/Propellor/Property/Hostname.hs +++ b/src/Propellor/Property/Hostname.hs @@ -22,20 +22,20 @@ import Data.List.Utils -- Also, the 127.0.0.1 line is set to localhost. Putting any -- other hostnames there is not best practices and can lead to annoying -- messages from eg, apache. -sane :: Property NoInfo +sane :: Property UnixLike sane = sane' extractDomain -sane' :: ExtractDomain -> Property NoInfo -sane' extractdomain = property ("sane hostname") $ - ensureProperty . setTo' extractdomain =<< asks hostName +sane' :: ExtractDomain -> Property UnixLike +sane' extractdomain = property' ("sane hostname") $ \w -> + ensureProperty w . setTo' extractdomain =<< asks hostName -- Like `sane`, but you can specify the hostname to use, instead -- of the default hostname of the `Host`. -setTo :: HostName -> Property NoInfo +setTo :: HostName -> Property UnixLike setTo = setTo' extractDomain -setTo' :: ExtractDomain -> HostName -> Property NoInfo -setTo' extractdomain hn = combineProperties desc +setTo' :: ExtractDomain -> HostName -> Property UnixLike +setTo' extractdomain hn = combineProperties desc $ toProps [ "/etc/hostname" `File.hasContent` [basehost] , hostslines $ catMaybes [ if null domain @@ -65,11 +65,12 @@ setTo' extractdomain hn = combineProperties desc -- | Makes contain search and domain lines for -- the domain that the hostname is in. -searchDomain :: Property NoInfo +searchDomain :: Property UnixLike searchDomain = searchDomain' extractDomain -searchDomain' :: ExtractDomain -> Property NoInfo -searchDomain' extractdomain = property desc (ensureProperty . go =<< asks hostName) +searchDomain' :: ExtractDomain -> Property UnixLike +searchDomain' extractdomain = property' desc $ \w -> + (ensureProperty w . go =<< asks hostName) where desc = "resolv.conf search and domain configured" go hn = diff --git a/src/Propellor/Property/Journald.hs b/src/Propellor/Property/Journald.hs index 2fbb780e..d0261626 100644 --- a/src/Propellor/Property/Journald.hs +++ b/src/Propellor/Property/Journald.hs @@ -5,7 +5,7 @@ import qualified Propellor.Property.Systemd as Systemd import Utility.DataUnits -- | Configures journald, restarting it so the changes take effect. -configured :: Systemd.Option -> String -> Property NoInfo +configured :: Systemd.Option -> String -> Property Linux configured option value = Systemd.configured "/etc/systemd/journald.conf" option value `onChange` Systemd.restarted "systemd-journald" @@ -14,28 +14,28 @@ configured option value = -- Examples: "100 megabytes" or "0.5tb" type DataSize = String -configuredSize :: Systemd.Option -> DataSize -> Property NoInfo +configuredSize :: Systemd.Option -> DataSize -> Property Linux configuredSize option s = case readSize dataUnits s of Just sz -> configured option (systemdSizeUnits sz) Nothing -> property ("unable to parse " ++ option ++ " data size " ++ s) $ return FailedChange -systemMaxUse :: DataSize -> Property NoInfo +systemMaxUse :: DataSize -> Property Linux systemMaxUse = configuredSize "SystemMaxUse" -runtimeMaxUse :: DataSize -> Property NoInfo +runtimeMaxUse :: DataSize -> Property Linux runtimeMaxUse = configuredSize "RuntimeMaxUse" -systemKeepFree :: DataSize -> Property NoInfo +systemKeepFree :: DataSize -> Property Linux systemKeepFree = configuredSize "SystemKeepFree" -runtimeKeepFree :: DataSize -> Property NoInfo +runtimeKeepFree :: DataSize -> Property Linux runtimeKeepFree = configuredSize "RuntimeKeepFree" -systemMaxFileSize :: DataSize -> Property NoInfo +systemMaxFileSize :: DataSize -> Property Linux systemMaxFileSize = configuredSize "SystemMaxFileSize" -runtimeMaxFileSize :: DataSize -> Property NoInfo +runtimeMaxFileSize :: DataSize -> Property Linux runtimeMaxFileSize = configuredSize "RuntimeMaxFileSize" -- Generates size units as used in journald.conf. diff --git a/src/Propellor/Property/Kerberos.hs b/src/Propellor/Property/Kerberos.hs index cb6e06cc..3c351943 100644 --- a/src/Propellor/Property/Kerberos.hs +++ b/src/Propellor/Property/Kerberos.hs @@ -34,25 +34,25 @@ keyTabPath = maybe defaultKeyTab id principal :: String -> Maybe String -> Maybe Realm -> Principal principal p i r = p ++ maybe "" ("/"++) i ++ maybe "" ("@" ++) r -installed :: Property NoInfo +installed :: Property DebianLike installed = Apt.installed ["krb5-user"] -kdcInstalled :: Property NoInfo +kdcInstalled :: Property DebianLike kdcInstalled = Apt.serviceInstalledRunning "krb5-kdc" -adminServerInstalled :: Property NoInfo +adminServerInstalled :: Property DebianLike adminServerInstalled = Apt.serviceInstalledRunning "krb5-admin-server" -kpropServerInstalled :: Property HasInfo +kpropServerInstalled :: Property DebianLike kpropServerInstalled = propertyList "kprop server installed" $ props & kdcInstalled & Apt.installed ["openbsd-inetd"] & "/etc/inetd.conf" `File.containsLines` - [ "krb5_prop\tstream\ttcp\tnowait\troot\t/usr/sbin/kpropd kpropd" - , "krb5_prop\tstream\ttcp6\tnowait\troot\t/usr/sbin/kpropd kpropd" - ] + [ "krb5_prop\tstream\ttcp\tnowait\troot\t/usr/sbin/kpropd kpropd" + , "krb5_prop\tstream\ttcp6\tnowait\troot\t/usr/sbin/kpropd kpropd" + ] -kpropAcls :: [String] -> Property NoInfo +kpropAcls :: [String] -> Property UnixLike kpropAcls ps = kpropdAclPath `File.hasContent` ps `describe` "kprop server ACLs" k5srvutil :: (Maybe FilePath) -> [String] -> IO String @@ -82,13 +82,14 @@ k5loginPath user = do h <- homedir user return $ h ".k5login" -k5login :: User -> [Principal] -> Property NoInfo -k5login user@(User u) ps = property (u ++ " has k5login") $ do +k5login :: User -> [Principal] -> Property UnixLike +k5login user@(User u) ps = property' desc $ \w -> do f <- liftIO $ k5loginPath user liftIO $ do createDirectoryIfMissing True (takeDirectory f) writeFile f (unlines ps) - ensureProperties - [ File.ownerGroup f user (userGroup user) - , File.ownerGroup (takeDirectory f) user (userGroup user) - ] + ensureProperty w $ combineProperties desc $ props + & File.ownerGroup f user (userGroup user) + & File.ownerGroup (takeDirectory f) user (userGroup user) + where + desc = u ++ " has k5login" diff --git a/src/Propellor/Property/LetsEncrypt.hs b/src/Propellor/Property/LetsEncrypt.hs index d5528c64..bf38046b 100644 --- a/src/Propellor/Property/LetsEncrypt.hs +++ b/src/Propellor/Property/LetsEncrypt.hs @@ -7,7 +7,7 @@ import qualified Propellor.Property.Apt as Apt import System.Posix.Files -installed :: Property NoInfo +installed :: Property DebianLike installed = Apt.installed ["letsencrypt"] -- | Tell the letsencrypt client that you agree with the Let's Encrypt @@ -39,15 +39,16 @@ type WebRoot = FilePath -- -- See `Propellor.Property.Apache.httpsVirtualHost` for a more complete -- integration of apache with letsencrypt, that's built on top of this. -letsEncrypt :: AgreeTOS -> Domain -> WebRoot -> Property NoInfo +letsEncrypt :: AgreeTOS -> Domain -> WebRoot -> Property DebianLike letsEncrypt tos domain = letsEncrypt' tos domain [] -- | Like `letsEncrypt`, but the certificate can be obtained for multiple -- domains. -letsEncrypt' :: AgreeTOS -> Domain -> [Domain] -> WebRoot -> Property NoInfo +letsEncrypt' :: AgreeTOS -> Domain -> [Domain] -> WebRoot -> Property DebianLike letsEncrypt' (AgreeTOS memail) domain domains webroot = prop `requires` installed where + prop :: Property UnixLike prop = property desc $ do startstats <- liftIO getstats (transcript, ok) <- liftIO $ diff --git a/src/Propellor/Property/LightDM.hs b/src/Propellor/Property/LightDM.hs index 75e3b19a..339fa9a3 100644 --- a/src/Propellor/Property/LightDM.hs +++ b/src/Propellor/Property/LightDM.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE FlexibleInstances #-} - -- | Maintainer: Sean Whitton module Propellor.Property.LightDM where @@ -8,11 +6,11 @@ import Propellor.Base import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.ConfFile as ConfFile -installed :: Property NoInfo +installed :: Property DebianLike installed = Apt.installed ["lightdm"] -- | Configures LightDM to skip the login screen and autologin as a user. -autoLogin :: User -> Property NoInfo +autoLogin :: User -> Property UnixLike autoLogin (User u) = "/etc/lightdm/lightdm.conf" `ConfFile.containsIniSetting` ("SeatDefaults", "autologin-user", u) `describe` "lightdm autologin" diff --git a/src/Propellor/Property/List.hs b/src/Propellor/Property/List.hs index 74aa6ca6..0eec04c7 100644 --- a/src/Propellor/Property/List.hs +++ b/src/Propellor/Property/List.hs @@ -1,86 +1,59 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} module Propellor.Property.List ( props, - PropertyList(..), - PropertyListType, - PropList(..), + Props, + toProps, + propertyList, + combineProperties, ) where import Propellor.Types -import Propellor.Engine +import Propellor.Types.Core +import Propellor.Types.MetaTypes import Propellor.PropAccum +import Propellor.Engine +import Propellor.Exception import Data.Monoid --- | Starts accumulating a list of properties. +toProps :: [Property (MetaTypes metatypes)] -> Props (MetaTypes metatypes) +toProps ps = Props (map toChildProperty 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 +-- 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 ps) = + property desc (ensureChildProperties cs) + `addChildren` cs + where + cs = map toChildProperty 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 ps) = + property desc (combineSatisfy cs NoChange) + `addChildren` cs + where + cs = map toChildProperty 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/Property/Locale.hs b/src/Propellor/Property/Locale.hs index 06cd63ad..b7cf242c 100644 --- a/src/Propellor/Property/Locale.hs +++ b/src/Propellor/Property/Locale.hs @@ -21,14 +21,17 @@ type LocaleVariable = String -- -- Note that reverting this property does not make a locale unavailable. That's -- because it might be required for other Locale.selectedFor statements. -selectedFor :: Locale -> [LocaleVariable] -> RevertableProperty NoInfo +selectedFor :: Locale -> [LocaleVariable] -> RevertableProperty DebianLike DebianLike locale `selectedFor` vars = select deselect where - select = check (not <$> isselected) (cmdProperty "update-locale" selectArgs) - `requires` available locale - `describe` (locale ++ " locale selected") - deselect = check isselected (cmdProperty "update-locale" vars) - `describe` (locale ++ " locale deselected") + select = tightenTargets $ + check (not <$> isselected) + (cmdProperty "update-locale" selectArgs) + `requires` available locale + `describe` (locale ++ " locale selected") + deselect = tightenTargets $ + check isselected (cmdProperty "update-locale" vars) + `describe` (locale ++ " locale deselected") selectArgs = zipWith (++) vars (repeat ('=':locale)) isselected = locale `isSelectedFor` vars @@ -46,20 +49,21 @@ locale `isSelectedFor` vars = do -- -- Per Debian bug #684134 we cannot ensure a locale is generated by means of -- Apt.reConfigure. So localeAvailable edits /etc/locale.gen manually. -available :: Locale -> RevertableProperty NoInfo -available locale = (ensureAvailable ensureUnavailable) +available :: Locale -> RevertableProperty DebianLike DebianLike +available locale = ensureAvailable ensureUnavailable where f = "/etc/locale.gen" desc = (locale ++ " locale generated") - ensureAvailable = - property desc $ (lines <$> (liftIO $ readFile f)) - >>= \locales -> - if locale `presentIn` locales - then ensureProperty $ - fileProperty desc (foldr uncomment []) f - `onChange` regenerate - else return FailedChange -- locale unavailable for generation - ensureUnavailable = + ensureAvailable :: Property DebianLike + ensureAvailable = property' desc $ \w -> do + locales <- lines <$> (liftIO $ readFile f) + if locale `presentIn` locales + then ensureProperty w $ + fileProperty desc (foldr uncomment []) f + `onChange` regenerate + else return FailedChange -- locale unavailable for generation + ensureUnavailable :: Property DebianLike + ensureUnavailable = tightenTargets $ fileProperty (locale ++ " locale not generated") (foldr comment []) f `onChange` regenerate diff --git a/src/Propellor/Property/Logcheck.hs b/src/Propellor/Property/Logcheck.hs index 22621cc2..ced9fce2 100644 --- a/src/Propellor/Property/Logcheck.hs +++ b/src/Propellor/Property/Logcheck.hs @@ -28,9 +28,9 @@ defaultPrefix = "^\\w{3} [ :[:digit:]]{11} [._[:alnum:]-]+ " ignoreFilePath :: ReportLevel -> Service -> FilePath ignoreFilePath t n = "/etc/logcheck/ignore.d." ++ (show t) n -ignoreLines :: ReportLevel -> Service -> [String] -> Property NoInfo +ignoreLines :: ReportLevel -> Service -> [String] -> Property UnixLike ignoreLines t n ls = (ignoreFilePath t n) `File.containsLines` ls `describe` ("logcheck ignore lines for " ++ n ++ "(" ++ (show t) ++ ")") -installed :: Property NoInfo +installed :: Property DebianLike installed = Apt.installed ["logcheck"] diff --git a/src/Propellor/Property/Mount.hs b/src/Propellor/Property/Mount.hs index 590cede9..5921755c 100644 --- a/src/Propellor/Property/Mount.hs +++ b/src/Propellor/Property/Mount.hs @@ -37,16 +37,17 @@ formatMountOpts (MountOpts []) = "defaults" formatMountOpts (MountOpts l) = intercalate "," l -- | Mounts a device. -mounted :: FsType -> Source -> MountPoint -> MountOpts -> Property NoInfo +mounted :: FsType -> Source -> MountPoint -> MountOpts -> Property UnixLike mounted fs src mnt opts = property (mnt ++ " mounted") $ toResult <$> liftIO (mount fs src mnt opts) -- | Bind mounts the first directory so its contents also appear -- in the second directory. -bindMount :: FilePath -> FilePath -> Property NoInfo -bindMount src dest = cmdProperty "mount" ["--bind", src, dest] - `assume` MadeChange - `describe` ("bind mounted " ++ src ++ " to " ++ dest) +bindMount :: FilePath -> FilePath -> Property Linux +bindMount src dest = tightenTargets $ + cmdProperty "mount" ["--bind", src, dest] + `assume` MadeChange + `describe` ("bind mounted " ++ src ++ " to " ++ dest) mount :: FsType -> Source -> MountPoint -> MountOpts -> IO Bool mount fs src mnt opts = boolSystem "mount" $ @@ -66,10 +67,10 @@ newtype SwapPartition = SwapPartition FilePath -- and its mount options are all automatically probed. -- -- The SwapPartitions are also included in the generated fstab. -fstabbed :: [MountPoint] -> [SwapPartition] -> Property NoInfo -fstabbed mnts swaps = property "fstabbed" $ do +fstabbed :: [MountPoint] -> [SwapPartition] -> Property Linux +fstabbed mnts swaps = property' "fstabbed" $ \o -> do fstab <- liftIO $ genFstab mnts swaps id - ensureProperty $ + ensureProperty o $ "/etc/fstab" `File.hasContent` fstab genFstab :: [MountPoint] -> [SwapPartition] -> (MountPoint -> MountPoint) -> IO [String] diff --git a/src/Propellor/Property/Munin.hs b/src/Propellor/Property/Munin.hs index 2464985a..dd74d91b 100644 --- a/src/Propellor/Property/Munin.hs +++ b/src/Propellor/Property/Munin.hs @@ -19,19 +19,19 @@ import qualified Propellor.Property.Service as Service nodePort :: Integer nodePort = 4949 -nodeInstalled :: Property NoInfo +nodeInstalled :: Property DebianLike nodeInstalled = Apt.serviceInstalledRunning "munin-node" -nodeRestarted :: Property NoInfo +nodeRestarted :: Property DebianLike nodeRestarted = Service.restarted "munin-node" nodeConfPath :: FilePath nodeConfPath = "/etc/munin/munin-node.conf" -masterInstalled :: Property NoInfo +masterInstalled :: Property DebianLike masterInstalled = Apt.serviceInstalledRunning "munin" -masterRestarted :: Property NoInfo +masterRestarted :: Property DebianLike masterRestarted = Service.restarted "munin" masterConfPath :: FilePath diff --git a/src/Propellor/Property/Network.hs b/src/Propellor/Property/Network.hs index 382f5d9d..9ed9e591 100644 --- a/src/Propellor/Property/Network.hs +++ b/src/Propellor/Property/Network.hs @@ -7,8 +7,8 @@ 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 +18,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 +31,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 +50,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 +83,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 +109,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" diff --git a/src/Propellor/Property/Nginx.hs b/src/Propellor/Property/Nginx.hs index 8fb5c49b..e40ba657 100644 --- a/src/Propellor/Property/Nginx.hs +++ b/src/Propellor/Property/Nginx.hs @@ -9,7 +9,7 @@ import qualified Propellor.Property.Service as Service type ConfigFile = [String] -siteEnabled :: HostName -> ConfigFile -> RevertableProperty NoInfo +siteEnabled :: HostName -> ConfigFile -> RevertableProperty DebianLike DebianLike siteEnabled hn cf = enable disable where enable = siteVal hn `File.isSymlinkedTo` siteValRelativeCfg hn @@ -22,11 +22,11 @@ siteEnabled hn cf = enable disable `requires` installed `onChange` reloaded -siteAvailable :: HostName -> ConfigFile -> Property NoInfo -siteAvailable hn cf = ("nginx site available " ++ hn) ==> - siteCfg hn `File.hasContent` (comment : cf) +siteAvailable :: HostName -> ConfigFile -> Property DebianLike +siteAvailable hn cf = "nginx site available " ++ hn ==> tightenTargets go where comment = "# deployed with propellor, do not modify" + go = siteCfg hn `File.hasContent` (comment : cf) siteCfg :: HostName -> FilePath siteCfg hn = "/etc/nginx/sites-available/" ++ hn @@ -37,11 +37,11 @@ siteVal hn = "/etc/nginx/sites-enabled/" ++ hn siteValRelativeCfg :: HostName -> File.LinkTarget siteValRelativeCfg hn = File.LinkTarget ("../sites-available/" ++ hn) -installed :: Property NoInfo +installed :: Property DebianLike installed = Apt.installed ["nginx"] -restarted :: Property NoInfo +restarted :: Property DebianLike restarted = Service.restarted "nginx" -reloaded :: Property NoInfo +reloaded :: Property DebianLike reloaded = Service.reloaded "nginx" diff --git a/src/Propellor/Property/OS.hs b/src/Propellor/Property/OS.hs index e5da0921..5a3ccc70 100644 --- a/src/Propellor/Property/OS.hs +++ b/src/Propellor/Property/OS.hs @@ -46,7 +46,7 @@ import Control.Exception (throw) -- install succeeds, to bootstrap from the cleanly installed system to -- a fully working system. For example: -- --- > & os (System (Debian Unstable) "amd64") +-- > & osDebian Unstable "amd64" -- > & cleanInstallOnce (Confirmed "foo.example.com") -- > `onChange` propertyList "fixing up after clean install" -- > [ preserveNetwork @@ -64,7 +64,7 @@ import Control.Exception (throw) -- > & User.accountFor "joey" -- > & User.hasSomePassword "joey" -- > -- rest of system properties here -cleanInstallOnce :: Confirmation -> Property NoInfo +cleanInstallOnce :: Confirmation -> Property Linux cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $ go `requires` confirmed "clean install confirmed" confirmation where @@ -83,14 +83,18 @@ cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $ `requires` osbootstrapped - osbootstrapped = withOS (newOSDir ++ " bootstrapped") $ \o -> case o of - (Just d@(System (Debian _) _)) -> debootstrap d - (Just u@(System (Buntish _) _)) -> debootstrap u - _ -> unsupportedOS + osbootstrapped :: Property Linux + osbootstrapped = withOS (newOSDir ++ " bootstrapped") $ \w o -> case o of + (Just d@(System (Debian _) _)) -> ensureProperty w $ + debootstrap d + (Just u@(System (Buntish _) _)) -> ensureProperty w $ + debootstrap u + _ -> unsupportedOS' - debootstrap targetos = ensureProperty $ - -- Ignore the os setting, and install debootstrap from - -- source, since we don't know what OS we're running in yet. + debootstrap :: System -> Property Linux + debootstrap targetos = + -- Install debootstrap from source, since we don't know + -- what OS we're currently running in. Debootstrap.built' Debootstrap.sourceInstall newOSDir targetos Debootstrap.DefaultConfig -- debootstrap, I wish it was faster.. @@ -100,6 +104,7 @@ cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $ -- sync instead? -- This is the fun bit. + flipped :: Property Linux flipped = property (newOSDir ++ " moved into place") $ liftIO $ do -- First, unmount most mount points, lazily, so -- they don't interfere with moving things around. @@ -137,6 +142,7 @@ cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $ return MadeChange + propellorbootstrapped :: Property UnixLike propellorbootstrapped = property "propellor re-debootstrapped in new os" $ return NoChange -- re-bootstrap propellor in /usr/local/propellor, @@ -145,6 +151,7 @@ cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $ -- be present in /old-os's /usr/local/propellor) -- TODO + finalized :: Property UnixLike finalized = property "clean OS installed" $ do liftIO $ writeFile flagfile "" return MadeChange @@ -179,7 +186,7 @@ massRename = go [] data Confirmation = Confirmed HostName -confirmed :: Desc -> Confirmation -> Property NoInfo +confirmed :: Desc -> Confirmation -> Property UnixLike confirmed desc (Confirmed c) = property desc $ do hostname <- asks hostName if hostname /= c @@ -191,25 +198,26 @@ confirmed desc (Confirmed c) = property desc $ do -- | is configured to bring up the network -- interface that currently has a default route configured, using -- the same (static) IP address. -preserveNetwork :: Property NoInfo +preserveNetwork :: Property DebianLike preserveNetwork = go `requires` Network.cleanInterfacesFile where - go = property "preserve network configuration" $ do + go :: Property DebianLike + go = property' "preserve network configuration" $ \w -> do ls <- liftIO $ lines <$> readProcess "ip" ["route", "list", "scope", "global"] case words <$> headMaybe ls of Just ("default":"via":_:"dev":iface:_) -> - ensureProperty $ Network.static iface + ensureProperty w $ Network.static iface _ -> do warningMessage "did not find any default ipv4 route" return FailedChange -- | is copied from the old OS -preserveResolvConf :: Property NoInfo +preserveResolvConf :: Property Linux preserveResolvConf = check (fileExist oldloc) $ - property (newloc ++ " copied from old OS") $ do + property' (newloc ++ " copied from old OS") $ \w -> do ls <- liftIO $ lines <$> readFile oldloc - ensureProperty $ newloc `File.hasContent` ls + ensureProperty w $ newloc `File.hasContent` ls where newloc = "/etc/resolv.conf" oldloc = oldOSDir ++ newloc @@ -217,20 +225,23 @@ preserveResolvConf = check (fileExist oldloc) $ -- | has added to it any ssh keys that -- were authorized in the old OS. Any other contents of the file are -- retained. -preserveRootSshAuthorized :: Property NoInfo +preserveRootSshAuthorized :: Property UnixLike preserveRootSshAuthorized = check (fileExist oldloc) $ - property (newloc ++ " copied from old OS") $ do + property' desc $ \w -> do ks <- liftIO $ lines <$> readFile oldloc - ensureProperties (map (setupRevertableProperty . Ssh.authorizedKey (User "root")) ks) + ensureProperty w $ combineProperties desc $ + toProps $ map (setupRevertableProperty . Ssh.authorizedKey (User "root")) ks where + desc = newloc ++ " copied from old OS" newloc = "/root/.ssh/authorized_keys" oldloc = oldOSDir ++ newloc -- Removes the old OS's backup from -oldOSRemoved :: Confirmation -> Property NoInfo +oldOSRemoved :: Confirmation -> Property UnixLike oldOSRemoved confirmation = check (doesDirectoryExist oldOSDir) $ go `requires` confirmed "old OS backup removal confirmed" confirmation where + go :: Property UnixLike go = property "old OS backup removed" $ do liftIO $ removeDirectoryRecursive oldOSDir return MadeChange diff --git a/src/Propellor/Property/Obnam.hs b/src/Propellor/Property/Obnam.hs index 666328ac..6d6f4a7f 100644 --- a/src/Propellor/Property/Obnam.hs +++ b/src/Propellor/Property/Obnam.hs @@ -40,7 +40,7 @@ data NumClients = OnlyClient | MultipleClients -- Since obnam uses a fair amount of system resources, only one obnam -- backup job will be run at a time. Other jobs will wait their turns to -- run. -backup :: FilePath -> Cron.Times -> [ObnamParam] -> NumClients -> Property NoInfo +backup :: FilePath -> Cron.Times -> [ObnamParam] -> NumClients -> Property DebianLike backup dir crontimes params numclients = backup' dir crontimes params numclients `requires` restored dir params @@ -50,7 +50,7 @@ backup dir crontimes params numclients = -- -- The gpg secret key will be automatically imported -- into root's keyring using Propellor.Property.Gpg.keyImported -backupEncrypted :: FilePath -> Cron.Times -> [ObnamParam] -> NumClients -> Gpg.GpgKeyId -> Property HasInfo +backupEncrypted :: FilePath -> Cron.Times -> [ObnamParam] -> NumClients -> Gpg.GpgKeyId -> Property (HasInfo + DebianLike) backupEncrypted dir crontimes params numclients keyid = backup dir crontimes params' numclients `requires` Gpg.keyImported keyid (User "root") @@ -58,7 +58,7 @@ backupEncrypted dir crontimes params numclients keyid = params' = ("--encrypt-with=" ++ Gpg.getGpgKeyId keyid) : params -- | Does a backup, but does not automatically restore. -backup' :: FilePath -> Cron.Times -> [ObnamParam] -> NumClients -> Property NoInfo +backup' :: FilePath -> Cron.Times -> [ObnamParam] -> NumClients -> Property DebianLike backup' dir crontimes params numclients = cronjob `describe` desc where desc = dir ++ " backed up by obnam" @@ -96,11 +96,12 @@ backup' dir crontimes params numclients = cronjob `describe` desc -- -- The restore is performed atomically; restoring to a temp directory -- and then moving it to the directory. -restored :: FilePath -> [ObnamParam] -> Property NoInfo -restored dir params = property (dir ++ " restored by obnam") go - `requires` installed +restored :: FilePath -> [ObnamParam] -> Property DebianLike +restored dir params = go `requires` installed where - go = ifM (liftIO needsRestore) + desc = dir ++ " restored by obnam" + go :: Property DebianLike + go = property desc $ ifM (liftIO needsRestore) ( do warningMessage $ dir ++ " is empty/missing; restoring from backup ..." liftIO restore @@ -152,5 +153,5 @@ keepParam ps = "--keep=" ++ intercalate "," (map go ps) isKeepParam :: ObnamParam -> Bool isKeepParam p = "--keep=" `isPrefixOf` p -installed :: Property NoInfo +installed :: Property DebianLike installed = Apt.installed ["obnam"] diff --git a/src/Propellor/Property/OpenId.hs b/src/Propellor/Property/OpenId.hs index 0f73bfb6..0abf38a6 100644 --- a/src/Propellor/Property/OpenId.hs +++ b/src/Propellor/Property/OpenId.hs @@ -16,7 +16,7 @@ import Data.List -- -- It's probably a good idea to put this property inside a docker or -- systemd-nspawn container. -providerFor :: [User] -> HostName -> Maybe Port -> Property HasInfo +providerFor :: [User] -> HostName -> Maybe Port -> Property (HasInfo + DebianLike) providerFor users hn mp = propertyList desc $ props & Apt.serviceInstalledRunning "apache2" & apacheconfigured @@ -24,7 +24,7 @@ providerFor users hn mp = propertyList desc $ props `onChange` Apache.restarted & File.fileProperty (desc ++ " configured") (map setbaseurl) "/etc/simpleid/config.inc" - & propertyList desc (map identfile users) + & propertyList desc (toProps $ map identfile users) where baseurl = hn ++ case mp of Nothing -> "" @@ -37,7 +37,7 @@ providerFor users hn mp = propertyList desc $ props | otherwise = l apacheconfigured = case mp of - Nothing -> toProp $ + Nothing -> setupRevertableProperty $ Apache.virtualHost hn (Port 80) "/var/www/html" Just p -> propertyList desc $ props & Apache.listenPorts [p] 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..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 @@ -16,7 +17,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 +25,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 +65,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' (getDesc (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/Postfix.hs b/src/Propellor/Property/Postfix.hs index df244061..45aa4e42 100644 --- a/src/Propellor/Property/Postfix.hs +++ b/src/Propellor/Property/Postfix.hs @@ -12,13 +12,13 @@ import qualified Data.Map as M import Data.List import Data.Char -installed :: Property NoInfo +installed :: Property DebianLike installed = Apt.serviceInstalledRunning "postfix" -restarted :: Property NoInfo +restarted :: Property DebianLike restarted = Service.restarted "postfix" -reloaded :: Property NoInfo +reloaded :: Property DebianLike reloaded = Service.reloaded "postfix" -- | Configures postfix as a satellite system, which @@ -28,38 +28,39 @@ reloaded = Service.reloaded "postfix" -- The smarthost may refuse to relay mail on to other domains, without -- further configuration/keys. But this should be enough to get cron job -- mail flowing to a place where it will be seen. -satellite :: Property NoInfo +satellite :: Property DebianLike satellite = check (not <$> mainCfIsSet "relayhost") setup `requires` installed where - setup = property "postfix satellite system" $ do + desc = "postfix satellite system" + setup :: Property DebianLike + setup = property' desc $ \w -> do hn <- asks hostName let (_, domain) = separate (== '.') hn - ensureProperties - [ Apt.reConfigure "postfix" + ensureProperty w $ combineProperties desc $ props + & Apt.reConfigure "postfix" [ ("postfix/main_mailer_type", "select", "Satellite system") , ("postfix/root_address", "string", "root") , ("postfix/destinations", "string", "localhost") , ("postfix/mailname", "string", hn) ] - , mainCf ("relayhost", "smtp." ++ domain) + & mainCf ("relayhost", "smtp." ++ domain) `onChange` reloaded - ] -- | Sets up a file by running a property (which the filename is passed -- to). If the setup property makes a change, postmap will be run on the -- file, and postfix will be reloaded. mappedFile - :: Combines (Property x) (Property NoInfo) + :: Combines (Property x) (Property UnixLike) => FilePath -> (FilePath -> Property x) - -> Property (CInfo x NoInfo) + -> CombinedType (Property x) (Property UnixLike) mappedFile f setup = setup f `onChange` (cmdProperty "postmap" [f] `assume` MadeChange) -- | Run newaliases command, which should be done after changing -- @/etc/aliases@. -newaliases :: Property NoInfo +newaliases :: Property UnixLike newaliases = check ("/etc/aliases" `isNewerThan` "/etc/aliases.db") (cmdProperty "newaliases" []) @@ -68,9 +69,9 @@ mainCfFile :: FilePath mainCfFile = "/etc/postfix/main.cf" -- | Sets a main.cf @name=value@ pair. Does not reload postfix immediately. -mainCf :: (String, String) -> Property NoInfo +mainCf :: (String, String) -> Property UnixLike mainCf (name, value) = check notset set - `describe` ("postfix main.cf " ++ setting) + `describe` ("postfix main.cf " ++ setting) where setting = name ++ "=" ++ value notset = (/= Just value) <$> getMainCf name @@ -105,7 +106,7 @@ mainCfIsSet name = do -- -- Note that multiline configurations that continue onto the next line -- are not currently supported. -dedupMainCf :: Property NoInfo +dedupMainCf :: Property UnixLike dedupMainCf = File.fileProperty "postfix main.cf dedupped" dedupCf mainCfFile dedupCf :: [String] -> [String] @@ -252,7 +253,7 @@ parseServiceLine l = Service nws = length ws -- | Enables a `Service` in postfix's `masterCfFile`. -service :: Service -> RevertableProperty NoInfo +service :: Service -> RevertableProperty DebianLike DebianLike service s = (enable disable) `describe` desc where @@ -276,7 +277,7 @@ service s = (enable disable) -- It would be wise to enable fail2ban, for example: -- -- > Fail2Ban.jailEnabled "postfix-sasl" -saslAuthdInstalled :: Property NoInfo +saslAuthdInstalled :: Property DebianLike saslAuthdInstalled = setupdaemon `requires` Service.running "saslauthd" `requires` postfixgroup @@ -303,7 +304,7 @@ saslAuthdInstalled = setupdaemon -- | Uses `saslpasswd2` to set the password for a user in the sasldb2 file. -- -- The password is taken from the privdata. -saslPasswdSet :: Domain -> User -> Property HasInfo +saslPasswdSet :: Domain -> User -> Property (HasInfo + UnixLike) saslPasswdSet domain (User user) = go `changesFileContent` "/etc/sasldb2" where go = withPrivData src ctx $ \getpw -> diff --git a/src/Propellor/Property/PropellorRepo.hs b/src/Propellor/Property/PropellorRepo.hs index d4fc089a..e60e7848 100644 --- a/src/Propellor/Property/PropellorRepo.hs +++ b/src/Propellor/Property/PropellorRepo.hs @@ -11,7 +11,7 @@ import Propellor.Git.Config -- -- This property is useful when hosts are being updated without using -- --spin, eg when using the `Propellor.Property.Cron.runPropellor` cron job. -hasOriginUrl :: String -> Property NoInfo +hasOriginUrl :: String -> Property UnixLike hasOriginUrl u = property ("propellor repo url " ++ u) $ do curru <- liftIO getRepoUrl if curru == Just u diff --git a/src/Propellor/Property/Prosody.hs b/src/Propellor/Property/Prosody.hs index 47095504..8017be4a 100644 --- a/src/Propellor/Property/Prosody.hs +++ b/src/Propellor/Property/Prosody.hs @@ -11,7 +11,7 @@ type ConfigFile = [String] type Conf = String -confEnabled :: Conf -> ConfigFile -> RevertableProperty NoInfo +confEnabled :: Conf -> ConfigFile -> RevertableProperty DebianLike DebianLike confEnabled conf cf = enable disable where enable = dir `File.isSymlinkedTo` target @@ -29,9 +29,9 @@ confEnabled conf cf = enable disable `requires` installed `onChange` reloaded -confAvailable :: Conf -> ConfigFile -> Property NoInfo +confAvailable :: Conf -> ConfigFile -> Property DebianLike confAvailable conf cf = ("prosody conf available " ++ conf) ==> - confAvailPath conf `File.hasContent` (comment : cf) + tightenTargets (confAvailPath conf `File.hasContent` (comment : cf)) where comment = "-- deployed with propellor, do not modify" @@ -41,11 +41,11 @@ confAvailPath conf = "/etc/prosody/conf.avail" conf <.> "cfg.lua" confValPath :: Conf -> FilePath confValPath conf = "/etc/prosody/conf.d" conf <.> "cfg.lua" -installed :: Property NoInfo +installed :: Property DebianLike installed = Apt.installed ["prosody"] -restarted :: Property NoInfo +restarted :: Property DebianLike restarted = Service.restarted "prosody" -reloaded :: Property NoInfo +reloaded :: Property DebianLike reloaded = Service.reloaded "prosody" diff --git a/src/Propellor/Property/Reboot.hs b/src/Propellor/Property/Reboot.hs index 26b85840..5b854fa3 100644 --- a/src/Propellor/Property/Reboot.hs +++ b/src/Propellor/Property/Reboot.hs @@ -2,8 +2,8 @@ module Propellor.Property.Reboot where import Propellor.Base -now :: Property NoInfo -now = cmdProperty "reboot" [] +now :: Property Linux +now = tightenTargets $ cmdProperty "reboot" [] `assume` MadeChange `describe` "reboot now" @@ -14,7 +14,7 @@ now = cmdProperty "reboot" [] -- -- The reboot can be forced to run, which bypasses the init system. Useful -- if the init system might not be running for some reason. -atEnd :: Bool -> (Result -> Bool) -> Property NoInfo +atEnd :: Bool -> (Result -> Bool) -> Property Linux atEnd force resultok = property "scheduled reboot at end of propellor run" $ do endAction "rebooting" atend return NoChange 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"] diff --git a/src/Propellor/Property/Scheduled.hs b/src/Propellor/Property/Scheduled.hs index 64a530bc..729a3749 100644 --- a/src/Propellor/Property/Scheduled.hs +++ b/src/Propellor/Property/Scheduled.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-} module Propellor.Property.Scheduled ( period @@ -10,6 +10,7 @@ module Propellor.Property.Scheduled ) where import Propellor.Base +import Propellor.Types.Core import Utility.Scheduled import Data.Time.Clock @@ -22,24 +23,24 @@ import qualified Data.Map as M -- last run. period :: (IsProp (Property i)) => Property i -> Recurrance -> Property i period prop recurrance = flip describe desc $ adjustPropertySatisfy prop $ \satisfy -> do - lasttime <- liftIO $ getLastChecked (propertyDesc prop) + lasttime <- liftIO $ getLastChecked (getDesc prop) nexttime <- liftIO $ fmap startTime <$> nextTime schedule lasttime t <- liftIO localNow if Just t >= nexttime then do r <- satisfy - liftIO $ setLastChecked t (propertyDesc prop) + liftIO $ setLastChecked t (getDesc prop) return r else noChange where schedule = Schedule recurrance AnyTime - desc = propertyDesc prop ++ " (period " ++ fromRecurrance recurrance ++ ")" + desc = getDesc prop ++ " (period " ++ fromRecurrance recurrance ++ ")" -- | Like period, but parse a human-friendly string. -periodParse :: Property NoInfo -> String -> Property NoInfo +periodParse :: (IsProp (Property i)) => Property i -> String -> Property i periodParse prop s = case toRecurrance s of Just recurrance -> period prop recurrance - Nothing -> property "periodParse" $ do + Nothing -> adjustPropertySatisfy prop $ \_ -> do liftIO $ warningMessage $ "failed periodParse: " ++ s noChange 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/Property/SiteSpecific/Branchable.hs b/src/Propellor/Property/SiteSpecific/Branchable.hs index 5c85610b..239bcbeb 100644 --- a/src/Propellor/Property/SiteSpecific/Branchable.hs +++ b/src/Propellor/Property/SiteSpecific/Branchable.hs @@ -9,7 +9,7 @@ import qualified Propellor.Property.Postfix as Postfix import qualified Propellor.Property.Gpg as Gpg import qualified Propellor.Property.Sudo as Sudo -server :: [Host] -> Property HasInfo +server :: [Host] -> Property (HasInfo + DebianLike) server hosts = propertyList "branchable server" $ props & "/etc/timezone" `File.hasContent` ["Etc/UTC"] & "/etc/locale.gen" `File.containsLines` diff --git a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs index 2932baf7..ce89b94a 100644 --- a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs +++ b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs @@ -25,7 +25,7 @@ builddir = gitbuilderdir "build" type TimeOut = String -- eg, 5h -autobuilder :: Architecture -> Times -> TimeOut -> Property HasInfo +autobuilder :: Architecture -> Times -> TimeOut -> Property (HasInfo + DebianLike) autobuilder arch crontimes timeout = combineProperties "gitannexbuilder" $ props & Apt.serviceInstalledRunning "cron" & Cron.niceJob "gitannexbuilder" crontimes (User builduser) gitbuilderdir @@ -37,6 +37,7 @@ autobuilder arch crontimes timeout = combineProperties "gitannexbuilder" $ props -- The builduser account does not have a password set, -- instead use the password privdata to hold the rsync server -- password used to upload the built image. + rsyncpassword :: Property (HasInfo + DebianLike) rsyncpassword = withPrivData (Password builduser) context $ \getpw -> property "rsync password" $ getpw $ \pw -> do have <- liftIO $ catchDefaultIO "" $ @@ -46,7 +47,7 @@ autobuilder arch crontimes timeout = combineProperties "gitannexbuilder" $ props then makeChange $ writeFile pwfile want else noChange -tree :: Architecture -> Flavor -> Property HasInfo +tree :: Architecture -> Flavor -> Property DebianLike tree buildarch flavor = combineProperties "gitannexbuilder tree" $ props & Apt.installed ["git"] & File.dirExists gitbuilderdir @@ -66,14 +67,14 @@ tree buildarch flavor = combineProperties "gitannexbuilder tree" $ props [ "git clone git://git-annex.branchable.com/ " ++ builddir ] -buildDepsApt :: Property HasInfo +buildDepsApt :: Property DebianLike buildDepsApt = combineProperties "gitannexbuilder build deps" $ props & Apt.buildDep ["git-annex"] & buildDepsNoHaskellLibs & Apt.buildDepIn builddir `describe` "git-annex source build deps installed" -buildDepsNoHaskellLibs :: Property NoInfo +buildDepsNoHaskellLibs :: Property DebianLike buildDepsNoHaskellLibs = Apt.installed ["git", "rsync", "moreutils", "ca-certificates", "debhelper", "ghc", "curl", "openssh-client", "git-remote-gcrypt", @@ -83,8 +84,9 @@ buildDepsNoHaskellLibs = Apt.installed "libmagic-dev", "alex", "happy", "c2hs" ] -haskellPkgsInstalled :: String -> Property NoInfo -haskellPkgsInstalled dir = flagFile go ("/haskellpkgsinstalled") +haskellPkgsInstalled :: String -> Property DebianLike +haskellPkgsInstalled dir = tightenTargets $ + flagFile go ("/haskellpkgsinstalled") where go = userScriptProperty (User builduser) [ "cd " ++ builddir ++ " && ./standalone/" ++ dir ++ "/install-haskell-packages" @@ -93,7 +95,7 @@ haskellPkgsInstalled dir = flagFile go ("/haskellpkgsinstalled") -- Installs current versions of git-annex's deps from cabal, but only -- does so once. -cabalDeps :: Property NoInfo +cabalDeps :: Property UnixLike cabalDeps = flagFile go cabalupdated where go = userScriptProperty (User builduser) @@ -101,20 +103,20 @@ cabalDeps = flagFile go cabalupdated `assume` MadeChange cabalupdated = homedir ".cabal" "packages" "hackage.haskell.org" "00-index.cache" -autoBuilderContainer :: (System -> Flavor -> Property HasInfo) -> System -> Flavor -> Times -> TimeOut -> Systemd.Container -autoBuilderContainer mkprop osver@(System _ arch) flavor crontime timeout = - Systemd.container name osver (Chroot.debootstrapped mempty) - & mkprop osver flavor +autoBuilderContainer :: (DebianSuite -> Architecture -> Flavor -> Property (HasInfo + Debian)) -> DebianSuite -> Architecture -> Flavor -> Times -> TimeOut -> Systemd.Container +autoBuilderContainer mkprop suite arch flavor crontime timeout = + Systemd.container name $ \d -> Chroot.debootstrapped mempty d $ props + & mkprop suite arch flavor & autobuilder arch crontime timeout where name = arch ++ fromMaybe "" flavor ++ "-git-annex-builder" type Flavor = Maybe String -standardAutoBuilder :: System -> Flavor -> Property HasInfo -standardAutoBuilder osver@(System _ arch) flavor = +standardAutoBuilder :: DebianSuite -> Architecture -> Flavor -> Property (HasInfo + Debian) +standardAutoBuilder suite arch flavor = propertyList "standard git-annex autobuilder" $ props - & os osver + & osDebian suite arch & buildDepsApt & Apt.stdSourcesList & Apt.unattendedUpgrades @@ -122,10 +124,10 @@ standardAutoBuilder osver@(System _ arch) flavor = & User.accountFor (User builduser) & tree arch flavor -stackAutoBuilder :: System -> Flavor -> Property HasInfo -stackAutoBuilder osver@(System _ arch) flavor = +stackAutoBuilder :: DebianSuite -> Architecture -> Flavor -> Property (HasInfo + Debian) +stackAutoBuilder suite arch flavor = propertyList "git-annex autobuilder using stack" $ props - & os osver + & osDebian suite arch & buildDepsNoHaskellLibs & Apt.stdSourcesList & Apt.unattendedUpgrades @@ -134,34 +136,34 @@ stackAutoBuilder osver@(System _ arch) flavor = & tree arch flavor & stackInstalled -stackInstalled :: Property NoInfo -stackInstalled = withOS "stack installed" $ \o -> +stackInstalled :: Property Linux +stackInstalled = withOS "stack installed" $ \w o -> case o of (Just (System (Debian (Stable "jessie")) "i386")) -> - ensureProperty $ manualinstall "i386" - _ -> ensureProperty $ Apt.installed ["haskell-stack"] + ensureProperty w $ manualinstall "i386" + _ -> ensureProperty w $ Apt.installed ["haskell-stack"] where -- Warning: Using a binary downloaded w/o validation. - manualinstall arch = check (not <$> doesFileExist binstack) $ - propertyList "stack installed from upstream tarball" - [ cmdProperty "wget" ["https://www.stackage.org/stack/linux-" ++ arch, "-O", tmptar] + manualinstall :: Architecture -> Property Linux + manualinstall arch = tightenTargets $ check (not <$> doesFileExist binstack) $ + propertyList "stack installed from upstream tarball" $ props + & cmdProperty "wget" ["https://www.stackage.org/stack/linux-" ++ arch, "-O", tmptar] `assume` MadeChange - , File.dirExists tmpdir - , cmdProperty "tar" ["xf", tmptar, "-C", tmpdir, "--strip-components=1"] + & File.dirExists tmpdir + & cmdProperty "tar" ["xf", tmptar, "-C", tmpdir, "--strip-components=1"] `assume` MadeChange - , cmdProperty "mv" [tmpdir "stack", binstack] + & cmdProperty "mv" [tmpdir "stack", binstack] `assume` MadeChange - , cmdProperty "rm" ["-rf", tmpdir, tmptar] + & cmdProperty "rm" ["-rf", tmpdir, tmptar] `assume` MadeChange - ] binstack = "/usr/bin/stack" tmptar = "/root/stack.tar.gz" tmpdir = "/root/stack" -armAutoBuilder :: System -> Flavor -> Property HasInfo -armAutoBuilder osver flavor = +armAutoBuilder :: DebianSuite -> Architecture -> Flavor -> Property (HasInfo + Debian) +armAutoBuilder suite arch flavor = propertyList "arm git-annex autobuilder" $ props - & standardAutoBuilder osver flavor + & standardAutoBuilder suite arch flavor & buildDepsNoHaskellLibs -- Works around ghc crash with parallel builds on arm. & (homedir ".cabal" "config") @@ -172,26 +174,30 @@ armAutoBuilder osver flavor = androidAutoBuilderContainer :: Times -> TimeOut -> Systemd.Container androidAutoBuilderContainer crontimes timeout = - androidContainer "android-git-annex-builder" (tree "android" Nothing) builddir - & Apt.unattendedUpgrades - & buildDepsNoHaskellLibs - & autobuilder "android" crontimes timeout + androidAutoBuilderContainer' "android-git-annex-builder" + (tree "android" Nothing) builddir crontimes timeout -- Android is cross-built in a Debian i386 container, using the Android NDK. -androidContainer - :: (IsProp (Property (CInfo NoInfo i)), (Combines (Property NoInfo) (Property i))) - => Systemd.MachineName - -> Property i +androidAutoBuilderContainer' + :: Systemd.MachineName + -> Property DebianLike -> FilePath + -> Times + -> TimeOut -> Systemd.Container -androidContainer name setupgitannexdir gitannexdir = Systemd.container name osver bootstrap - & Apt.stdSourcesList - & User.accountFor (User builduser) - & File.dirExists gitbuilderdir - & File.ownerGroup homedir (User builduser) (Group builduser) - & flagFile chrootsetup ("/chrootsetup") - `requires` setupgitannexdir - & haskellPkgsInstalled "android" +androidAutoBuilderContainer' name setupgitannexdir gitannexdir crontimes timeout = + Systemd.container name $ \d -> bootstrap d $ props + & osDebian (Stable "jessie") "i386" + & Apt.stdSourcesList + & User.accountFor (User builduser) + & File.dirExists gitbuilderdir + & File.ownerGroup homedir (User builduser) (Group builduser) + & flagFile chrootsetup ("/chrootsetup") + `requires` setupgitannexdir + & haskellPkgsInstalled "android" + & Apt.unattendedUpgrades + & buildDepsNoHaskellLibs + & autobuilder "android" crontimes timeout where -- Use git-annex's android chroot setup script, which will install -- ghc-android and the NDK, all build deps, etc, in the home @@ -200,5 +206,4 @@ androidContainer name setupgitannexdir gitannexdir = Systemd.container name osve [ "cd " ++ gitannexdir ++ " && ./standalone/android/buildchroot-inchroot" ] `assume` MadeChange - osver = System (Debian (Stable "jessie")) "i386" bootstrap = Chroot.debootstrapped mempty diff --git a/src/Propellor/Property/SiteSpecific/GitHome.hs b/src/Propellor/Property/SiteSpecific/GitHome.hs index 83a1a16a..f14b5f12 100644 --- a/src/Propellor/Property/SiteSpecific/GitHome.hs +++ b/src/Propellor/Property/SiteSpecific/GitHome.hs @@ -5,14 +5,15 @@ import qualified Propellor.Property.Apt as Apt import Propellor.Property.User -- | Clones Joey Hess's git home directory, and runs its fixups script. -installedFor :: User -> Property NoInfo +installedFor :: User -> Property DebianLike installedFor user@(User u) = check (not <$> hasGitDir user) $ - property ("githome " ++ u) (go =<< liftIO (homedir user)) - `requires` Apt.installed ["git"] + go `requires` Apt.installed ["git"] where - go home = do + go :: Property DebianLike + go = property' ("githome " ++ u) $ \w -> do + home <- liftIO (homedir user) let tmpdir = home "githome" - ensureProperty $ combineProperties "githome setup" + ensureProperty w $ combineProperties "githome setup" $ toProps [ userScriptProperty user ["git clone " ++ url ++ " " ++ tmpdir] `assume` MadeChange , property "moveout" $ makeChange $ void $ diff --git a/src/Propellor/Property/SiteSpecific/IABak.hs b/src/Propellor/Property/SiteSpecific/IABak.hs index bb62fba7..b245e444 100644 --- a/src/Propellor/Property/SiteSpecific/IABak.hs +++ b/src/Propellor/Property/SiteSpecific/IABak.hs @@ -15,14 +15,14 @@ repo = "https://github.com/ArchiveTeam/IA.BAK/" userrepo :: String userrepo = "git@gitlab.com:archiveteam/IA.bak.users.git" -publicFace :: Property HasInfo +publicFace :: Property DebianLike publicFace = propertyList "iabak public face" $ props & Git.cloned (User "root") repo "/usr/local/IA.BAK" (Just "server") & Apt.serviceInstalledRunning "apache2" & Cron.niceJob "graph-gen" (Cron.Times "*/10 * * * *") (User "root") "/" "/usr/local/IA.BAK/web/graph-gen.sh" -gitServer :: [Host] -> Property HasInfo +gitServer :: [Host] -> Property (HasInfo + DebianLike) gitServer knownhosts = propertyList "iabak git server" $ props & Git.cloned (User "root") repo "/usr/local/IA.BAK" (Just "server") & Git.cloned (User "root") repo "/usr/local/IA.BAK/client" (Just "master") @@ -42,7 +42,7 @@ gitServer knownhosts = propertyList "iabak git server" $ props "/usr/local/IA.BAK" "./expireemailer" -registrationServer :: [Host] -> Property HasInfo +registrationServer :: [Host] -> Property (HasInfo + DebianLike) registrationServer knownhosts = propertyList "iabak registration server" $ props & User.accountFor (User "registrar") & Ssh.userKeys (User "registrar") (Context "IA.bak.users.git") sshKeys @@ -66,7 +66,7 @@ sshKeys = [ (SshRsa, "ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQCoiE+CPiIQyfWnl/E9iKG3eo4QzlH30vi7xAgKolGaTu6qKy4XPtl+8MNm2Dqn9QEYRVyyOT/XH0yP5dRc6uyReT8dBy03MmLkVbj8Q+nKCz5YOMTxrY3sX6RRXU1zVGjeVd0DtC+rKRT7reoCxef42LAJTm8nCyZu/enAuso5qHqBbqulFz2YXEKfU1SEEXLawtvgGck1KmCyg+pqazeI1eHWXrojQf5isTBKfPQLWVppBkWAf5cA4wP5U1vN9dVirIdw66ds1M8vnGlkTBjxP/HLGBWGYhZHE7QXjXRsk2RIXlHN9q6GdNu8+F3HXS22mst47E4UAeRoiXSMMtF5") ] -graphiteServer :: Property HasInfo +graphiteServer :: Property (HasInfo + DebianLike) graphiteServer = propertyList "iabak graphite server" $ props & Apt.serviceInstalledRunning "apache2" & Apt.installed ["libapache2-mod-wsgi", "graphite-carbon", "graphite-web"] @@ -114,7 +114,8 @@ graphiteServer = propertyList "iabak graphite server" $ props , "" ] where + graphiteCSRF :: Property (HasInfo + DebianLike) graphiteCSRF = withPrivData (Password "csrf-token") (Context "iabak.archiveteam.org") $ - \gettoken -> property "graphite-web CSRF token" $ - gettoken $ \token -> ensureProperty $ File.containsLine + \gettoken -> property' "graphite-web CSRF token" $ \w -> + gettoken $ \token -> ensureProperty w $ File.containsLine "/etc/graphite/local_settings.py" ("SECRET_KEY = '"++ privDataVal token ++"'") diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs index 03f2efcb..0ce64939 100644 --- a/src/Propellor/Property/SiteSpecific/JoeySites.hs +++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs @@ -1,6 +1,8 @@ -- | Specific configuration for Joey Hess's sites. Probably not useful to -- others except as an example. +{-# LANGUAGE FlexibleContexts, TypeFamilies #-} + module Propellor.Property.SiteSpecific.JoeySites where import Propellor.Base @@ -24,7 +26,7 @@ import Data.List import System.Posix.Files import Data.String.Utils -scrollBox :: Property HasInfo +scrollBox :: Property (HasInfo + DebianLike) scrollBox = propertyList "scroll server" $ props & User.accountFor (User "scroll") & Git.cloned (User "scroll") "git://git.kitenet.net/scroll" (d "scroll") Nothing @@ -94,16 +96,12 @@ scrollBox = propertyList "scroll server" $ props s = d "login.sh" g = d "game.sh" -oldUseNetServer :: [Host] -> Property HasInfo +oldUseNetServer :: [Host] -> Property (HasInfo + DebianLike) oldUseNetServer hosts = propertyList "olduse.net server" $ props & Apt.installed ["leafnode"] & oldUseNetInstalled "oldusenet-server" & oldUseNetBackup - & check (not . isSymbolicLink <$> getSymbolicLinkStatus newsspool) - (property "olduse.net spool in place" $ makeChange $ do - removeDirectoryRecursive newsspool - createSymbolicLink (datadir "news") newsspool - ) + & spoolsymlink & "/etc/news/leafnode/config" `File.hasContent` [ "# olduse.net configuration (deployed by propellor)" , "expire = 1000000" -- no expiry via texpire @@ -135,7 +133,15 @@ oldUseNetServer hosts = propertyList "olduse.net server" $ props , Apache.allowAll , " " ] + + spoolsymlink :: Property UnixLike + spoolsymlink = check (not . isSymbolicLink <$> getSymbolicLinkStatus newsspool) + (property "olduse.net spool in place" $ makeChange $ do + removeDirectoryRecursive newsspool + createSymbolicLink (datadir "news") newsspool + ) + oldUseNetBackup :: Property (HasInfo + DebianLike) oldUseNetBackup = Obnam.backup datadir (Cron.Times "33 4 * * *") [ "--repository=sftp://2318@usw-s002.rsync.net/~/olduse.net" , "--client-name=spool" @@ -149,12 +155,12 @@ oldUseNetServer hosts = propertyList "olduse.net server" $ props `requires` Ssh.knownHost hosts "usw-s002.rsync.net" (User "root") keyfile = "/root/.ssh/olduse.net.key" -oldUseNetShellBox :: Property HasInfo +oldUseNetShellBox :: Property DebianLike oldUseNetShellBox = propertyList "olduse.net shellbox" $ props & oldUseNetInstalled "oldusenet" & Service.running "shellinabox" -oldUseNetInstalled :: Apt.Package -> Property HasInfo +oldUseNetInstalled :: Apt.Package -> Property DebianLike oldUseNetInstalled pkg = check (not <$> Apt.isInstalled pkg) $ propertyList ("olduse.net " ++ pkg) $ props & Apt.installed (words "build-essential devscripts debhelper git libncursesw5-dev libpcre3-dev pkg-config bison libicu-dev libidn11-dev libcanlock2-dev libuu-dev ghc libghc-strptime-dev libghc-hamlet-dev libghc-ifelse-dev libghc-hxt-dev libghc-utf8-string-dev libghc-missingh-dev libghc-sha-dev") @@ -170,25 +176,25 @@ oldUseNetInstalled pkg = check (not <$> Apt.isInstalled pkg) $ ] `assume` MadeChange `describe` "olduse.net built" - -kgbServer :: Property HasInfo + +kgbServer :: Property (HasInfo + Debian) kgbServer = propertyList desc $ props & installed & File.hasPrivContent "/etc/kgb-bot/kgb.conf" anyContext `onChange` Service.restarted "kgb-bot" where desc = "kgb.kitenet.net setup" - installed = withOS desc $ \o -> case o of + installed :: Property Debian + installed = withOS desc $ \w o -> case o of (Just (System (Debian Unstable) _)) -> - ensureProperty $ propertyList desc - [ Apt.serviceInstalledRunning "kgb-bot" - , "/etc/default/kgb-bot" `File.containsLine` "BOT_ENABLED=1" + ensureProperty w $ propertyList desc $ props + & Apt.serviceInstalledRunning "kgb-bot" + & "/etc/default/kgb-bot" `File.containsLine` "BOT_ENABLED=1" `describe` "kgb bot enabled" `onChange` Service.running "kgb-bot" - ] _ -> error "kgb server needs Debian unstable (for kgb-bot 1.31+)" -mumbleServer :: [Host] -> Property HasInfo +mumbleServer :: [Host] -> Property (HasInfo + DebianLike) mumbleServer hosts = combineProperties hn $ props & Apt.serviceInstalledRunning "mumble-server" & Obnam.backup "/var/lib/mumble-server" (Cron.Times "55 5 * * *") @@ -209,7 +215,7 @@ mumbleServer hosts = combineProperties hn $ props sshkey = "/root/.ssh/mumble.debian.net.key" -- git.kitenet.net and git.joeyh.name -gitServer :: [Host] -> Property HasInfo +gitServer :: [Host] -> Property (HasInfo + DebianLike) gitServer hosts = propertyList "git.kitenet.net setup" $ props & Obnam.backupEncrypted "/srv/git" (Cron.Times "33 3 * * *") [ "--repository=sftp://2318@usw-s002.rsync.net/~/git.kitenet.net" @@ -266,7 +272,7 @@ gitServer hosts = propertyList "git.kitenet.net setup" $ props type AnnexUUID = String -- | A website, with files coming from a git-annex repository. -annexWebSite :: Git.RepoUrl -> HostName -> AnnexUUID -> [(String, Git.RepoUrl)] -> Property HasInfo +annexWebSite :: Git.RepoUrl -> HostName -> AnnexUUID -> [(String, Git.RepoUrl)] -> Property (HasInfo + DebianLike) annexWebSite origin hn uuid remotes = propertyList (hn ++" website using git-annex") $ props & Git.cloned (User "joey") origin dir Nothing `onChange` setup @@ -308,7 +314,7 @@ annexWebSite origin hn uuid remotes = propertyList (hn ++" website using git-ann , " " ] -apacheSite :: HostName -> Bool -> Apache.ConfigFile -> RevertableProperty NoInfo +apacheSite :: HostName -> Bool -> Apache.ConfigFile -> RevertableProperty DebianLike DebianLike apacheSite hn withssl middle = Apache.siteEnabled hn $ apachecfg hn withssl middle apachecfg :: HostName -> Bool -> Apache.ConfigFile -> Apache.ConfigFile @@ -348,7 +354,7 @@ mainhttpscert True = , " SSLCertificateChainFile /etc/ssl/certs/startssl.pem" ] -gitAnnexDistributor :: Property HasInfo +gitAnnexDistributor :: Property (HasInfo + DebianLike) gitAnnexDistributor = combineProperties "git-annex distributor, including rsync server and signer" $ props & Apt.installed ["rsync"] & File.hasPrivContent "/etc/rsyncd.conf" (Context "git-annex distributor") @@ -364,19 +370,18 @@ gitAnnexDistributor = combineProperties "git-annex distributor, including rsync -- git-annex distribution signing key & Gpg.keyImported (Gpg.GpgKeyId "89C809CB") (User "joey") where - endpoint d = combineProperties ("endpoint " ++ d) - [ File.dirExists d - , File.ownerGroup d (User "joey") (Group "joey") - ] + endpoint d = combineProperties ("endpoint " ++ d) $ props + & File.dirExists d + & File.ownerGroup d (User "joey") (Group "joey") -downloads :: [Host] -> Property HasInfo +downloads :: [Host] -> Property (HasInfo + DebianLike) downloads hosts = annexWebSite "/srv/git/downloads.git" "downloads.kitenet.net" "840760dc-08f0-11e2-8c61-576b7e66acfd" [("eubackup", "ssh://eubackup.kitenet.net/~/lib/downloads/")] `requires` Ssh.knownHost hosts "eubackup.kitenet.net" (User "joey") -tmp :: Property HasInfo +tmp :: Property (HasInfo + DebianLike) tmp = propertyList "tmp.kitenet.net" $ props & annexWebSite "/srv/git/joey/tmp.git" "tmp.kitenet.net" @@ -386,7 +391,7 @@ tmp = propertyList "tmp.kitenet.net" $ props & pumpRss -- Twitter, you kill us. -twitRss :: Property HasInfo +twitRss :: Property DebianLike twitRss = combineProperties "twitter rss" $ props & Git.cloned (User "joey") "git://git.kitenet.net/twitrss.git" dir Nothing & check (not <$> doesFileExist (dir "twitRss")) compiled @@ -409,11 +414,11 @@ twitRss = combineProperties "twitter rss" $ props ] -- Work around for expired ssl cert. -pumpRss :: Property NoInfo +pumpRss :: Property DebianLike pumpRss = Cron.job "pump rss" (Cron.Times "15 * * * *") (User "joey") "/srv/web/tmp.kitenet.net/" "wget https://rss.io.jpope.org/feed/joeyh@identi.ca.atom -O pump.atom.new --no-check-certificate 2>/dev/null; sed 's/ & / /g' pump.atom.new > pump.atom" -ircBouncer :: Property HasInfo +ircBouncer :: Property (HasInfo + DebianLike) ircBouncer = propertyList "IRC bouncer" $ props & Apt.installed ["znc"] & User.accountFor (User "znc") @@ -428,20 +433,19 @@ ircBouncer = propertyList "IRC bouncer" $ props where conf = "/home/znc/.znc/configs/znc.conf" -kiteShellBox :: Property NoInfo -kiteShellBox = propertyList "kitenet.net shellinabox" - [ Apt.installed ["openssl", "shellinabox", "openssh-client"] - , File.hasContent "/etc/default/shellinabox" +kiteShellBox :: Property DebianLike +kiteShellBox = propertyList "kitenet.net shellinabox" $ props + & Apt.installed ["openssl", "shellinabox", "openssh-client"] + & File.hasContent "/etc/default/shellinabox" [ "# Deployed by propellor" , "SHELLINABOX_DAEMON_START=1" , "SHELLINABOX_PORT=443" , "SHELLINABOX_ARGS=\"--no-beep --service=/:SSH:kitenet.net\"" ] `onChange` Service.restarted "shellinabox" - , Service.running "shellinabox" - ] + & Service.running "shellinabox" -githubBackup :: Property HasInfo +githubBackup :: Property (HasInfo + DebianLike) githubBackup = propertyList "github-backup box" $ props & Apt.installed ["github-backup", "moreutils"] & githubKeys @@ -462,7 +466,7 @@ githubBackup = propertyList "github-backup box" $ props ] ++ map gitriddance githubMirrors gitriddance (r, msg) = "(cd " ++ r ++ " && gitriddance " ++ shellEscape msg ++ ")" -githubKeys :: Property HasInfo +githubKeys :: Property (HasInfo + UnixLike) githubKeys = let f = "/home/joey/.github-keys" in File.hasPrivContent f anyContext @@ -482,12 +486,12 @@ githubMirrors = where plzuseurl u = "Please submit changes to " ++ u ++ " instead of using github pull requests, which are not part of my workflow. Just open a todo item there and link to a git repository containing your changes. Did you know, git is a distributed system? The git repository doesn't even need to be on github! Please send any complaints to Github; they don't allow turning off pull requests or redirecting them elsewhere. -- A robot acting on behalf of Joey Hess" -rsyncNetBackup :: [Host] -> Property NoInfo +rsyncNetBackup :: [Host] -> Property DebianLike rsyncNetBackup hosts = Cron.niceJob "rsync.net copied in daily" (Cron.Times "30 5 * * *") (User "joey") "/home/joey/lib/backup" "mkdir -p rsync.net && rsync --delete -az 2318@usw-s002.rsync.net: rsync.net" `requires` Ssh.knownHost hosts "usw-s002.rsync.net" (User "joey") -backupsBackedupFrom :: [Host] -> HostName -> FilePath -> Property NoInfo +backupsBackedupFrom :: [Host] -> HostName -> FilePath -> Property DebianLike backupsBackedupFrom hosts srchost destdir = Cron.niceJob desc (Cron.Times "@reboot") (User "joey") "/" cmd `requires` Ssh.knownHost hosts srchost (User "joey") @@ -495,9 +499,9 @@ backupsBackedupFrom hosts srchost destdir = Cron.niceJob desc desc = "backups copied from " ++ srchost ++ " on boot" cmd = "sleep 30m && rsync -az --bwlimit=300K --partial --delete " ++ srchost ++ ":lib/backup/ " ++ destdir srchost -obnamRepos :: [String] -> Property NoInfo -obnamRepos rs = propertyList ("obnam repos for " ++ unwords rs) - (mkbase : map mkrepo rs) +obnamRepos :: [String] -> Property UnixLike +obnamRepos rs = propertyList ("obnam repos for " ++ unwords rs) $ + toProps (mkbase : map mkrepo rs) where mkbase = mkdir "/home/joey/lib/backup" `requires` mkdir "/home/joey/lib" @@ -505,13 +509,13 @@ obnamRepos rs = propertyList ("obnam repos for " ++ unwords rs) mkdir d = File.dirExists d `before` File.ownerGroup d (User "joey") (Group "joey") -podcatcher :: Property NoInfo +podcatcher :: Property DebianLike podcatcher = Cron.niceJob "podcatcher run hourly" (Cron.Times "55 * * * *") (User "joey") "/home/joey/lib/sound/podcasts" "xargs git-annex importfeed -c annex.genmetadata=true < feeds; mr --quiet update" `requires` Apt.installed ["git-annex", "myrepos"] -kiteMailServer :: Property HasInfo +kiteMailServer :: Property (HasInfo + DebianLike) kiteMailServer = propertyList "kitenet.net mail server" $ props & Postfix.installed & Apt.installed ["postfix-pcre"] @@ -710,7 +714,7 @@ kiteMailServer = propertyList "kitenet.net mail server" $ props -- Configures postfix to relay outgoing mail to kitenet.net, with -- verification via tls cert. -postfixClientRelay :: Context -> Property HasInfo +postfixClientRelay :: Context -> Property (HasInfo + DebianLike) postfixClientRelay ctx = Postfix.mainCfFile `File.containsLines` -- Using smtps not smtp because more networks firewall smtp [ "relayhost = kitenet.net:smtps" @@ -727,7 +731,7 @@ postfixClientRelay ctx = Postfix.mainCfFile `File.containsLines` `requires` hasPostfixCert ctx -- Configures postfix to have the dkim milter, and no other milters. -dkimMilter :: Property HasInfo +dkimMilter :: Property (HasInfo + DebianLike) dkimMilter = Postfix.mainCfFile `File.containsLines` [ "smtpd_milters = inet:localhost:8891" , "non_smtpd_milters = inet:localhost:8891" @@ -740,7 +744,7 @@ dkimMilter = Postfix.mainCfFile `File.containsLines` -- This does not configure postfix to use the dkim milter, -- nor does it set up domainkey DNS. -dkimInstalled :: Property HasInfo +dkimInstalled :: Property (HasInfo + DebianLike) dkimInstalled = go `onChange` Service.restarted "opendkim" where go = propertyList "opendkim installed" $ props @@ -763,17 +767,16 @@ dkimInstalled = go `onChange` Service.restarted "opendkim" domainKey :: (BindDomain, Record) domainKey = (RelDomain "mail._domainkey", TXT "v=DKIM1; k=rsa; p=MIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQCc+/rfzNdt5DseBBmfB3C6sVM7FgVvf4h1FeCfyfwPpVcmPdW6M2I+NtJsbRkNbEICxiP6QY2UM0uoo9TmPqLgiCCG2vtuiG6XMsS0Y/gGwqKM7ntg/7vT1Go9vcquOFFuLa5PnzpVf8hB9+PMFdS4NPTvWL2c5xxshl/RJzICnQIDAQAB") -hasJoeyCAChain :: Property HasInfo +hasJoeyCAChain :: Property (HasInfo + UnixLike) hasJoeyCAChain = "/etc/ssl/certs/joeyca.pem" `File.hasPrivContentExposed` Context "joeyca.pem" -hasPostfixCert :: Context -> Property HasInfo -hasPostfixCert ctx = combineProperties "postfix tls cert installed" - [ "/etc/ssl/certs/postfix.pem" `File.hasPrivContentExposed` ctx - , "/etc/ssl/private/postfix.pem" `File.hasPrivContent` ctx - ] +hasPostfixCert :: Context -> Property (HasInfo + UnixLike) +hasPostfixCert ctx = combineProperties "postfix tls cert installed" $ props + & "/etc/ssl/certs/postfix.pem" `File.hasPrivContentExposed` ctx + & "/etc/ssl/private/postfix.pem" `File.hasPrivContent` ctx -kitenetHttps :: Property HasInfo +kitenetHttps :: Property (HasInfo + DebianLike) kitenetHttps = propertyList "kitenet.net https certs" $ props & File.hasPrivContent "/etc/ssl/certs/web.pem" ctx & File.hasPrivContent "/etc/ssl/private/web.pem" ctx @@ -784,7 +787,7 @@ kitenetHttps = propertyList "kitenet.net https certs" $ props -- Legacy static web sites and redirections from kitenet.net to newer -- sites. -legacyWebSites :: Property HasInfo +legacyWebSites :: Property (HasInfo + DebianLike) legacyWebSites = propertyList "legacy web sites" $ props & Apt.serviceInstalledRunning "apache2" & Apache.modEnabled "rewrite" @@ -944,7 +947,7 @@ legacyWebSites = propertyList "legacy web sites" $ props , "rewriterule (.*) http://joeyh.name$1 [r]" ] -userDirHtml :: Property NoInfo +userDirHtml :: Property DebianLike userDirHtml = File.fileProperty "apache userdir is html" (map munge) conf `onChange` Apache.reloaded `requires` Apache.modEnabled "userdir" @@ -956,10 +959,9 @@ userDirHtml = File.fileProperty "apache userdir is html" (map munge) conf -- -- -- oncalendar example value: "*-*-* 7:30" -alarmClock :: String -> User -> String -> Property NoInfo -alarmClock oncalendar (User user) command = combineProperties - "goodmorning timer installed" - [ "/etc/systemd/system/goodmorning.timer" `File.hasContent` +alarmClock :: String -> User -> String -> Property DebianLike +alarmClock oncalendar (User user) command = combineProperties "goodmorning timer installed" $ props + & "/etc/systemd/system/goodmorning.timer" `File.hasContent` [ "[Unit]" , "Description=good morning" , "" @@ -974,7 +976,7 @@ alarmClock oncalendar (User user) command = combineProperties ] `onChange` (Systemd.daemonReloaded `before` Systemd.restarted "goodmorning.timer") - , "/etc/systemd/system/goodmorning.service" `File.hasContent` + & "/etc/systemd/system/goodmorning.service" `File.hasContent` [ "[Unit]" , "Description=good morning" , "RefuseManualStart=true" @@ -987,8 +989,7 @@ alarmClock oncalendar (User user) command = combineProperties , "ExecStart=/bin/systemd-inhibit --what=handle-lid-switch --why=goodmorning /bin/su " ++ user ++ " -c \"" ++ command ++ "\"" ] `onChange` Systemd.daemonReloaded - , Systemd.enabled "goodmorning.timer" - , Systemd.started "goodmorning.timer" - , "/etc/systemd/logind.conf" `ConfFile.containsIniSetting` + & Systemd.enabled "goodmorning.timer" + & Systemd.started "goodmorning.timer" + & "/etc/systemd/logind.conf" `ConfFile.containsIniSetting` ("Login", "LidSwitchIgnoreInhibited", "no") - ] diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs index 26cdbeb7..6e1690d2 100644 --- a/src/Propellor/Property/Ssh.hs +++ b/src/Propellor/Property/Ssh.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveDataTypeable, TypeFamilies #-} module Propellor.Property.Ssh ( installed, @@ -47,10 +47,13 @@ import qualified Data.Map as M import qualified Data.Set as S import Data.List -installed :: Property NoInfo -installed = Apt.installed ["ssh"] +installed :: Property UnixLike +installed = "ssh installed" ==> (aptinstall `pickOS` unsupportedOS) + where + aptinstall :: Property DebianLike + aptinstall = Apt.installed ["ssh"] -restarted :: Property NoInfo +restarted :: Property DebianLike restarted = Service.restarted "ssh" sshBool :: Bool -> String @@ -62,10 +65,10 @@ sshdConfig = "/etc/ssh/sshd_config" type ConfigKeyword = String -setSshdConfigBool :: ConfigKeyword -> Bool -> Property NoInfo +setSshdConfigBool :: ConfigKeyword -> Bool -> Property DebianLike setSshdConfigBool setting allowed = setSshdConfig setting (sshBool allowed) -setSshdConfig :: ConfigKeyword -> String -> Property NoInfo +setSshdConfig :: ConfigKeyword -> String -> Property DebianLike setSshdConfig setting val = File.fileProperty desc f sshdConfig `onChange` restarted where @@ -84,19 +87,19 @@ data RootLogin | WithoutPassword -- ^ disable password authentication for root, while allowing other authentication methods | ForcedCommandsOnly -- ^ allow root login with public-key authentication, but only if a forced command has been specified for the public key -permitRootLogin :: RootLogin -> Property NoInfo +permitRootLogin :: RootLogin -> Property DebianLike permitRootLogin (RootLogin b) = setSshdConfigBool "PermitRootLogin" b permitRootLogin WithoutPassword = setSshdConfig "PermitRootLogin" "without-password" permitRootLogin ForcedCommandsOnly = setSshdConfig "PermitRootLogin" "forced-commands-only" -passwordAuthentication :: Bool -> Property NoInfo +passwordAuthentication :: Bool -> Property DebianLike passwordAuthentication = setSshdConfigBool "PasswordAuthentication" -- | Configure ssh to not allow password logins. -- -- To prevent lock-out, this is done only once root's -- authorized_keys is in place. -noPasswords :: Property NoInfo +noPasswords :: Property DebianLike noPasswords = check (hasAuthorizedKeys (User "root")) $ passwordAuthentication False @@ -114,7 +117,7 @@ dotFile f user = do -- ports it is configured to listen on. -- -- Revert to prevent it listening on a particular port. -listenPort :: Port -> RevertableProperty NoInfo +listenPort :: Port -> RevertableProperty DebianLike DebianLike listenPort port = enable disable where portline = "Port " ++ fromPort port @@ -133,16 +136,17 @@ hasAuthorizedKeys = go <=< dotFile "authorized_keys" -- | Blows away existing host keys and make new ones. -- Useful for systems installed from an image that might reuse host keys. -- A flag file is used to only ever do this once. -randomHostKeys :: Property NoInfo +randomHostKeys :: Property DebianLike randomHostKeys = flagFile prop "/etc/ssh/.unique_host_keys" `onChange` restarted where - prop = property "ssh random host keys" $ do + prop :: Property UnixLike + prop = property' "ssh random host keys" $ \w -> do void $ liftIO $ boolSystem "sh" [ Param "-c" , Param "rm -f /etc/ssh/ssh_host_*" ] - ensureProperty $ scriptProperty [ "DPKG_MAINTSCRIPT_NAME=postinst DPKG_MAINTSCRIPT_PACKAGE=openssh-server /var/lib/dpkg/info/openssh-server.postinst configure" ] + ensureProperty w $ scriptProperty [ "DPKG_MAINTSCRIPT_NAME=postinst DPKG_MAINTSCRIPT_PACKAGE=openssh-server /var/lib/dpkg/info/openssh-server.postinst configure" ] `assume` MadeChange -- | The text of a ssh public key, for example, "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIB3BJ2GqZiTR2LEoDXyYFgh/BduWefjdKXAsAtzS9zeI" @@ -153,43 +157,51 @@ type PubKeyText = String -- The corresponding private keys come from the privdata. -- -- Any host keys that are not in the list are removed from the host. -hostKeys :: IsContext c => c -> [(SshKeyType, PubKeyText)] -> Property HasInfo -hostKeys ctx l = propertyList desc $ catMaybes $ - map (\(t, pub) -> Just $ hostKey ctx t pub) l ++ [cleanup] +hostKeys :: IsContext c => c -> [(SshKeyType, PubKeyText)] -> Property (HasInfo + DebianLike) +hostKeys ctx l = go `before` cleanup where desc = "ssh host keys configured " ++ typelist (map fst l) + go :: Property (HasInfo + DebianLike) + go = propertyList desc $ toProps $ catMaybes $ + map (\(t, pub) -> Just $ hostKey ctx t pub) l typelist tl = "(" ++ unwords (map fromKeyType tl) ++ ")" alltypes = [minBound..maxBound] staletypes = let have = map fst l in filter (`notElem` have) alltypes - removestale b = map (File.notPresent . flip keyFile b) staletypes + removestale :: Bool -> [Property DebianLike] + removestale b = map (tightenTargets . File.notPresent . flip keyFile b) staletypes + cleanup :: Property DebianLike cleanup - | null staletypes || null l = Nothing - | otherwise = Just $ toProp $ - property ("any other ssh host keys removed " ++ typelist staletypes) $ - ensureProperty $ - combineProperties desc (removestale True ++ removestale False) - `onChange` restarted + | null staletypes || null l = doNothing + | otherwise = + combineProperties ("any other ssh host keys removed " ++ typelist staletypes) + (toProps $ removestale True ++ removestale False) + `onChange` restarted -- | Installs a single ssh host key of a particular type. -- -- The public key is provided to this function; -- the private key comes from the privdata; -hostKey :: IsContext c => c -> SshKeyType -> PubKeyText -> Property HasInfo -hostKey context keytype pub = combineProperties desc - [ hostPubKey keytype pub - , toProp $ property desc $ install File.hasContent True (lines pub) - , withPrivData (keysrc "" (SshPrivKey keytype "")) context $ \getkey -> - property desc $ getkey $ - install File.hasContentProtected False . privDataLines - ] - `onChange` restarted +hostKey :: IsContext c => c -> SshKeyType -> PubKeyText -> Property (HasInfo + DebianLike) +hostKey context keytype pub = go `onChange` restarted where + go = combineProperties desc $ props + & hostPubKey keytype pub + & installpub + & installpriv desc = "ssh host key configured (" ++ fromKeyType keytype ++ ")" - install writer ispub keylines = do - let f = keyFile keytype ispub - ensureProperty $ writer f (keyFileContent keylines) keysrc ext field = PrivDataSourceFileFromCommand field ("sshkey"++ext) ("ssh-keygen -t " ++ sshKeyTypeParam keytype ++ " -f sshkey") + installpub :: Property UnixLike + installpub = keywriter File.hasContent True (lines pub) + installpriv :: Property (HasInfo + UnixLike) + installpriv = withPrivData (keysrc "" (SshPrivKey keytype "")) context $ \getkey -> + property' desc $ \w -> getkey $ + ensureProperty w + . keywriter File.hasContentProtected False + . privDataLines + keywriter p ispub keylines = do + let f = keyFile keytype ispub + p f (keyFileContent keylines) -- Make sure that there is a newline at the end; -- ssh requires this for some types of private keys. @@ -204,7 +216,7 @@ keyFile keytype ispub = "/etc/ssh/ssh_host_" ++ fromKeyType keytype ++ "_key" ++ -- | Indicates the host key that is used by a Host, but does not actually -- configure the host to use it. Normally this does not need to be used; -- use 'hostKey' instead. -hostPubKey :: SshKeyType -> PubKeyText -> Property HasInfo +hostPubKey :: SshKeyType -> PubKeyText -> Property (HasInfo + UnixLike) hostPubKey t = pureInfoProperty "ssh pubkey known" . HostKeyInfo . M.singleton t getHostPubKey :: Propellor (M.Map SshKeyType PubKeyText) @@ -224,7 +236,7 @@ instance Monoid HostKeyInfo where -- parameter when there is a duplicate key HostKeyInfo (new `M.union` old) -userPubKeys :: User -> [(SshKeyType, PubKeyText)] -> Property HasInfo +userPubKeys :: User -> [(SshKeyType, PubKeyText)] -> Property (HasInfo + UnixLike) userPubKeys u@(User n) l = pureInfoProperty ("ssh pubkey for " ++ n) $ UserKeyInfo (M.singleton u (S.fromList l)) @@ -248,8 +260,8 @@ instance Monoid UserKeyInfo where -- -- The public keys are added to the Info, so other properties like -- `authorizedKeysFrom` can use them. -userKeys :: IsContext c => User -> c -> [(SshKeyType, PubKeyText)] -> Property HasInfo -userKeys user@(User name) context ks = combineProperties desc $ +userKeys :: IsContext c => User -> c -> [(SshKeyType, PubKeyText)] -> Property (HasInfo + UnixLike) +userKeys user@(User name) context ks = combineProperties desc $ toProps $ userPubKeys user ks : map (userKeyAt Nothing user context) ks where desc = unwords @@ -264,7 +276,7 @@ userKeys user@(User name) context ks = combineProperties desc $ -- A file can be specified to write the key to somewhere other than -- the default locations. Allows a user to have multiple keys for -- different roles. -userKeyAt :: IsContext c => Maybe FilePath -> User -> c -> (SshKeyType, PubKeyText) -> Property HasInfo +userKeyAt :: IsContext c => Maybe FilePath -> User -> c -> (SshKeyType, PubKeyText) -> Property (HasInfo + UnixLike) userKeyAt dest user@(User u) context (keytype, pubkeytext) = combineProperties desc $ props & pubkey @@ -276,17 +288,21 @@ userKeyAt dest user@(User u) context (keytype, pubkeytext) = , dest , Just $ "(" ++ fromKeyType keytype ++ ")" ] - pubkey = property desc $ install File.hasContent ".pub" [pubkeytext] - privkey = withPrivData (SshPrivKey keytype u) context $ \getkey -> - property desc $ getkey $ - install File.hasContentProtected "" . privDataLines - install writer ext key = do + pubkey :: Property UnixLike + pubkey = property' desc $ \w -> + ensureProperty w =<< installprop File.hasContent ".pub" [pubkeytext] + privkey :: Property (HasInfo + UnixLike) + privkey = withPrivData (SshPrivKey keytype u) context privkey' + privkey' :: ((PrivData -> Propellor Result) -> Propellor Result) -> Property (HasInfo + UnixLike) + privkey' getkey = property' desc $ \w -> getkey $ \k -> + ensureProperty w + =<< installprop File.hasContentProtected "" (privDataLines k) + installprop writer ext key = do f <- liftIO $ keyfile ext - ensureProperty $ combineProperties desc - [ writer f (keyFileContent key) - , File.ownerGroup f user (userGroup user) - , File.ownerGroup (takeDirectory f) user (userGroup user) - ] + return $ combineProperties desc $ props + & writer f (keyFileContent key) + & File.ownerGroup f user (userGroup user) + & File.ownerGroup (takeDirectory f) user (userGroup user) keyfile ext = case dest of Nothing -> do home <- homeDirectory <$> getUserEntryForName u @@ -301,33 +317,34 @@ fromKeyType SshEd25519 = "ed25519" -- | Puts some host's ssh public key(s), as set using `hostPubKey` -- or `hostKey` into the known_hosts file for a user. -knownHost :: [Host] -> HostName -> User -> Property NoInfo -knownHost hosts hn user@(User u) = property desc $ - go =<< knownHostLines hosts hn +knownHost :: [Host] -> HostName -> User -> Property UnixLike +knownHost hosts hn user@(User u) = property' desc $ \w -> + go w =<< knownHostLines hosts hn where desc = u ++ " knows ssh key for " ++ hn - go [] = do + go _ [] = do warningMessage $ "no configured ssh host keys for " ++ hn return FailedChange - go ls = do + go w ls = do f <- liftIO $ dotFile "known_hosts" user - modKnownHost user f $ + ensureProperty w $ modKnownHost user f $ f `File.containsLines` ls `requires` File.dirExists (takeDirectory f) -- | Reverts `knownHost` -unknownHost :: [Host] -> HostName -> User -> Property NoInfo -unknownHost hosts hn user@(User u) = property desc $ - go =<< knownHostLines hosts hn +unknownHost :: [Host] -> HostName -> User -> Property UnixLike +unknownHost hosts hn user@(User u) = property' desc $ \w -> + go w =<< knownHostLines hosts hn where desc = u ++ " does not know ssh key for " ++ hn - go [] = return NoChange - go ls = do + go _ [] = return NoChange + go w ls = do f <- liftIO $ dotFile "known_hosts" user ifM (liftIO $ doesFileExist f) - ( modKnownHost user f $ f `File.lacksLines` ls + ( ensureProperty w $ modKnownHost user f $ + f `File.lacksLines` ls , return NoChange ) @@ -337,8 +354,8 @@ knownHostLines hosts hn = keylines <$> fromHost hosts hn getHostPubKey keylines (Just m) = map (\k -> hn ++ " " ++ k) (M.elems m) keylines Nothing = [] -modKnownHost :: User -> FilePath -> Property NoInfo -> Propellor Result -modKnownHost user f p = ensureProperty $ p +modKnownHost :: User -> FilePath -> Property UnixLike -> Property UnixLike +modKnownHost user f p = p `requires` File.ownerGroup f user (userGroup user) `requires` File.ownerGroup (takeDirectory f) user (userGroup user) @@ -348,30 +365,30 @@ modKnownHost user f p = ensureProperty $ p -- The ssh keys of the remote user can be set using `keysImported` -- -- Any other lines in the authorized_keys file are preserved as-is. -authorizedKeysFrom :: User -> (User, Host) -> Property NoInfo +authorizedKeysFrom :: User -> (User, Host) -> Property UnixLike localuser@(User ln) `authorizedKeysFrom` (remoteuser@(User rn), remotehost) = - property desc (go =<< authorizedKeyLines remoteuser remotehost) + property' desc (\w -> go w =<< authorizedKeyLines remoteuser remotehost) where remote = rn ++ "@" ++ hostName remotehost desc = ln ++ " authorized_keys from " ++ remote - go [] = do + go _ [] = do warningMessage $ "no configured ssh user keys for " ++ remote return FailedChange - go ls = ensureProperty $ combineProperties desc $ - map (authorizedKey localuser) ls + go w ls = ensureProperty w $ combineProperties desc $ toProps $ + map (setupRevertableProperty . authorizedKey localuser) ls -- | Reverts `authorizedKeysFrom` -unauthorizedKeysFrom :: User -> (User, Host) -> Property NoInfo +unauthorizedKeysFrom :: User -> (User, Host) -> Property UnixLike localuser@(User ln) `unauthorizedKeysFrom` (remoteuser@(User rn), remotehost) = - property desc (go =<< authorizedKeyLines remoteuser remotehost) + property' desc (\w -> go w =<< authorizedKeyLines remoteuser remotehost) where remote = rn ++ "@" ++ hostName remotehost desc = ln ++ " unauthorized_keys from " ++ remote - go [] = return NoChange - go ls = ensureProperty $ combineProperties desc $ - map (revert . authorizedKey localuser) ls + go _ [] = return NoChange + go w ls = ensureProperty w $ combineProperties desc $ toProps $ + map (undoRevertableProperty . authorizedKey localuser) ls authorizedKeyLines :: User -> Host -> Propellor [File.Line] authorizedKeyLines remoteuser remotehost = @@ -380,37 +397,37 @@ authorizedKeyLines remoteuser remotehost = -- | Makes a user have authorized_keys from the PrivData -- -- This removes any other lines from the file. -authorizedKeys :: IsContext c => User -> c -> Property HasInfo +authorizedKeys :: IsContext c => User -> c -> Property (HasInfo + UnixLike) authorizedKeys user@(User u) context = withPrivData (SshAuthorizedKeys u) context $ \get -> - property desc $ get $ \v -> do + property' desc $ \w -> get $ \v -> do f <- liftIO $ dotFile "authorized_keys" user - ensureProperty $ combineProperties desc - [ File.hasContentProtected f (keyFileContent (privDataLines v)) - , File.ownerGroup f user (userGroup user) - , File.ownerGroup (takeDirectory f) user (userGroup user) - ] + ensureProperty w $ combineProperties desc $ props + & File.hasContentProtected f (keyFileContent (privDataLines v)) + & File.ownerGroup f user (userGroup user) + & File.ownerGroup (takeDirectory f) user (userGroup user) where desc = u ++ " has authorized_keys" -- | Ensures that a user's authorized_keys contains a line. -- Any other lines in the file are preserved as-is. -authorizedKey :: User -> String -> RevertableProperty NoInfo +authorizedKey :: User -> String -> RevertableProperty UnixLike UnixLike authorizedKey user@(User u) l = add remove where - add = property (u ++ " has authorized_keys") $ do + add = property' (u ++ " has authorized_keys") $ \w -> do f <- liftIO $ dotFile "authorized_keys" user - modAuthorizedKey f user $ + ensureProperty w $ modAuthorizedKey f user $ f `File.containsLine` l `requires` File.dirExists (takeDirectory f) - remove = property (u ++ " lacks authorized_keys") $ do + remove = property' (u ++ " lacks authorized_keys") $ \w -> do f <- liftIO $ dotFile "authorized_keys" user ifM (liftIO $ doesFileExist f) - ( modAuthorizedKey f user $ f `File.lacksLine` l + ( ensureProperty w $ modAuthorizedKey f user $ + f `File.lacksLine` l , return NoChange ) -modAuthorizedKey :: FilePath -> User -> Property NoInfo -> Propellor Result -modAuthorizedKey f user p = ensureProperty $ p +modAuthorizedKey :: FilePath -> User -> Property UnixLike -> Property UnixLike +modAuthorizedKey f user p = p `before` File.mode f (combineModes [ownerWriteMode, ownerReadMode]) `before` File.ownerGroup f user (userGroup user) `before` File.ownerGroup (takeDirectory f) user (userGroup user) diff --git a/src/Propellor/Property/Sudo.hs b/src/Propellor/Property/Sudo.hs index ed6ba2d5..45ab8af2 100644 --- a/src/Propellor/Property/Sudo.hs +++ b/src/Propellor/Property/Sudo.hs @@ -9,12 +9,13 @@ import Propellor.Property.User -- | Allows a user to sudo. If the user has a password, sudo is configured -- to require it. If not, NOPASSWORD is enabled for the user. -enabledFor :: User -> Property NoInfo -enabledFor user@(User u) = property desc go `requires` Apt.installed ["sudo"] +enabledFor :: User -> Property DebianLike +enabledFor user@(User u) = go `requires` Apt.installed ["sudo"] where - go = do + go :: Property UnixLike + go = property' desc $ \w -> do locked <- liftIO $ isLockedPassword user - ensureProperty $ + ensureProperty w $ fileProperty desc (modify locked . filter (wanted locked)) "/etc/sudoers" diff --git a/src/Propellor/Property/Systemd.hs b/src/Propellor/Property/Systemd.hs index 2234ad5c..e0b7d572 100644 --- a/src/Propellor/Property/Systemd.hs +++ b/src/Propellor/Property/Systemd.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances, TypeFamilies #-} module Propellor.Property.Systemd ( -- * Services @@ -25,6 +25,7 @@ module Propellor.Property.Systemd ( MachineName, Container, container, + debContainer, nspawned, -- * Container configuration containerCfg, @@ -43,6 +44,7 @@ module Propellor.Property.Systemd ( import Propellor.Base import Propellor.Types.Chroot import Propellor.Types.Container +import Propellor.Container import Propellor.Types.Info import qualified Propellor.Property.Chroot as Chroot import qualified Propellor.Property.Apt as Apt @@ -61,23 +63,23 @@ type MachineName = String data Container = Container MachineName Chroot.Chroot Host deriving (Show) -instance PropAccum Container where - (Container n c h) `addProp` p = Container n c (h `addProp` p) - (Container n c h) `addPropFront` p = Container n c (h `addPropFront` p) - getProperties (Container _ _ h) = hostProperties h +instance IsContainer Container where + containerProperties (Container _ _ h) = containerProperties h + containerInfo (Container _ _ h) = containerInfo h + setContainerProperties (Container n c h) ps = Container n c (setContainerProperties h ps) -- | Starts a systemd service. -- -- Note that this does not configure systemd to start the service on boot, -- it only ensures that the service is currently running. -started :: ServiceName -> Property NoInfo -started n = cmdProperty "systemctl" ["start", n] +started :: ServiceName -> Property Linux +started n = tightenTargets $ cmdProperty "systemctl" ["start", n] `assume` NoChange `describe` ("service " ++ n ++ " started") -- | Stops a systemd service. -stopped :: ServiceName -> Property NoInfo -stopped n = cmdProperty "systemctl" ["stop", n] +stopped :: ServiceName -> Property Linux +stopped n = tightenTargets $ cmdProperty "systemctl" ["stop", n] `assume` NoChange `describe` ("service " ++ n ++ " stopped") @@ -85,35 +87,35 @@ stopped n = cmdProperty "systemctl" ["stop", n] -- -- This does not ensure the service is started, it only configures systemd -- to start it on boot. -enabled :: ServiceName -> Property NoInfo -enabled n = cmdProperty "systemctl" ["enable", n] +enabled :: ServiceName -> Property Linux +enabled n = tightenTargets $ cmdProperty "systemctl" ["enable", n] `assume` NoChange `describe` ("service " ++ n ++ " enabled") -- | Disables a systemd service. -disabled :: ServiceName -> Property NoInfo -disabled n = cmdProperty "systemctl" ["disable", n] +disabled :: ServiceName -> Property Linux +disabled n = tightenTargets $ cmdProperty "systemctl" ["disable", n] `assume` NoChange `describe` ("service " ++ n ++ " disabled") -- | Masks a systemd service. -masked :: ServiceName -> RevertableProperty NoInfo +masked :: ServiceName -> RevertableProperty Linux Linux masked n = systemdMask systemdUnmask where - systemdMask = cmdProperty "systemctl" ["mask", n] + systemdMask = tightenTargets $ cmdProperty "systemctl" ["mask", n] `assume` NoChange `describe` ("service " ++ n ++ " masked") - systemdUnmask = cmdProperty "systemctl" ["unmask", n] + systemdUnmask = tightenTargets $ cmdProperty "systemctl" ["unmask", n] `assume` NoChange `describe` ("service " ++ n ++ " unmasked") -- | Ensures that a service is both enabled and started -running :: ServiceName -> Property NoInfo +running :: ServiceName -> Property Linux running n = started n `requires` enabled n -- | Restarts a systemd service. -restarted :: ServiceName -> Property NoInfo -restarted n = cmdProperty "systemctl" ["restart", n] +restarted :: ServiceName -> Property Linux +restarted n = tightenTargets $ cmdProperty "systemctl" ["restart", n] `assume` NoChange `describe` ("service " ++ n ++ " restarted") @@ -126,16 +128,15 @@ journald :: ServiceName journald = "systemd-journald" -- | Enables persistent storage of the journal. -persistentJournal :: Property NoInfo +persistentJournal :: Property DebianLike persistentJournal = check (not <$> doesDirectoryExist dir) $ - combineProperties "persistent systemd journal" - [ cmdProperty "install" ["-d", "-g", "systemd-journal", dir] + combineProperties "persistent systemd journal" $ props + & cmdProperty "install" ["-d", "-g", "systemd-journal", dir] `assume` MadeChange - , cmdProperty "setfacl" ["-R", "-nm", "g:adm:rx,d:g:adm:rx", dir] + & Apt.installed ["acl"] + & cmdProperty "setfacl" ["-R", "-nm", "g:adm:rx,d:g:adm:rx", dir] `assume` MadeChange - , started "systemd-journal-flush" - ] - `requires` Apt.installed ["acl"] + & started "systemd-journal-flush" where dir = "/var/log/journal" @@ -148,11 +149,10 @@ type Option = String -- currently the case for files like journald.conf and system.conf. -- And it assumes the file already exists with -- the right [Header], so new lines can just be appended to the end. -configured :: FilePath -> Option -> String -> Property NoInfo -configured cfgfile option value = combineProperties desc - [ File.fileProperty desc (mapMaybe removeother) cfgfile - , File.containsLine cfgfile line - ] +configured :: FilePath -> Option -> String -> Property Linux +configured cfgfile option value = tightenTargets $ combineProperties desc $ props + & File.fileProperty desc (mapMaybe removeother) cfgfile + & File.containsLine cfgfile line where setting = option ++ "=" line = setting ++ value @@ -162,43 +162,59 @@ configured cfgfile option value = combineProperties desc | otherwise = Just l -- | Causes systemd to reload its configuration files. -daemonReloaded :: Property NoInfo -daemonReloaded = cmdProperty "systemctl" ["daemon-reload"] +daemonReloaded :: Property Linux +daemonReloaded = tightenTargets $ cmdProperty "systemctl" ["daemon-reload"] `assume` NoChange -- | Configures journald, restarting it so the changes take effect. -journaldConfigured :: Option -> String -> Property NoInfo +journaldConfigured :: Option -> String -> Property Linux journaldConfigured option value = configured "/etc/systemd/journald.conf" option value `onChange` restarted journald -- | Ensures machined and machinectl are installed -machined :: Property NoInfo -machined = withOS "machined installed" $ \o -> +machined :: Property Linux +machined = withOS "machined installed" $ \w o -> case o of -- Split into separate debian package since systemd 225. (Just (System (Debian suite) _)) - | not (isStable suite) -> ensureProperty $ + | not (isStable suite) -> ensureProperty w $ Apt.installed ["systemd-container"] _ -> noChange --- | Defines a container with a given machine name, and operating system, +-- | Defines a container with a given machine name, -- and how to create its chroot if not already present. -- --- Properties can be added to configure the Container. +-- Properties can be added to configure the Container. At a minimum, +-- add a property such as `osDebian` to specify the operating system +-- to bootstrap. -- --- > container "webserver" (System (Debian Unstable) "amd64") (Chroot.debootstrapped mempty) +-- > container "webserver" $ \d -> Chroot.debootstrapped mempty d $ props +-- > & osDebian Unstable "amd64" -- > & Apt.installedRunning "apache2" -- > & ... -container :: MachineName -> System -> (FilePath -> Chroot.Chroot) -> Container -container name system mkchroot = Container name c h - & os system - & resolvConfed - & linkJournal +container :: MachineName -> (FilePath -> Chroot.Chroot) -> Container +container name mkchroot = + let c = Container name chroot (host name (containerProps chroot)) + in setContainerProps c $ containerProps c + &^ resolvConfed + &^ linkJournal where - c = mkchroot (containerDir name) - & os system - h = Host name [] mempty + chroot = mkchroot (containerDir name) + +-- | Defines a container with a given machine name, with the chroot +-- created using debootstrap. +-- +-- Properties can be added to configure the Container. At a minimum, +-- add a property such as `osDebian` to specify the operating system +-- to bootstrap. +-- +-- > debContainer "webserver" $ props +-- > & osDebian Unstable "amd64" +-- > & Apt.installedRunning "apache2" +-- > & ... +debContainer :: MachineName -> Props metatypes -> Container +debContainer name ps = container name $ \d -> Chroot.debootstrapped mempty d ps -- | Runs a container using systemd-nspawn. -- @@ -214,13 +230,14 @@ container name system mkchroot = Container name c h -- -- Reverting this property stops the container, removes the systemd unit, -- and deletes the chroot and all its contents. -nspawned :: Container -> RevertableProperty HasInfo +nspawned :: Container -> RevertableProperty (HasInfo + Linux) Linux nspawned c@(Container name (Chroot.Chroot loc builder _) h) = p `describe` ("nspawned " ++ name) where + p :: RevertableProperty (HasInfo + Linux) Linux p = enterScript c `before` chrootprovisioned - `before` nspawnService c (_chrootCfg $ getInfo $ hostInfo h) + `before` nspawnService c (_chrootCfg $ fromInfo $ hostInfo h) `before` containerprovisioned -- Chroot provisioning is run in systemd-only mode, @@ -230,8 +247,9 @@ nspawned c@(Container name (Chroot.Chroot loc builder _) h) = -- Use nsenter to enter container and and run propellor to -- finish provisioning. + containerprovisioned :: RevertableProperty Linux Linux containerprovisioned = - Chroot.propellChroot chroot (enterContainerProcess c) False + tightenTargets (Chroot.propellChroot chroot (enterContainerProcess c) False) doNothing @@ -239,7 +257,7 @@ nspawned c@(Container name (Chroot.Chroot loc builder _) h) = -- | Sets up the service file for the container, and then starts -- it running. -nspawnService :: Container -> ChrootCfg -> RevertableProperty NoInfo +nspawnService :: Container -> ChrootCfg -> RevertableProperty Linux Linux nspawnService (Container name _ _) cfg = setup teardown where service = nspawnServiceName name @@ -264,10 +282,12 @@ nspawnService (Container name _ _) cfg = setup teardown <$> servicefilecontent <*> catchDefaultIO "" (readFile servicefile) + writeservicefile :: Property Linux writeservicefile = property servicefile $ makeChange $ do c <- servicefilecontent File.viaStableTmp (\t -> writeFile t c) servicefile + setupservicefile :: Property Linux setupservicefile = check (not <$> goodservicefile) $ -- if it's running, it has the wrong configuration, -- so stop it @@ -275,8 +295,12 @@ nspawnService (Container name _ _) cfg = setup teardown `requires` daemonReloaded `requires` writeservicefile - setup = started service `requires` setupservicefile `requires` machined + setup :: Property Linux + setup = started service + `requires` setupservicefile + `requires` machined + teardown :: Property Linux teardown = check (doesFileExist servicefile) $ disabled service `requires` stopped service @@ -290,11 +314,12 @@ nspawnServiceParams (SystemdNspawnCfg ps) = -- -- This uses nsenter to enter the container, by looking up the pid of the -- container's init process and using its namespace. -enterScript :: Container -> RevertableProperty NoInfo -enterScript c@(Container name _ _) = setup teardown +enterScript :: Container -> RevertableProperty Linux Linux +enterScript c@(Container name _ _) = + tightenTargets setup tightenTargets teardown where - setup = combineProperties ("generated " ++ enterScriptFile c) - [ scriptfile `File.hasContent` + setup = combineProperties ("generated " ++ enterScriptFile c) $ props + & scriptfile `File.hasContent` [ "#!/usr/bin/perl" , "# Generated by propellor" , "my $pid=`machinectl show " ++ shellEscape name ++ " -p Leader | cut -d= -f2`;" @@ -309,8 +334,7 @@ enterScript c@(Container name _ _) = setup teardown , "}" , "exit(1);" ] - , scriptfile `File.mode` combineModes (readModes ++ executeModes) - ] + & scriptfile `File.mode` combineModes (readModes ++ executeModes) teardown = File.notPresent scriptfile scriptfile = enterScriptFile c @@ -336,11 +360,14 @@ mungename = replace "/" "_" -- When there is no leading dash, "--" is prepended to the parameter. -- -- Reverting the property will remove a parameter, if it's present. -containerCfg :: String -> RevertableProperty HasInfo +containerCfg :: String -> RevertableProperty (HasInfo + Linux) (HasInfo + Linux) containerCfg p = RevertableProperty (mk True) (mk False) where - mk b = pureInfoProperty ("container configuration " ++ (if b then "" else "without ") ++ p') $ - mempty { _chrootCfg = SystemdNspawnCfg [(p', b)] } + mk b = tightenTargets $ + pureInfoProperty desc $ + mempty { _chrootCfg = SystemdNspawnCfg [(p', b)] } + where + desc = "container configuration " ++ (if b then "" else "without ") ++ p' p' = case p of ('-':_) -> p _ -> "--" ++ p @@ -348,18 +375,18 @@ containerCfg p = RevertableProperty (mk True) (mk False) -- | Bind mounts from the host into the container. -- -- This property is enabled by default. Revert it to disable it. -resolvConfed :: RevertableProperty HasInfo +resolvConfed :: RevertableProperty (HasInfo + Linux) (HasInfo + Linux) resolvConfed = containerCfg "bind=/etc/resolv.conf" -- | Link the container's journal to the host's if possible. -- (Only works if the host has persistent journal enabled.) -- -- This property is enabled by default. Revert it to disable it. -linkJournal :: RevertableProperty HasInfo +linkJournal :: RevertableProperty (HasInfo + Linux) (HasInfo + Linux) linkJournal = containerCfg "link-journal=try-guest" -- | Disconnect networking of the container from the host. -privateNetwork :: RevertableProperty HasInfo +privateNetwork :: RevertableProperty (HasInfo + Linux) (HasInfo + Linux) privateNetwork = containerCfg "private-network" class Publishable a where @@ -397,7 +424,7 @@ instance Publishable (Proto, Bound Port) where -- > & Systemd.running Systemd.networkd -- > & Systemd.publish (Port 80 ->- Port 8080) -- > & Apt.installedRunning "apache2" -publish :: Publishable p => p -> RevertableProperty HasInfo +publish :: Publishable p => p -> RevertableProperty (HasInfo + Linux) (HasInfo + Linux) publish p = containerCfg $ "--port=" ++ toPublish p class Bindable a where @@ -410,9 +437,9 @@ instance Bindable (Bound FilePath) where toBind v = hostSide v ++ ":" ++ containerSide v -- | Bind mount a file or directory from the host into the container. -bind :: Bindable p => p -> RevertableProperty HasInfo +bind :: Bindable p => p -> RevertableProperty (HasInfo + Linux) (HasInfo + Linux) bind p = containerCfg $ "--bind=" ++ toBind p -- | Read-only mind mount. -bindRo :: Bindable p => p -> RevertableProperty HasInfo +bindRo :: Bindable p => p -> RevertableProperty (HasInfo + Linux) (HasInfo + Linux) bindRo p = containerCfg $ "--bind-ro=" ++ toBind p diff --git a/src/Propellor/Property/Systemd/Core.hs b/src/Propellor/Property/Systemd/Core.hs index 7842f177..0290bce5 100644 --- a/src/Propellor/Property/Systemd/Core.hs +++ b/src/Propellor/Property/Systemd/Core.hs @@ -6,5 +6,5 @@ import qualified Propellor.Property.Apt as Apt -- dbus is only a Recommends of systemd, but is needed for communication -- from the systemd inside a container to the one outside, so make sure it -- gets installed. -installed :: Property NoInfo +installed :: Property DebianLike installed = Apt.installed ["systemd", "dbus"] diff --git a/src/Propellor/Property/Tor.hs b/src/Propellor/Property/Tor.hs index 0c040f95..92dbd507 100644 --- a/src/Propellor/Property/Tor.hs +++ b/src/Propellor/Property/Tor.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TypeFamilies #-} + module Propellor.Property.Tor where import Propellor.Base @@ -19,7 +21,7 @@ type NodeName = String -- | Sets up a tor bridge. (Not a relay or exit node.) -- -- Uses port 443 -isBridge :: Property NoInfo +isBridge :: Property DebianLike isBridge = configured [ ("BridgeRelay", "1") , ("Exitpolicy", "reject *:*") @@ -31,7 +33,7 @@ isBridge = configured -- | Sets up a tor relay. -- -- Uses port 443 -isRelay :: Property NoInfo +isRelay :: Property DebianLike isRelay = configured [ ("BridgeRelay", "0") , ("Exitpolicy", "reject *:*") @@ -44,21 +46,21 @@ isRelay = configured -- -- This can be moved to a different IP without needing to wait to -- accumulate trust. -named :: NodeName -> Property HasInfo +named :: NodeName -> Property (HasInfo + DebianLike) named n = configured [("Nickname", n')] `describe` ("tor node named " ++ n') `requires` torPrivKey (Context ("tor " ++ n)) where n' = saneNickname n -torPrivKey :: Context -> Property HasInfo +torPrivKey :: Context -> Property (HasInfo + DebianLike) torPrivKey context = f `File.hasPrivContent` context `onChange` File.ownerGroup f user (userGroup user) `requires` torPrivKeyDirExists where f = torPrivKeyDir "secret_id_key" -torPrivKeyDirExists :: Property NoInfo +torPrivKeyDirExists :: Property DebianLike torPrivKeyDirExists = File.dirExists torPrivKeyDir `onChange` setperms `requires` installed @@ -71,20 +73,20 @@ torPrivKeyDir = "/var/lib/tor/keys" -- | A tor server (bridge, relay, or exit) -- Don't use if you just want to run tor for personal use. -server :: Property NoInfo +server :: Property DebianLike server = configured [("SocksPort", "0")] `requires` installed `requires` Apt.installed ["ntp"] `describe` "tor server" -installed :: Property NoInfo +installed :: Property DebianLike installed = Apt.installed ["tor"] -- | Specifies configuration settings. Any lines in the config file -- that set other values for the specified settings will be removed, -- while other settings are left as-is. Tor is restarted when -- configuration is changed. -configured :: [(String, String)] -> Property NoInfo +configured :: [(String, String)] -> Property DebianLike configured settings = File.fileProperty "tor configured" go mainConfig `onChange` restarted where @@ -105,19 +107,19 @@ data BwLimit -- -- For example, PerSecond "30 kibibytes" is the minimum limit -- for a useful relay. -bandwidthRate :: BwLimit -> Property NoInfo +bandwidthRate :: BwLimit -> Property DebianLike bandwidthRate (PerSecond s) = bandwidthRate' s 1 bandwidthRate (PerDay s) = bandwidthRate' s (24*60*60) bandwidthRate (PerMonth s) = bandwidthRate' s (31*24*60*60) -bandwidthRate' :: String -> Integer -> Property NoInfo +bandwidthRate' :: String -> Integer -> Property DebianLike bandwidthRate' s divby = case readSize dataUnits s of Just sz -> let v = show (sz `div` divby) ++ " bytes" in configured [("BandwidthRate", v)] `describe` ("tor BandwidthRate " ++ v) Nothing -> property ("unable to parse " ++ s) noChange -hiddenServiceAvailable :: HiddenServiceName -> Int -> Property NoInfo +hiddenServiceAvailable :: HiddenServiceName -> Int -> Property DebianLike hiddenServiceAvailable hn port = hiddenServiceHostName $ hiddenService hn port where hiddenServiceHostName p = adjustPropertySatisfy p $ \satisfy -> do @@ -126,7 +128,7 @@ hiddenServiceAvailable hn port = hiddenServiceHostName $ hiddenService hn port warningMessage $ unwords ["hidden service hostname:", h] return r -hiddenService :: HiddenServiceName -> Int -> Property NoInfo +hiddenService :: HiddenServiceName -> Int -> Property DebianLike hiddenService hn port = ConfFile.adjustSection (unwords ["hidden service", hn, "available on port", show port]) (== oniondir) @@ -139,18 +141,18 @@ hiddenService hn port = ConfFile.adjustSection oniondir = unwords ["HiddenServiceDir", varLib hn] onionport = unwords ["HiddenServicePort", show port, "127.0.0.1:" ++ show port] -hiddenServiceData :: IsContext c => HiddenServiceName -> c -> Property HasInfo -hiddenServiceData hn context = combineProperties desc - [ installonion "hostname" - , installonion "private_key" - ] +hiddenServiceData :: IsContext c => HiddenServiceName -> c -> Property (HasInfo + DebianLike) +hiddenServiceData hn context = combineProperties desc $ props + & installonion "hostname" + & installonion "private_key" where desc = unwords ["hidden service data available in", varLib hn] + installonion :: FilePath -> Property (HasInfo + DebianLike) installonion f = withPrivData (PrivFile $ varLib hn f) context $ \getcontent -> - property desc $ getcontent $ install $ varLib hn f - install f privcontent = ifM (liftIO $ doesFileExist f) + property' desc $ \w -> getcontent $ install w $ varLib hn f + install w f privcontent = ifM (liftIO $ doesFileExist f) ( noChange - , ensureProperties + , ensureProperty w $ propertyList desc $ toProps [ property desc $ makeChange $ do createDirectoryIfMissing True (takeDirectory f) writeFileProtected f (unlines (privDataLines privcontent)) @@ -161,7 +163,7 @@ hiddenServiceData hn context = combineProperties desc ] ) -restarted :: Property NoInfo +restarted :: Property DebianLike restarted = Service.restarted "tor" mainConfig :: FilePath diff --git a/src/Propellor/Property/Unbound.hs b/src/Propellor/Property/Unbound.hs index f1280b0e..23a5b30d 100644 --- a/src/Propellor/Property/Unbound.hs +++ b/src/Propellor/Property/Unbound.hs @@ -41,13 +41,13 @@ type UnboundValue = String type ZoneType = String -installed :: Property NoInfo +installed :: Property DebianLike installed = Apt.installed ["unbound"] -restarted :: Property NoInfo +restarted :: Property DebianLike restarted = Service.restarted "unbound" -reloaded :: Property NoInfo +reloaded :: Property DebianLike reloaded = Service.reloaded "unbound" dValue :: BindDomain -> String @@ -90,7 +90,7 @@ config = "/etc/unbound/unbound.conf.d/propellor.conf" -- > , (AbsDomain "myrouter.example.com", PTR $ reverseIP $ IPv4 "192.168.1.1") -- > , (AbsDomain "mylaptop.example.com", PTR $ reverseIP $ IPv4 "192.168.1.2") -- > ] -cachingDnsServer :: [UnboundSection] -> [UnboundZone] -> [UnboundHost] -> Property NoInfo +cachingDnsServer :: [UnboundSection] -> [UnboundZone] -> [UnboundHost] -> Property DebianLike cachingDnsServer sections zones hosts = config `hasContent` (comment : otherSections ++ serverSection) `onChange` restarted diff --git a/src/Propellor/Property/User.hs b/src/Propellor/Property/User.hs index c9c91a77..76eae647 100644 --- a/src/Propellor/Property/User.hs +++ b/src/Propellor/Property/User.hs @@ -7,8 +7,8 @@ import qualified Propellor.Property.File as File data Eep = YesReallyDeleteHome -accountFor :: User -> Property NoInfo -accountFor user@(User u) = check nohomedir go +accountFor :: User -> Property DebianLike +accountFor user@(User u) = tightenTargets $ check nohomedir go `describe` ("account for " ++ u) where nohomedir = isNothing <$> catchMaybeIO (homedir user) @@ -18,11 +18,11 @@ accountFor user@(User u) = check nohomedir go , u ] -systemAccountFor :: User -> Property NoInfo +systemAccountFor :: User -> Property DebianLike systemAccountFor user@(User u) = systemAccountFor' user Nothing (Just (Group u)) -systemAccountFor' :: User -> Maybe FilePath -> Maybe Group -> Property NoInfo -systemAccountFor' (User u) mhome mgroup = check nouser go +systemAccountFor' :: User -> Maybe FilePath -> Maybe Group -> Property DebianLike +systemAccountFor' (User u) mhome mgroup = tightenTargets $ check nouser go `describe` ("system account for " ++ u) where nouser = isNothing <$> catchMaybeIO (getUserEntryForName u) @@ -43,8 +43,8 @@ systemAccountFor' (User u) mhome mgroup = check nouser go ] -- | Removes user home directory!! Use with caution. -nuked :: User -> Eep -> Property NoInfo -nuked user@(User u) _ = check hashomedir go +nuked :: User -> Eep -> Property DebianLike +nuked user@(User u) _ = tightenTargets $ check hashomedir go `describe` ("nuked user " ++ u) where hashomedir = isJust <$> catchMaybeIO (homedir user) @@ -55,13 +55,13 @@ nuked user@(User u) _ = check hashomedir go -- | Only ensures that the user has some password set. It may or may -- not be a password from the PrivData. -hasSomePassword :: User -> Property HasInfo +hasSomePassword :: User -> Property (HasInfo + DebianLike) hasSomePassword user = hasSomePassword' user hostContext -- | While hasSomePassword uses the name of the host as context, -- this allows specifying a different context. This is useful when -- you want to use the same password on multiple hosts, for example. -hasSomePassword' :: IsContext c => User -> c -> Property HasInfo +hasSomePassword' :: IsContext c => User -> c -> Property (HasInfo + DebianLike) hasSomePassword' user context = check ((/= HasPassword) <$> getPasswordStatus user) $ hasPassword' user context @@ -71,12 +71,14 @@ hasSomePassword' user context = check ((/= HasPassword) <$> getPasswordStatus us -- A user's password can be stored in the PrivData in either of two forms; -- the full cleartext or a hash. The latter -- is obviously more secure. -hasPassword :: User -> Property HasInfo +hasPassword :: User -> Property (HasInfo + DebianLike) hasPassword user = hasPassword' user hostContext -hasPassword' :: IsContext c => User -> c -> Property HasInfo -hasPassword' (User u) context = go `requires` shadowConfig True +hasPassword' :: IsContext c => User -> c -> Property (HasInfo + DebianLike) +hasPassword' (User u) context = go + `requires` shadowConfig True where + go :: Property (HasInfo + UnixLike) go = withSomePrivData srcs context $ property (u ++ " has password") . setPassword srcs = @@ -94,7 +96,7 @@ setPassword getpassword = getpassword $ go -- | Makes a user's password be the passed String. Highly insecure: -- The password is right there in your config file for anyone to see! -hasInsecurePassword :: User -> String -> Property NoInfo +hasInsecurePassword :: User -> String -> Property DebianLike hasInsecurePassword u@(User n) p = property (n ++ " has insecure password") $ chpasswd u p [] @@ -104,9 +106,10 @@ chpasswd (User user) v ps = makeChange $ withHandle StdinHandle createProcessSuc hPutStrLn h $ user ++ ":" ++ v hClose h -lockedPassword :: User -> Property NoInfo -lockedPassword user@(User u) = check (not <$> isLockedPassword user) go - `describe` ("locked " ++ u ++ " password") +lockedPassword :: User -> Property DebianLike +lockedPassword user@(User u) = tightenTargets $ + check (not <$> isLockedPassword user) go + `describe` ("locked " ++ u ++ " password") where go = cmdProperty "passwd" [ "--lock" @@ -130,8 +133,8 @@ isLockedPassword user = (== LockedPassword) <$> getPasswordStatus user homedir :: User -> IO FilePath homedir (User user) = homeDirectory <$> getUserEntryForName user -hasGroup :: User -> Group -> Property NoInfo -hasGroup (User user) (Group group') = check test go +hasGroup :: User -> Group -> Property DebianLike +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] @@ -145,12 +148,13 @@ hasGroup (User user) (Group group') = check test go -- -- Note that some groups may only exit after installation of other -- software. When a group does not exist yet, the user won't be added to it. -hasDesktopGroups :: User -> Property NoInfo -hasDesktopGroups user@(User u) = property desc $ do +hasDesktopGroups :: User -> Property DebianLike +hasDesktopGroups user@(User u) = property' desc $ \o -> do existinggroups <- map (fst . break (== ':')) . lines <$> liftIO (readFile "/etc/group") let toadd = filter (`elem` existinggroups) desktopgroups - ensureProperty $ 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 @@ -170,11 +174,11 @@ hasDesktopGroups user@(User u) = property desc $ do ] -- | Controls whether shadow passwords are enabled or not. -shadowConfig :: Bool -> Property NoInfo -shadowConfig True = check (not <$> shadowExists) +shadowConfig :: Bool -> Property DebianLike +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" @@ -183,11 +187,11 @@ shadowExists = doesFileExist "/etc/shadow" -- | Ensures that a user has a specified login shell, and that the shell -- is enabled in /etc/shells. -hasLoginShell :: User -> FilePath -> Property NoInfo +hasLoginShell :: User -> FilePath -> Property DebianLike hasLoginShell user loginshell = shellSetTo user loginshell `requires` shellEnabled loginshell -shellSetTo :: User -> FilePath -> Property NoInfo -shellSetTo (User u) loginshell = check needchangeshell +shellSetTo :: User -> FilePath -> Property DebianLike +shellSetTo (User u) loginshell = tightenTargets $ check needchangeshell (cmdProperty "chsh" ["--shell", loginshell, u]) `describe` (u ++ " has login shell " ++ loginshell) where @@ -196,5 +200,6 @@ shellSetTo (User u) loginshell = check needchangeshell return (currshell /= loginshell) -- | Ensures that /etc/shells contains a shell. -shellEnabled :: FilePath -> Property NoInfo -shellEnabled loginshell = "/etc/shells" `File.containsLine` loginshell +shellEnabled :: FilePath -> Property DebianLike +shellEnabled loginshell = tightenTargets $ + "/etc/shells" `File.containsLine` loginshell diff --git a/src/Propellor/Property/Uwsgi.hs b/src/Propellor/Property/Uwsgi.hs index f76d6a0f..4eb94103 100644 --- a/src/Propellor/Property/Uwsgi.hs +++ b/src/Propellor/Property/Uwsgi.hs @@ -11,7 +11,7 @@ type ConfigFile = [String] type AppName = String -appEnabled :: AppName -> ConfigFile -> RevertableProperty NoInfo +appEnabled :: AppName -> ConfigFile -> RevertableProperty DebianLike DebianLike appEnabled an cf = enable disable where enable = appVal an `File.isSymlinkedTo` appValRelativeCfg an @@ -24,9 +24,9 @@ appEnabled an cf = enable disable `requires` installed `onChange` reloaded -appAvailable :: AppName -> ConfigFile -> Property NoInfo +appAvailable :: AppName -> ConfigFile -> Property DebianLike appAvailable an cf = ("uwsgi app available " ++ an) ==> - appCfg an `File.hasContent` (comment : cf) + tightenTargets (appCfg an `File.hasContent` (comment : cf)) where comment = "# deployed with propellor, do not modify" @@ -39,11 +39,11 @@ appVal an = "/etc/uwsgi/apps-enabled/" an <.> "ini" appValRelativeCfg :: AppName -> File.LinkTarget appValRelativeCfg an = File.LinkTarget $ "../apps-available" an <.> "ini" -installed :: Property NoInfo +installed :: Property DebianLike installed = Apt.installed ["uwsgi"] -restarted :: Property NoInfo +restarted :: Property DebianLike restarted = Service.restarted "uwsgi" -reloaded :: Property NoInfo +reloaded :: Property DebianLike reloaded = Service.reloaded "uwsgi" diff --git a/src/Propellor/Property/ZFS/Properties.hs b/src/Propellor/Property/ZFS/Properties.hs index 5ceaf9ba..47d5a9d1 100644 --- a/src/Propellor/Property/ZFS/Properties.hs +++ b/src/Propellor/Property/ZFS/Properties.hs @@ -3,6 +3,7 @@ -- Functions defining zfs Properties. module Propellor.Property.ZFS.Properties ( + ZFSOS, zfsExists, zfsSetProperties ) where @@ -11,9 +12,12 @@ import Propellor.Base import Data.List (intercalate) import qualified Propellor.Property.ZFS.Process as ZP +-- | OS's that support ZFS +type ZFSOS = Linux + FreeBSD + -- | Will ensure that a ZFS volume exists with the specified mount point. -- This requires the pool to exist as well, but we don't create pools yet. -zfsExists :: ZFS -> Property NoInfo +zfsExists :: ZFS -> Property ZFSOS zfsExists z = check (not <$> ZP.zfsExists z) create `describe` unwords ["Creating", zfsName z] where @@ -21,16 +25,16 @@ zfsExists z = check (not <$> ZP.zfsExists z) create create = cmdProperty p a -- | Sets the given properties. Returns True if all were successfully changed, False if not. -zfsSetProperties :: ZFS -> ZFSProperties -> Property NoInfo +zfsSetProperties :: ZFS -> ZFSProperties -> Property ZFSOS zfsSetProperties z setProperties = setall `requires` zfsExists z where spcmd :: String -> String -> (String, [String]) spcmd p v = ZP.zfsCommand "set" [Just (intercalate "=" [p, v]), Nothing] z - setprop :: (String, String) -> Property NoInfo + setprop :: (String, String) -> Property ZFSOS setprop (p, v) = check (ZP.zfsExists z) $ cmdProperty (fst (spcmd p v)) (snd (spcmd p v)) setall = combineProperties (unwords ["Setting properties on", zfsName z]) $ - map setprop $ toPropertyList setProperties + toProps $ map setprop $ toPropertyList setProperties diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs index 5f103b8a..944696dd 100644 --- a/src/Propellor/Spin.hs +++ b/src/Propellor/Spin.hs @@ -90,7 +90,7 @@ spin' mprivdata relay target hst = do error "remote propellor failed" where hn = fromMaybe target relay - sys = case getInfo (hostInfo hst) of + sys = case fromInfo (hostInfo hst) of InfoVal o -> Just o NoInfoVal -> Nothing @@ -170,7 +170,7 @@ getSshTarget target hst return ip configips = map fromIPAddr $ mapMaybe getIPAddr $ - S.toList $ fromDnsInfo $ getInfo $ hostInfo hst + S.toList $ fromDnsInfo $ fromInfo $ hostInfo hst -- Update the privdata, repo url, and git repo over the ssh -- connection, talking to the user's local propellor instance which is diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs index 542a1f66..6d6b14ea 100644 --- a/src/Propellor/Types.hs +++ b/src/Propellor/Types.hs @@ -1,264 +1,156 @@ -{-# LANGUAGE PackageImports #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} -module Propellor.Types - ( Host(..) - , Property - , Info - , HasInfo - , NoInfo - , CInfo +module Propellor.Types ( + -- * Core data types + Host(..) + , Property(..) + , property , Desc - , infoProperty - , simpleProperty - , adjustPropertySatisfy - , propertyInfo - , propertyDesc - , propertyChildren , RevertableProperty(..) - , MkRevertableProperty(..) - , IsProp(..) + , () + , Propellor(..) + , LiftPropellor(..) + , Info + -- * Types of properties + , UnixLike + , Linux + , DebianLike + , Debian + , Buntish + , FreeBSD + , HasInfo + , type (+) + , 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 - , propertySatisfy - , ignoreInfo ) 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 import Propellor.Types.Result +import Propellor.Types.MetaTypes import Propellor.Types.ZFS --- | Everything Propellor knows about a system: Its hostname, --- properties and their collected info. -data Host = Host - { hostName :: HostName - , hostProperties :: [Property HasInfo] - , 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, and an action to ensure it has the --- property. +-- that the system should have, with a descrition, and an action to ensure +-- it has the property. +-- that have the property. +-- +-- There are different types of properties that target different OS's, +-- and so have different metatypes. +-- For example: "Property DebianLike" and "Property FreeBSD". -- --- A property can have associated `Info` or not. This is tracked at the --- type level with Property `NoInfo` and Property `HasInfo`. +-- Also, some properties have associated `Info`, which is indicated in +-- their type: "Property (HasInfo + DebianLike)" -- --- There are many instances and type families, which are mostly used +-- There are many associated type families, which are mostly used -- internally, so you needn't worry about them. -data Property i where - IProperty :: Desc -> Propellor Result -> Info -> [Property HasInfo] -> Property HasInfo - SProperty :: Desc -> Propellor Result -> [Property NoInfo] -> Property NoInfo - --- | Indicates that a Property has associated Info. -data HasInfo --- | Indicates that a Property does not have Info. -data NoInfo - --- | Type level calculation of the combination of HasInfo and/or NoInfo -type family CInfo x y -type instance CInfo HasInfo HasInfo = HasInfo -type instance CInfo HasInfo NoInfo = HasInfo -type instance CInfo NoInfo HasInfo = HasInfo -type instance CInfo NoInfo NoInfo = NoInfo - --- | Constructs a Property with associated Info. -infoProperty - :: Desc -- ^ description of the property - -> Propellor Result -- ^ action to run to satisfy the property (must be idempotent; may run repeatedly) - -> Info -- ^ info associated with the property - -> [Property i] -- ^ child properties - -> Property HasInfo -infoProperty d a i cs = IProperty d a i (map toIProperty cs) +data Property metatypes = Property metatypes Desc (Propellor Result) Info [ChildProperty] --- | Constructs a Property with no Info. -simpleProperty :: Desc -> Propellor Result -> [Property NoInfo] -> Property NoInfo -simpleProperty = SProperty +instance Show (Property metatypes) where + show p = "property " ++ show (getDesc p) -toIProperty :: Property i -> Property HasInfo -toIProperty p@(IProperty {}) = p -toIProperty (SProperty d s cs) = IProperty d s mempty (map toIProperty cs) - -toSProperty :: Property i -> Property NoInfo -toSProperty (IProperty d s _ cs) = SProperty d s (map toSProperty cs) -toSProperty p@(SProperty {}) = p - --- | Makes a version of a Proprty without its Info. --- Use with caution! -ignoreInfo :: Property i -> Property NoInfo -ignoreInfo = toSProperty - --- | Gets the action that can be run to satisfy a Property. --- You should never run this action directly. Use --- 'Propellor.Engine.ensureProperty` instead. -propertySatisfy :: Property i -> Propellor Result -propertySatisfy (IProperty _ a _ _) = a -propertySatisfy (SProperty _ a _) = a +-- | Constructs a Property, from a description and an action to run to +-- ensure the Property is met. +-- +-- 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 = property "foo" $ do +-- > ... +-- > return MadeChange +property + :: SingI metatypes + => Desc + -> Propellor Result + -> Property (MetaTypes metatypes) +property d a = Property sing d a mempty mempty -- | Changes the action that is performed to satisfy a property. -adjustPropertySatisfy :: Property i -> (Propellor Result -> Propellor Result) -> Property i -adjustPropertySatisfy (IProperty d s i cs) f = IProperty d (f s) i cs -adjustPropertySatisfy (SProperty d s cs) f = SProperty d (f s) cs - -propertyInfo :: Property i -> Info -propertyInfo (IProperty _ _ i _) = i -propertyInfo (SProperty {}) = mempty - -propertyDesc :: Property i -> Desc -propertyDesc (IProperty d _ _ _) = d -propertyDesc (SProperty d _ _) = d - -instance Show (Property i) where - show p = "property " ++ show (propertyDesc p) - --- | A Property can include a list of child properties that it also --- satisfies. This allows them to be introspected to collect their info, etc. -propertyChildren :: Property i -> [Property i] -propertyChildren (IProperty _ _ _ cs) = cs -propertyChildren (SProperty _ _ cs) = cs +adjustPropertySatisfy :: Property metatypes -> (Propellor Result -> Propellor Result) -> Property metatypes +adjustPropertySatisfy (Property t d s i c) f = Property t d (f s) i c -- | A property that can be reverted. The first Property is run -- normally and the second is run when it's reverted. -data RevertableProperty i = RevertableProperty - { setupRevertableProperty :: Property i - , undoRevertableProperty :: Property i +data RevertableProperty setupmetatypes undometatypes = RevertableProperty + { setupRevertableProperty :: Property setupmetatypes + , undoRevertableProperty :: Property undometatypes } -instance Show (RevertableProperty i) where +instance Show (RevertableProperty setupmetatypes undometatypes) where show (RevertableProperty p _) = show p -class MkRevertableProperty i1 i2 where - -- | Shorthand to construct a revertable property. - () :: Property i1 -> Property i2 -> RevertableProperty (CInfo i1 i2) - -instance MkRevertableProperty HasInfo HasInfo where - x y = RevertableProperty x y -instance MkRevertableProperty NoInfo NoInfo where - x y = RevertableProperty x y -instance MkRevertableProperty NoInfo HasInfo where - x y = RevertableProperty (toProp x) y -instance MkRevertableProperty HasInfo NoInfo where - x y = RevertableProperty x (toProp y) - --- | Class of types that can be used as properties of a host. -class IsProp p where - setDesc :: p -> Desc -> p - toProp :: p -> Property HasInfo - getDesc :: p -> Desc - -- | Gets the info of the property, combined with all info - -- of all children properties. - getInfoRecursive :: p -> Info - -instance IsProp (Property HasInfo) where - setDesc (IProperty _ a i cs) d = IProperty d a i cs - toProp = id - getDesc = propertyDesc - getInfoRecursive (IProperty _ _ i cs) = - i <> mconcat (map getInfoRecursive cs) -instance IsProp (Property NoInfo) where - setDesc (SProperty _ a cs) d = SProperty d a cs - toProp = toIProperty - getDesc = propertyDesc - getInfoRecursive _ = mempty - -instance IsProp (RevertableProperty HasInfo) where - setDesc = setDescR +-- | Shorthand to construct a revertable property from any two Properties. +() + :: Property setupmetatypes + -> Property undometatypes + -> RevertableProperty setupmetatypes undometatypes +setup undo = RevertableProperty setup undo + +instance IsProp (Property metatypes) where + setDesc (Property t _ a i c) d = Property t d a i c + getDesc (Property _ d _ _ _) = d + getChildren (Property _ _ _ _ c) = c + addChildren (Property t d a i c) c' = Property t d a i (c ++ c') + getInfoRecursive (Property _ _ _ i c) = + i <> mconcat (map getInfoRecursive c) + getInfo (Property _ _ _ i _) = i + toChildProperty (Property _ d a i c) = ChildProperty d a i c + getSatisfy (Property _ _ a _ _) = a + +instance IsProp (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 - toProp (RevertableProperty p1 _) = p1 + getChildren (RevertableProperty p1 _) = getChildren p1 + -- | Only add children to the active side. + addChildren (RevertableProperty p1 p2) c = RevertableProperty (addChildren p1 c) p2 -- | Return the Info of the currently active side. getInfoRecursive (RevertableProperty p1 _p2) = getInfoRecursive p1 -instance IsProp (RevertableProperty NoInfo) where - setDesc = setDescR - getDesc (RevertableProperty p1 _) = getDesc p1 - toProp (RevertableProperty p1 _) = toProp p1 - getInfoRecursive (RevertableProperty _ _) = mempty - --- | Sets the description of both sides. -setDescR :: IsProp (Property i) => RevertableProperty i -> Desc -> RevertableProperty i -setDescR (RevertableProperty p1 p2) d = - RevertableProperty (setDesc p1 d) (setDesc p2 ("not " ++ d)) + getInfo (RevertableProperty p1 _p2) = getInfo p1 + toChildProperty (RevertableProperty p1 _p2) = toChildProperty p1 + getSatisfy (RevertableProperty p1 _) = getSatisfy p1 -- | Type level calculation of the type that results from combining two -- types of properties. type family CombinedType x y -type instance CombinedType (Property x) (Property y) = Property (CInfo x y) -type instance CombinedType (RevertableProperty x) (RevertableProperty y) = RevertableProperty (CInfo x y) +type instance CombinedType (Property (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 x) (Property y) = Property (CInfo x y) -type instance CombinedType (Property x) (RevertableProperty y) = Property (CInfo 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 class Combines x y where -- | Combines together two properties, yielding a property that - -- has the description and info of the first, and that has the second - -- property as a child. + -- has the description and info of the first, and that has the + -- second property as a child property. combineWith :: ResultCombiner -- ^ How to combine the actions to satisfy the properties. @@ -269,73 +161,37 @@ class Combines x y where -> y -> CombinedType x y -instance Combines (Property HasInfo) (Property HasInfo) where - combineWith f _ (IProperty d1 a1 i1 cs1) y@(IProperty _d2 a2 _i2 _cs2) = - IProperty d1 (f a1 a2) i1 (y : cs1) - -instance Combines (Property HasInfo) (Property NoInfo) where - combineWith f _ (IProperty d1 a1 i1 cs1) y@(SProperty _d2 a2 _cs2) = - IProperty d1 (f a1 a2) i1 (toIProperty y : cs1) - -instance Combines (Property NoInfo) (Property HasInfo) where - combineWith f _ (SProperty d1 a1 cs1) y@(IProperty _d2 a2 _i2 _cs2) = - IProperty d1 (f a1 a2) mempty (y : map toIProperty cs1) - -instance Combines (Property NoInfo) (Property NoInfo) where - combineWith f _ (SProperty d1 a1 cs1) y@(SProperty _d2 a2 _cs2) = - SProperty d1 (f a1 a2) (y : cs1) - -instance Combines (RevertableProperty NoInfo) (RevertableProperty NoInfo) where - combineWith = combineWithRR -instance Combines (RevertableProperty HasInfo) (RevertableProperty HasInfo) where - combineWith = combineWithRR -instance Combines (RevertableProperty HasInfo) (RevertableProperty NoInfo) where - combineWith = combineWithRR -instance Combines (RevertableProperty NoInfo) (RevertableProperty HasInfo) where - combineWith = combineWithRR -instance Combines (RevertableProperty NoInfo) (Property HasInfo) where - combineWith = combineWithRP -instance Combines (RevertableProperty NoInfo) (Property NoInfo) where - combineWith = combineWithRP -instance Combines (RevertableProperty HasInfo) (Property HasInfo) where - combineWith = combineWithRP -instance Combines (RevertableProperty HasInfo) (Property NoInfo) where - combineWith = combineWithRP -instance Combines (Property HasInfo) (RevertableProperty NoInfo) where - combineWith = combineWithPR -instance Combines (Property NoInfo) (RevertableProperty NoInfo) where - combineWith = combineWithPR -instance Combines (Property HasInfo) (RevertableProperty HasInfo) where - combineWith = combineWithPR -instance Combines (Property NoInfo) (RevertableProperty HasInfo) where - combineWith = combineWithPR - -combineWithRR - :: Combines (Property x) (Property y) - => ResultCombiner - -> ResultCombiner - -> RevertableProperty x - -> RevertableProperty y - -> RevertableProperty (CInfo x y) -combineWithRR sf tf (RevertableProperty s1 t1) (RevertableProperty s2 t2) = - RevertableProperty - (combineWith sf tf s1 s2) - (combineWith tf sf t1 t2) - -combineWithRP - :: Combines (Property i) y - => (Propellor Result -> Propellor Result -> Propellor Result) - -> (Propellor Result -> Propellor Result -> Propellor Result) - -> RevertableProperty i - -> y - -> CombinedType (Property i) y -combineWithRP sf tf (RevertableProperty x _) y = combineWith sf tf x y - -combineWithPR - :: Combines x (Property i) - => (Propellor Result -> Propellor Result -> Propellor Result) - -> (Propellor Result -> Propellor Result -> Propellor Result) - -> x - -> RevertableProperty i - -> CombinedType x (Property i) -combineWithPR sf tf x (RevertableProperty y _) = combineWith sf tf x y +instance (CheckCombinable x y ~ 'CanCombine, SingI (Combine x y)) => Combines (Property (MetaTypes x)) (Property (MetaTypes y)) where + 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 (CheckCombinable x y ~ 'CanCombine, CheckCombinable x' y' ~ 'CanCombine, 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 (CheckCombinable x y ~ 'CanCombine, 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 (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/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 53fa9e77..2e188ae5 100644 --- a/src/Propellor/Types/Info.hs +++ b/src/Propellor/Types/Info.hs @@ -4,7 +4,8 @@ module Propellor.Types.Info ( Info, IsInfo(..), addInfo, - getInfo, + toInfo, + fromInfo, mapInfo, propagatableInfo, InfoVal(..), @@ -18,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) @@ -46,9 +50,14 @@ 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 + -- The list is reversed here because addInfo builds it up in reverse order. -getInfo :: IsInfo v => Info -> v -getInfo (Info l) = mconcat (mapMaybe extractInfoEntry (reverse l)) +fromInfo :: IsInfo v => Info -> v +fromInfo (Info l) = mconcat (mapMaybe extractInfoEntry (reverse l)) -- | Maps a function over all values stored in the Info that are of the -- appropriate type. diff --git a/src/Propellor/Types/MetaTypes.hs b/src/Propellor/Types/MetaTypes.hs new file mode 100644 index 00000000..e064d76f --- /dev/null +++ b/src/Propellor/Types/MetaTypes.hs @@ -0,0 +1,213 @@ +{-# LANGUAGE TypeOperators, PolyKinds, DataKinds, TypeFamilies, UndecidableInstances, FlexibleInstances, GADTs #-} + +module Propellor.Types.MetaTypes ( + MetaType(..), + UnixLike, + Linux, + DebianLike, + Debian, + Buntish, + FreeBSD, + HasInfo, + MetaTypes, + type (+), + sing, + SingI, + IncludesInfo, + Targets, + NonTargets, + NotSuperset, + Combine, + CheckCombine(..), + CheckCombinable, + type (&&), + Not, + EqT, + Union, +) where + +import Propellor.Types.Singletons +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 ] +-- | Any linux system +type Linux = MetaTypes '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish ] +-- | Debian and derivatives. +type DebianLike = MetaTypes '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish ] +type Debian = MetaTypes '[ 'Targeting 'OSDebian ] +type Buntish = MetaTypes '[ 'Targeting 'OSBuntish ] +type FreeBSD = MetaTypes '[ 'Targeting 'OSFreeBSD ] + +-- | Used to indicate that a Property adds Info to the Host where it's used. +type HasInfo = MetaTypes '[ 'WithInfo ] + +type family IncludesInfo t :: Bool +type instance IncludesInfo (MetaTypes l) = Elem 'WithInfo l + +type MetaTypes = Sing + +-- 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) + OSBuntishS :: Sing ('Targeting 'OSBuntish) + OSFreeBSDS :: Sing ('Targeting 'OSFreeBSD) + WithInfoS :: Sing 'WithInfo +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. +-- +-- For example: +-- +-- > HasInfo + Debian +-- +-- Which is shorthand for this type: +-- +-- > MetaTypes '[WithInfo, Targeting OSDebian] +type family a + b :: ab +type instance (MetaTypes a) + (MetaTypes b) = MetaTypes (Concat a b) + +type family Concat (list1 :: [a]) (list2 :: [a]) :: [a] +type instance Concat '[] bs = bs +type instance Concat (a ': as) bs = a ': (Concat as bs) + +-- | Combine two MetaTypes lists, yielding a list +-- that has targets present in both, and nontargets present in either. +type family Combine (list1 :: [a]) (list2 :: [a]) :: [a] +type instance Combine (list1 :: [a]) (list2 :: [a]) = + (Concat + (NonTargets list1 `Union` NonTargets list2) + (Targets list1 `Intersect` Targets list2) + ) + +-- | Checks if two MetaTypes lists can be safely combined. +-- +-- This should be used anywhere Combine is used, as an additional +-- constraint. For example: +-- +-- > foo :: (CheckCombinable x y ~ 'CanCombine) => x -> y -> Combine x y +type family CheckCombinable (list1 :: [a]) (list2 :: [a]) :: CheckCombine +-- As a special case, if either list is empty, let it be combined with the +-- other. This relies on MetaTypes list always containing at least +-- 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 (l1 ': list1) (l2 ': list2) = + CheckCombinable' (Combine (l1 ': list1) (l2 ': list2)) +type family CheckCombinable' (combinedlist :: [a]) :: CheckCombine +type instance CheckCombinable' '[] = 'CannotCombineTargets +type instance CheckCombinable' (a ': rest) + = If (IsTarget a) + 'CanCombine + (CheckCombinable' rest) + +data CheckCombine = CannotCombineTargets | CanCombine + +-- | Every item in the subset must be in the superset. +-- +-- The name of this was chosen to make type errors more understandable. +type family NotSuperset (superset :: [a]) (subset :: [a]) :: CheckCombine +type instance NotSuperset superset '[] = 'CanCombine +type instance NotSuperset superset (s ': rest) = + If (Elem s superset) + (NotSuperset superset rest) + 'CannotCombineTargets + +type family IsTarget (a :: t) :: Bool +type instance IsTarget ('Targeting a) = 'True +type instance IsTarget 'WithInfo = 'False + +type family Targets (l :: [a]) :: [a] +type instance Targets '[] = '[] +type instance Targets (x ': xs) = + If (IsTarget x) + (x ': Targets xs) + (Targets xs) + +type family NonTargets (l :: [a]) :: [a] +type instance NonTargets '[] = '[] +type instance NonTargets (x ': xs) = + If (IsTarget x) + (NonTargets xs) + (x ': NonTargets xs) + +-- | Type level elem +type family Elem (a :: t) (list :: [t]) :: Bool +type instance Elem a '[] = 'False +type instance Elem a (b ': bs) = EqT a b || Elem a bs + +-- | Type level union. +type family Union (list1 :: [a]) (list2 :: [a]) :: [a] +type instance Union '[] list2 = list2 +type instance Union (a ': rest) list2 = + If (Elem a list2 || Elem a rest) + (Union rest list2) + (a ': Union rest list2) + +-- | Type level intersection. Duplicate list items are eliminated. +type family Intersect (list1 :: [a]) (list2 :: [a]) :: [a] +type instance Intersect '[] list2 = '[] +type instance Intersect (a ': rest) list2 = + If (Elem a list2 && Not (Elem a rest)) + (a ': Intersect rest list2) + (Intersect rest list2) + +-- | Type level equality +-- +-- This is a very clumsy implmentation, but it works back to ghc 7.6. +type family EqT (a :: t) (b :: t) :: Bool +type instance EqT ('Targeting a) ('Targeting b) = EqT a b +type instance EqT 'WithInfo 'WithInfo = 'True +type instance EqT 'WithInfo ('Targeting b) = 'False +type instance EqT ('Targeting a) 'WithInfo = 'False +type instance EqT 'OSDebian 'OSDebian = 'True +type instance EqT 'OSBuntish 'OSBuntish = 'True +type instance EqT 'OSFreeBSD 'OSFreeBSD = 'True +type instance EqT 'OSDebian 'OSBuntish = 'False +type instance EqT 'OSDebian 'OSFreeBSD = 'False +type instance EqT 'OSBuntish 'OSDebian = 'False +type instance EqT 'OSBuntish 'OSFreeBSD = 'False +type instance EqT 'OSFreeBSD 'OSDebian = 'False +type instance EqT 'OSFreeBSD 'OSBuntish = 'False +-- More modern version if the combinatiorial explosion gets too bad later: +-- +-- type family Eq (a :: MetaType) (b :: MetaType) where +-- Eq a a = True +-- Eq a b = False + +-- | An equivilant to the following is in Data.Type.Bool in +-- modern versions of ghc, but is included here to support ghc 7.6. +type family If (cond :: Bool) (tru :: a) (fls :: a) :: a +type instance If 'True tru fls = tru +type instance If 'False tru fls = fls +type family (a :: Bool) || (b :: Bool) :: Bool +type instance 'False || 'False = 'False +type instance 'True || 'True = 'True +type instance 'True || 'False = 'True +type instance 'False || 'True = 'True +type family (a :: Bool) && (b :: Bool) :: Bool +type instance 'False && 'False = 'False +type instance 'True && 'True = 'True +type instance 'True && 'False = 'False +type instance 'False && 'True = 'False +type family Not (a :: Bool) :: Bool +type instance Not 'False = 'True +type instance Not 'True = 'False + diff --git a/src/Propellor/Types/OS.hs b/src/Propellor/Types/OS.hs index a1ba14d4..d7df5490 100644 --- a/src/Propellor/Types/OS.hs +++ b/src/Propellor/Types/OS.hs @@ -3,6 +3,7 @@ module Propellor.Types.OS ( System(..), Distribution(..), + TargetOS(..), DebianSuite(..), FreeBSDRelease(..), FBSDVersion(..), @@ -16,6 +17,7 @@ module Propellor.Types.OS ( userGroup, Port(..), fromPort, + systemToTargetOS, ) where import Network.BSD (HostName) @@ -28,10 +30,23 @@ data System = System Distribution Architecture data Distribution = Debian DebianSuite - | Buntish Release -- ^ A well-known Debian derivative founded by a space tourist. The actual name of this distribution is not used in Propellor per ) + | Buntish Release -- ^ A well-known Debian derivative founded by a space tourist. The actual name of this distribution is not used in Propellor per | FreeBSD FreeBSDRelease deriving (Show, Eq) +-- | Properties can target one or more OS's; the targets are part +-- of the type of the property, so need to be kept fairly simple. +data TargetOS + = OSDebian + | OSBuntish + | OSFreeBSD + 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". data DebianSuite = Experimental | Unstable | Testing | Stable Release @@ -39,10 +54,10 @@ data DebianSuite = Experimental | Unstable | Testing | Stable Release -- | FreeBSD breaks their releases into "Production" and "Legacy". data FreeBSDRelease = FBSDProduction FBSDVersion | FBSDLegacy FBSDVersion - deriving (Show, Eq) + deriving (Show, Eq) data FBSDVersion = FBSD101 | FBSD102 | FBSD093 - deriving (Eq) + deriving (Eq) instance IsString FBSDVersion where fromString "10.1-RELEASE" = FBSD101 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 diff --git a/src/Propellor/Types/Singletons.hs b/src/Propellor/Types/Singletons.hs new file mode 100644 index 00000000..f2089ee8 --- /dev/null +++ b/src/Propellor/Types/Singletons.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE CPP, DataKinds, PolyKinds, TypeOperators, TypeFamilies, GADTs, UndecidableInstances #-} + +-- | 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) + +-- | A class used to pass singleton values implicitly. +class SingI t where + sing :: Sing t + +-- Lists of singletons +data instance Sing (x :: [k]) where + Nil :: Sing '[] + Cons :: Sing x -> Sing xs -> Sing (x ': xs) +instance (SingI x, SingI xs) => SingI (x ': xs) where sing = Cons sing sing +instance SingI '[] where sing = Nil + +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