From c7609c824ba1ce7cdcdf9c646b721db80333f04b Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 15 Jan 2015 20:15:01 -0400 Subject: Add descriptions of how to set missing fields to --list-fields output. (Minor API changes) --- debian/changelog | 7 +++++++ 1 file changed, 7 insertions(+) (limited to 'debian') diff --git a/debian/changelog b/debian/changelog index 44335711..c36472e4 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,10 @@ +propellor (1.4.0) UNRELEASED; urgency=medium + + * Add descriptions of how to set missing fields to --list-fields output. + (Minor API changes) + + -- Joey Hess Thu, 15 Jan 2015 20:14:29 -0400 + propellor (1.3.2) unstable; urgency=medium * SSHFP records are also generated for CNAMES of hosts. -- cgit v1.2.3 From afee550e708cb50a72f0505e3c4ca8f775f39ef0 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 18 Jan 2015 18:02:07 -0400 Subject: Property tree Properties now form a tree, instead of the flat list used before. This simplifies propigation of Info from the Properties used inside a container to the outer host; the Property that docks the container on the host can just have as child properties all the inner Properties, and their Info can then be gathered recursively. (Although in practice it still needs to be filtered, since not all Info should propigate out of a container.) Note that there is no change to how Properties are actually satisfied. Just because a Property lists some child properties, this does not mean they always have their propertySatisfy actions run. It's still up to the parent property to run those actions. That's necessary so that a container's properties can be satisfied inside it, not outside. It also allows property combinators to add the combined Properties to their childProperties list, even if, like onChange, they don't always run the child properties at all. Testing: I tested that the exact same Info is calculated before and after this change, for every Host in my config file. --- debian/changelog | 4 ++- src/Propellor/Engine.hs | 2 +- src/Propellor/Host.hs | 46 ++++++++++++++---------- src/Propellor/Info.hs | 2 +- src/Propellor/Property.hs | 20 ++++------- src/Propellor/Property/Chroot.hs | 4 ++- src/Propellor/Property/Dns.hs | 2 +- src/Propellor/Property/Docker.hs | 4 +-- src/Propellor/Property/SiteSpecific/JoeySites.hs | 1 - src/Propellor/Types.hs | 33 ++++++++++------- 10 files changed, 67 insertions(+), 51 deletions(-) (limited to 'debian') diff --git a/debian/changelog b/debian/changelog index c36472e4..c458de81 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,7 +1,9 @@ propellor (1.4.0) UNRELEASED; urgency=medium * Add descriptions of how to set missing fields to --list-fields output. - (Minor API changes) + * Properties now form a tree, instead of the flat list used before. + This includes the properties used inside a container. + (API change) -- Joey Hess Thu, 15 Jan 2015 20:14:29 -0400 diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs index 667f6bfb..22fbdfbb 100644 --- a/src/Propellor/Engine.hs +++ b/src/Propellor/Engine.hs @@ -35,7 +35,7 @@ import Utility.Monad mainProperties :: Host -> IO () mainProperties host = do ret <- runPropellor host $ - ensureProperties [Property "overall" (ensureProperties $ hostProperties host) mempty] + ensureProperties [Property "overall" (ensureProperties $ hostProperties host) mempty mempty] h <- mkMessageHandle whenConsole h $ setTitle "propellor: done" diff --git a/src/Propellor/Host.hs b/src/Propellor/Host.hs index 896db676..cfe90949 100644 --- a/src/Propellor/Host.hs +++ b/src/Propellor/Host.hs @@ -3,12 +3,9 @@ module Propellor.Host where import Data.Monoid -import qualified Data.Set as S import Propellor.Types -import Propellor.Info import Propellor.Property -import Propellor.PrivData -- | Starts accumulating the properties of a Host. -- @@ -35,8 +32,10 @@ class Hostlike h where getHost :: h -> Host instance Hostlike Host where - (Host hn ps is) & p = Host hn (ps ++ [toProp p]) (is <> getInfo p) - (Host hn ps is) &^ p = Host hn ([toProp p] ++ ps) (getInfo p <> is) + (Host hn ps is) & p = Host hn (ps ++ [toProp p]) + (is <> getInfoRecursive p) + (Host hn ps is) &^ p = Host hn ([toProp p] ++ ps) + (getInfoRecursive p <> is) getHost h = h -- | Adds a property in reverted form. @@ -47,18 +46,29 @@ infixl 1 &^ infixl 1 & infixl 1 ! --- | When eg, docking a container, some of the Info about the container --- should propigate out to the Host it's on. This includes DNS info, --- so that eg, aliases of the container are reflected in the dns for the --- host where it runs. +-- | Adjust the provided Property, adding to its +-- propertyChidren the properties of the Hostlike. + +-- The Info of the propertyChildren is adjusted to only include +-- info that should be propigated out to the Property. +-- +-- DNS Info is propigated, so that eg, aliases of a Hostlike +-- are reflected in the dns for the host where it runs. -- --- This adjusts the Property that docks a container, to include such info --- from the container. -propigateInfo :: Hostlike hl => hl -> Property -> (Info -> Info) -> Property -propigateInfo hl p f = combineProperties (propertyDesc p) $ - p' : dnsprops ++ privprops +-- PrivData Info is propigated, so that properties used inside a +-- Hostlike will have the necessary PrivData available. +propigateHostLike :: Hostlike hl => hl -> Property -> Property +propigateHostLike hl prop = prop + { propertyChildren = propertyChildren prop ++ hostprops + } where - p' = p { propertyInfo = f (propertyInfo p) } - i = hostInfo (getHost hl) - dnsprops = map addDNS (S.toList $ _dns i) - privprops = map addPrivData (S.toList $ _privData i) + hostprops = map go $ hostProperties $ getHost hl + go p = + let i = propertyInfo p + in p + { propertyInfo = mempty + { _dns = _dns i + , _privData = _privData i + } + , propertyChildren = map go (propertyChildren p) + } diff --git a/src/Propellor/Info.hs b/src/Propellor/Info.hs index ccb27cf3..15ea9466 100644 --- a/src/Propellor/Info.hs +++ b/src/Propellor/Info.hs @@ -12,7 +12,7 @@ import Data.Monoid import Control.Applicative pureInfoProperty :: Desc -> Info -> Property -pureInfoProperty desc = Property ("has " ++ desc) (return NoChange) +pureInfoProperty desc i = Property ("has " ++ desc) (return NoChange) i mempty askInfo :: (Info -> Val a) -> Propellor (Maybe a) askInfo f = asks (fromVal . f . hostInfo) diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs index c0878fb6..43690735 100644 --- a/src/Propellor/Property.hs +++ b/src/Propellor/Property.hs @@ -16,19 +16,19 @@ import Utility.Monad -- Constructs a Property. property :: Desc -> Propellor Result -> Property -property d s = Property d s mempty +property d s = Property d s mempty mempty -- | 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 propigate overall success/failure. propertyList :: Desc -> [Property] -> Property -propertyList desc ps = Property desc (ensureProperties ps) (combineInfos ps) +propertyList desc ps = Property desc (ensureProperties ps) mempty ps -- | Combines a list of properties, resulting in one property that -- ensures each in turn. Stops if a property fails. combineProperties :: Desc -> [Property] -> Property -combineProperties desc ps = Property desc (go ps NoChange) (combineInfos ps) +combineProperties desc ps = Property desc (go ps NoChange) mempty ps where go [] rs = return rs go (l:ls) rs = do @@ -67,15 +67,16 @@ flagFile' p getflagfile = adjustProperty p $ \satisfy -> do --- | Whenever a change has to be made for a Property, causes a hook -- Property to also be run, but not otherwise. onChange :: Property -> Property -> Property -p `onChange` hook = Property (propertyDesc p) satisfy (combineInfo p hook) - where - satisfy = do +p `onChange` hook = p + { propertySatisfy = do r <- ensureProperty p case r of MadeChange -> do r' <- ensureProperty hook return $ r <> r' _ -> return r + , propertyChildren = propertyChildren p ++ [hook] + } (==>) :: Desc -> Property -> Property (==>) = flip describe @@ -128,13 +129,6 @@ revert (RevertableProperty p1 p2) = RevertableProperty p2 p1 adjustProperty :: Property -> (Propellor Result -> Propellor Result) -> Property adjustProperty p f = p { propertySatisfy = f (propertySatisfy p) } --- | Combines the Info of two properties. -combineInfo :: (IsProp p, IsProp q) => p -> q -> Info -combineInfo p q = getInfo p <> getInfo q - -combineInfos :: IsProp p => [p] -> Info -combineInfos = mconcat . map getInfo - makeChange :: IO () -> Propellor Result makeChange a = liftIO a >> return MadeChange diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs index 3da8b0d6..de99e6c4 100644 --- a/src/Propellor/Property/Chroot.hs +++ b/src/Propellor/Property/Chroot.hs @@ -76,7 +76,9 @@ provisioned' propigator c@(Chroot loc system builderconf _) systemdonly = Revert teardown = toProp (revert built) propigateChrootInfo :: Chroot -> Property -> Property -propigateChrootInfo c p = propigateInfo c p (<> chrootInfo c) +propigateChrootInfo c p = propigateHostLike c p' + where + p' = p { propertyInfo = propertyInfo p <> chrootInfo c } chrootInfo :: Chroot -> Info chrootInfo (Chroot loc _ _ h) = diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs index ceda2e07..6114834c 100644 --- a/src/Propellor/Property/Dns.hs +++ b/src/Propellor/Property/Dns.hs @@ -78,7 +78,7 @@ setupPrimary zonefile mknamedconffile hosts domain soa rs = (partialzone, zonewarnings) = genZone indomain hostmap domain soa baseprop = Property ("dns primary for " ++ domain) satisfy - (addNamedConf conf) + (addNamedConf conf) [] satisfy = do sshfps <- concat <$> mapM (genSSHFP domain) (M.elems hostmap) let zone = partialzone diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs index eb0d8ec5..3e2fbaf3 100644 --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -134,9 +134,9 @@ docked ctr@(Container _ h) = RevertableProperty ] propigateContainerInfo :: Container -> Property -> Property -propigateContainerInfo ctr@(Container _ h) p = - propigateInfo ctr p (<> dockerinfo) +propigateContainerInfo ctr@(Container _ h) p = propigateHostLike ctr p' where + p' = p { propertyInfo = propertyInfo p <> dockerinfo } dockerinfo = dockerInfo $ mempty { _dockerContainers = M.singleton (hostName h) h } diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs index a2eb44b0..10312b4e 100644 --- a/src/Propellor/Property/SiteSpecific/JoeySites.hs +++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs @@ -419,7 +419,6 @@ kiteMailServer = propertyList "kitenet.net mail server" , "/etc/default/spamassassin" `File.containsLines` [ "# Propellor deployed" , "ENABLED=1" - , "CRON=1" , "OPTIONS=\"--create-prefs --max-children 5 --helper-home-dir\"" , "CRON=1" , "NICE=\"--nicelevel 15\"" diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs index ab84a46b..9f1c8f1b 100644 --- a/src/Propellor/Types.hs +++ b/src/Propellor/Types.hs @@ -4,7 +4,7 @@ module Propellor.Types ( Host(..) , Info(..) - , getInfo + , getInfoRecursive , Propellor(..) , Property(..) , RevertableProperty(..) @@ -38,7 +38,6 @@ import "mtl" Control.Monad.RWS.Strict import "MonadCatchIO-transformers" Control.Monad.CatchIO import qualified Data.Set as S import qualified Data.Map as M -import qualified Propellor.Types.Dns as Dns import Propellor.Types.OS import Propellor.Types.Chroot @@ -46,9 +45,10 @@ import Propellor.Types.Dns import Propellor.Types.Docker import Propellor.Types.PrivData import Propellor.Types.Empty +import qualified Propellor.Types.Dns as Dns -- | Everything Propellor knows about a system: Its hostname, --- properties and other info. +-- properties and their collected info. data Host = Host { hostName :: HostName , hostProperties :: [Property] @@ -77,7 +77,15 @@ data Property = Property , propertySatisfy :: Propellor Result -- ^ must be idempotent; may run repeatedly , propertyInfo :: Info - -- ^ a property can add info to the host. + -- ^ info associated with the property + , propertyChildren :: [Property] + -- ^ A property can include a list of child properties. + -- This allows them to be introspected to collect their info, + -- etc. + -- + -- Note that listing Properties here does not ensure that + -- their propertySatisfy is run when satisfying the parent + -- property; it's up to the parent's propertySatisfy to do that. } instance Show Property where @@ -93,21 +101,22 @@ class IsProp p where -- | Indicates that the first property can only be satisfied -- once the second one is. requires :: p -> Property -> p - getInfo :: p -> Info + -- | Gets the info of the property, combined with all info + -- of all children properties. + getInfoRecursive :: p -> Info instance IsProp Property where describe p d = p { propertyDesc = d } toProp p = p - getInfo = propertyInfo - x `requires` y = Property (propertyDesc x) satisfy info - where - info = getInfo y <> getInfo x - satisfy = do + getInfoRecursive p = propertyInfo p <> mconcat (map getInfoRecursive (propertyChildren p)) + x `requires` y = x + { propertySatisfy = do r <- propertySatisfy y case r of FailedChange -> return FailedChange _ -> propertySatisfy x - + , propertyChildren = y : propertyChildren x + } instance IsProp RevertableProperty where -- | Sets the description of both sides. @@ -117,7 +126,7 @@ instance IsProp RevertableProperty where (RevertableProperty p1 p2) `requires` y = RevertableProperty (p1 `requires` y) p2 -- | Return the Info of the currently active side. - getInfo (RevertableProperty p1 _p2) = getInfo p1 + getInfoRecursive (RevertableProperty p1 _p2) = getInfoRecursive p1 type Desc = String -- cgit v1.2.3 From 4da4c4a70feeb9f11f9e521a45fb51d16082802a Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 19 Jan 2015 14:29:09 -0400 Subject: use git.joeyh.name in preference to git.kitenet.net --- debian/control | 2 +- src/Propellor.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) (limited to 'debian') diff --git a/debian/control b/debian/control index 24ff39cb..a9b6c2ce 100644 --- a/debian/control +++ b/debian/control @@ -18,7 +18,7 @@ Build-Depends: libghc-monadcatchio-transformers-dev, Maintainer: Gergely Nagy Standards-Version: 3.9.6 -Vcs-Git: git://git.kitenet.net/propellor +Vcs-Git: git://git.joeyh.name/propellor Homepage: http://propellor.branchable.com/ Package: propellor diff --git a/src/Propellor.hs b/src/Propellor.hs index d0e89ca5..3eddd8d7 100644 --- a/src/Propellor.hs +++ b/src/Propellor.hs @@ -27,7 +27,7 @@ -- -- See config.hs for a more complete example, and clone Propellor's -- git repository for a deployable system using Propellor: --- git clone +-- git clone module Propellor ( module Propellor.Types -- cgit v1.2.3 From 04d4d0d6c43dcf7643417bb16927f314b55e42fc Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 19 Jan 2015 14:43:25 -0400 Subject: Fix info propigation from fallback combinator's second Property. --- debian/changelog | 1 + src/Propellor/Property.hs | 12 +++++++----- 2 files changed, 8 insertions(+), 5 deletions(-) (limited to 'debian') diff --git a/debian/changelog b/debian/changelog index c458de81..b9d1373e 100644 --- a/debian/changelog +++ b/debian/changelog @@ -4,6 +4,7 @@ propellor (1.4.0) UNRELEASED; urgency=medium * Properties now form a tree, instead of the flat list used before. This includes the properties used inside a container. (API change) + * Fix info propigation from fallback combinator's second Property. -- Joey Hess Thu, 15 Jan 2015 20:14:29 -0400 diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs index 43690735..9db08b2d 100644 --- a/src/Propellor/Property.hs +++ b/src/Propellor/Property.hs @@ -92,11 +92,13 @@ check c p = adjustProperty p $ \satisfy -> ifM (liftIO c) -- | Tries the first property, but if it fails to work, instead uses -- the second. fallback :: Property -> Property -> Property -fallback p1 p2 = adjustProperty p1 $ \satisfy -> do - r <- satisfy - if r == FailedChange - then propertySatisfy p2 - else return r +fallback p1 p2 = p1' { propertyChildren = p2 : propertyChildren p1' } + where + p1' = adjustProperty p1 $ \satisfy -> do + r <- satisfy + if r == FailedChange + then propertySatisfy p2 + else return r -- | Marks a Property as trivial. It can only return FailedChange or -- NoChange. -- cgit v1.2.3 From 88082c729344a48dd060826c1f74c486c1d91ac8 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 21 Jan 2015 22:48:44 -0400 Subject: Added systemd configuration properties. --- config-joey.hs | 1 + debian/changelog | 1 + src/Propellor/Property/Systemd.hs | 36 ++++++++++++++++++++++++++++++++++++ 3 files changed, 38 insertions(+) (limited to 'debian') diff --git a/config-joey.hs b/config-joey.hs index 83839489..89e94192 100644 --- a/config-joey.hs +++ b/config-joey.hs @@ -145,6 +145,7 @@ kite = standardSystemUnhardened "kite.kitenet.net" Testing "amd64" & Apt.unattendedUpgrades & Systemd.installed & Systemd.persistentJournal + & Systemd.journaldConfigured "SystemMaxUse" "500M" & Ssh.passwordAuthentication True -- Since ssh password authentication is allowed: & Apt.serviceInstalledRunning "fail2ban" diff --git a/debian/changelog b/debian/changelog index b9d1373e..f60a4a2b 100644 --- a/debian/changelog +++ b/debian/changelog @@ -5,6 +5,7 @@ propellor (1.4.0) UNRELEASED; urgency=medium This includes the properties used inside a container. (API change) * Fix info propigation from fallback combinator's second Property. + * Added systemd configuration properties. -- Joey Hess Thu, 15 Jan 2015 20:14:29 -0400 diff --git a/src/Propellor/Property/Systemd.hs b/src/Propellor/Property/Systemd.hs index 613ed01c..259bb222 100644 --- a/src/Propellor/Property/Systemd.hs +++ b/src/Propellor/Property/Systemd.hs @@ -6,7 +6,11 @@ module Propellor.Property.Systemd ( stopped, enabled, disabled, + restarted, persistentJournal, + Option, + configured, + journaldConfigured, daemonReloaded, Container, container, @@ -60,6 +64,11 @@ disabled :: ServiceName -> Property disabled n = trivial $ cmdProperty "systemctl" ["disable", n] `describe` ("service " ++ n ++ " disabled") +-- | Restarts a systemd service. +restarted :: ServiceName -> Property +restarted n = trivial $ cmdProperty "systemctl" ["restart", n] + `describe` ("service " ++ n ++ " restarted") + -- | Enables persistent storage of the journal. persistentJournal :: Property persistentJournal = check (not <$> doesDirectoryExist dir) $ @@ -72,6 +81,33 @@ persistentJournal = check (not <$> doesDirectoryExist dir) $ where dir = "/var/log/journal" +type Option = String + +-- | Ensures that an option is configured in one of systemd's config files. +-- Does not ensure that the relevant daemon notices the change immediately. +-- +-- This assumes that there is only one [Header] per file, which is +-- currently the case. 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 +configured cfgfile option value = combineProperties desc + [ File.fileProperty desc (mapMaybe removeother) cfgfile + , File.containsLine cfgfile line + ] + where + setting = option ++ "=" + line = setting ++ value + desc = cfgfile ++ " " ++ line + removeother l + | setting `isPrefixOf` l = Nothing + | otherwise = Just l + +-- | Configures journald, restarting it so the changes take effect. +journaldConfigured :: Option -> String -> Property +journaldConfigured option value = + configured "/etc/systemd/journald.conf" option value + `onChange` restarted "systemd-journald" + -- | Causes systemd to reload its configuration files. daemonReloaded :: Property daemonReloaded = trivial $ cmdProperty "systemctl" ["daemon-reload"] -- cgit v1.2.3 From fa66cb49d668ca065324530ced05b72de0499e34 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 21 Jan 2015 23:21:24 -0400 Subject: Added journald configuration properties. --- debian/changelog | 1 + propellor.cabal | 3 + src/Propellor/Property/Systemd/Journald.hs | 54 ++++++++++ src/Utility/DataUnits.hs | 161 +++++++++++++++++++++++++++++ src/Utility/HumanNumber.hs | 21 ++++ 5 files changed, 240 insertions(+) create mode 100644 src/Propellor/Property/Systemd/Journald.hs create mode 100644 src/Utility/DataUnits.hs create mode 100644 src/Utility/HumanNumber.hs (limited to 'debian') diff --git a/debian/changelog b/debian/changelog index f60a4a2b..a5f22d12 100644 --- a/debian/changelog +++ b/debian/changelog @@ -6,6 +6,7 @@ propellor (1.4.0) UNRELEASED; urgency=medium (API change) * Fix info propigation from fallback combinator's second Property. * Added systemd configuration properties. + * Added journald configuration properties. -- Joey Hess Thu, 15 Jan 2015 20:14:29 -0400 diff --git a/propellor.cabal b/propellor.cabal index b410674a..a0a67a8c 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -100,6 +100,7 @@ Library Propellor.Property.Sudo Propellor.Property.Systemd Propellor.Property.Systemd.Core + Propellor.Property.Systemd.Journald Propellor.Property.Tor Propellor.Property.User Propellor.Property.HostingProvider.CloudAtCost @@ -136,11 +137,13 @@ Library Propellor.Property.Chroot.Util Utility.Applicative Utility.Data + Utility.DataUnits Utility.Directory Utility.Env Utility.Exception Utility.FileMode Utility.FileSystemEncoding + Utility.HumanNumber Utility.LinuxMkLibs Utility.Misc Utility.Monad diff --git a/src/Propellor/Property/Systemd/Journald.hs b/src/Propellor/Property/Systemd/Journald.hs new file mode 100644 index 00000000..e852ebd9 --- /dev/null +++ b/src/Propellor/Property/Systemd/Journald.hs @@ -0,0 +1,54 @@ +module Propellor.Property.Systemd.Journald where +import Propellor +import qualified Propellor.Property.Systemd as Systemd +import qualified Propellor.Property.File as File +import Utility.DataUnits + +-- | Configures journald, restarting it so the changes take effect. +configured :: Systemd.Option -> String -> Property +configured option value = + Systemd.configured "/etc/systemd/journald.conf" option value + `onChange` Systemd.restarted "systemd-journald" + +-- The string is parsed to get a data size. +-- Examples: "100 megabytes" or "0.5tb" +type DataSize = String + +configuredSize :: Systemd.Option -> DataSize -> Property +configuredSize option s = case readSize dataUnits s of + Just sz -> configured option (systemdSizeUnits sz) + Nothing -> property ("unable to parse " ++ option ++ " data size " ++ s) noChange + +systemMaxUse :: DataSize -> Property +systemMaxUse = configuredSize "SystemMaxUse" + +runtimeMaxUse :: DataSize -> Property +runtimeMaxUse = configuredSize "RuntimeMaxUse" + +systemKeepFree :: DataSize -> Property +systemKeepFree = configuredSize "SystemKeepFree" + +runtimeKeepFree :: DataSize -> Property +runtimeKeepFree = configuredSize "RuntimeKeepFree" + +systemMaxFileSize :: DataSize -> Property +systemMaxFileSize = configuredSize "SystemMaxFileSize" + +runtimeMaxFileSize :: DataSize -> Property +runtimeMaxFileSize = configuredSize "RuntimeMaxFileSize" + +-- Generates size units as used in journald.conf. +systemdSizeUnits :: Integer -> String +systemdSizeUnits n = filter (/= ' ') (roughSize cfgfileunits True n) + where + cfgfileunits :: [Unit] + cfgfileunits = + [ Unit (p 6) "E" "exabyte" + , Unit (p 5) "P" "petabyte" + , Unit (p 4) "T" "terabyte" + , Unit (p 3) "G" "gigabyte" + , Unit (p 2) "M" "megabyte" + , Unit (p 1) "K" "kilobyte" + ] + p :: Integer -> Integer + p n = 1024^n diff --git a/src/Utility/DataUnits.hs b/src/Utility/DataUnits.hs new file mode 100644 index 00000000..2ece1430 --- /dev/null +++ b/src/Utility/DataUnits.hs @@ -0,0 +1,161 @@ +{- data size display and parsing + - + - Copyright 2011 Joey Hess + - + - License: BSD-2-clause + - + - + - And now a rant: + - + - In the beginning, we had powers of two, and they were good. + - + - Disk drive manufacturers noticed that some powers of two were + - sorta close to some powers of ten, and that rounding down to the nearest + - power of ten allowed them to advertise their drives were bigger. This + - was sorta annoying. + - + - Then drives got big. Really, really big. This was good. + - + - Except that the small rounding error perpretrated by the drive + - manufacturers suffered the fate of a small error, and became a large + - error. This was bad. + - + - So, a committee was formed. And it arrived at a committee-like decision, + - which satisfied noone, confused everyone, and made the world an uglier + - place. As with all committees, this was meh. + - + - And the drive manufacturers happily continued selling drives that are + - increasingly smaller than you'd expect, if you don't count on your + - fingers. But that are increasingly too big for anyone to much notice. + - This caused me to need git-annex. + - + - Thus, I use units here that I loathe. Because if I didn't, people would + - be confused that their drives seem the wrong size, and other people would + - complain at me for not being standards compliant. And we call this + - progress? + -} + +module Utility.DataUnits ( + dataUnits, + storageUnits, + memoryUnits, + bandwidthUnits, + oldSchoolUnits, + Unit(..), + + roughSize, + compareSizes, + readSize +) where + +import Data.List +import Data.Char + +import Utility.HumanNumber + +type ByteSize = Integer +type Name = String +type Abbrev = String +data Unit = Unit ByteSize Abbrev Name + deriving (Ord, Show, Eq) + +dataUnits :: [Unit] +dataUnits = storageUnits ++ memoryUnits + +{- Storage units are (stupidly) powers of ten. -} +storageUnits :: [Unit] +storageUnits = + [ Unit (p 8) "YB" "yottabyte" + , Unit (p 7) "ZB" "zettabyte" + , Unit (p 6) "EB" "exabyte" + , Unit (p 5) "PB" "petabyte" + , Unit (p 4) "TB" "terabyte" + , Unit (p 3) "GB" "gigabyte" + , Unit (p 2) "MB" "megabyte" + , Unit (p 1) "kB" "kilobyte" -- weird capitalization thanks to committe + , Unit (p 0) "B" "byte" + ] + where + p :: Integer -> Integer + p n = 1000^n + +{- Memory units are (stupidly named) powers of 2. -} +memoryUnits :: [Unit] +memoryUnits = + [ Unit (p 8) "YiB" "yobibyte" + , Unit (p 7) "ZiB" "zebibyte" + , Unit (p 6) "EiB" "exbibyte" + , Unit (p 5) "PiB" "pebibyte" + , Unit (p 4) "TiB" "tebibyte" + , Unit (p 3) "GiB" "gibibyte" + , Unit (p 2) "MiB" "mebibyte" + , Unit (p 1) "KiB" "kibibyte" + , Unit (p 0) "B" "byte" + ] + where + p :: Integer -> Integer + p n = 2^(n*10) + +{- Bandwidth units are only measured in bits if you're some crazy telco. -} +bandwidthUnits :: [Unit] +bandwidthUnits = error "stop trying to rip people off" + +{- Do you yearn for the days when men were men and megabytes were megabytes? -} +oldSchoolUnits :: [Unit] +oldSchoolUnits = zipWith (curry mingle) storageUnits memoryUnits + where + mingle (Unit _ a n, Unit s' _ _) = Unit s' a n + +{- approximate display of a particular number of bytes -} +roughSize :: [Unit] -> Bool -> ByteSize -> String +roughSize units short i + | i < 0 = '-' : findUnit units' (negate i) + | otherwise = findUnit units' i + where + units' = sortBy (flip compare) units -- largest first + + findUnit (u@(Unit s _ _):us) i' + | i' >= s = showUnit i' u + | otherwise = findUnit us i' + findUnit [] i' = showUnit i' (last units') -- bytes + + showUnit x (Unit size abbrev name) = s ++ " " ++ unit + where + v = (fromInteger x :: Double) / fromInteger size + s = showImprecise 2 v + unit + | short = abbrev + | s == "1" = name + | otherwise = name ++ "s" + +{- displays comparison of two sizes -} +compareSizes :: [Unit] -> Bool -> ByteSize -> ByteSize -> String +compareSizes units abbrev old new + | old > new = roughSize units abbrev (old - new) ++ " smaller" + | old < new = roughSize units abbrev (new - old) ++ " larger" + | otherwise = "same" + +{- Parses strings like "10 kilobytes" or "0.5tb". -} +readSize :: [Unit] -> String -> Maybe ByteSize +readSize units input + | null parsednum || null parsedunit = Nothing + | otherwise = Just $ round $ number * fromIntegral multiplier + where + (number, rest) = head parsednum + multiplier = head parsedunit + unitname = takeWhile isAlpha $ dropWhile isSpace rest + + parsednum = reads input :: [(Double, String)] + parsedunit = lookupUnit units unitname + + lookupUnit _ [] = [1] -- no unit given, assume bytes + lookupUnit [] _ = [] + lookupUnit (Unit s a n:us) v + | a ~~ v || n ~~ v = [s] + | plural n ~~ v || a ~~ byteabbrev v = [s] + | otherwise = lookupUnit us v + + a ~~ b = map toLower a == map toLower b + + plural n = n ++ "s" + byteabbrev a = a ++ "b" diff --git a/src/Utility/HumanNumber.hs b/src/Utility/HumanNumber.hs new file mode 100644 index 00000000..c3fede95 --- /dev/null +++ b/src/Utility/HumanNumber.hs @@ -0,0 +1,21 @@ +{- numbers for humans + - + - Copyright 2012-2013 Joey Hess + - + - License: BSD-2-clause + -} + +module Utility.HumanNumber where + +{- Displays a fractional value as a string with a limited number + - of decimal digits. -} +showImprecise :: RealFrac a => Int -> a -> String +showImprecise precision n + | precision == 0 || remainder == 0 = show (round n :: Integer) + | otherwise = show int ++ "." ++ striptrailing0s (pad0s $ show remainder) + where + int :: Integer + (int, frac) = properFraction n + remainder = round (frac * 10 ^ precision) :: Integer + pad0s s = replicate (precision - length s) '0' ++ s + striptrailing0s = reverse . dropWhile (== '0') . reverse -- cgit v1.2.3 From d156a1e9ba202761512ee06e497614d58c658697 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 23 Jan 2015 01:18:47 -0400 Subject: Added more network interface configuration properties. --- config-joey.hs | 1 + debian/changelog | 1 + src/Propellor/Property/Network.hs | 87 +++++++++++++++++++++++++++++++++------ 3 files changed, 76 insertions(+), 13 deletions(-) (limited to 'debian') diff --git a/config-joey.hs b/config-joey.hs index 81066983..e1587076 100644 --- a/config-joey.hs +++ b/config-joey.hs @@ -141,6 +141,7 @@ kite = standardSystemUnhardened "kite.kitenet.net" Testing "amd64" , (SshEd25519, "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIFZftKMnH/zH29BHMKbcBO4QsgTrstYFVhbrzrlRzBO3") ] + & Network.static "eth0" `requires` Network.cleanInterfacesFile & Apt.installed ["linux-image-amd64"] & Linode.chainPVGrub 5 & Apt.unattendedUpgrades diff --git a/debian/changelog b/debian/changelog index a5f22d12..18a8a366 100644 --- a/debian/changelog +++ b/debian/changelog @@ -7,6 +7,7 @@ propellor (1.4.0) UNRELEASED; urgency=medium * Fix info propigation from fallback combinator's second Property. * Added systemd configuration properties. * Added journald configuration properties. + * Added more network interface configuration properties. -- Joey Hess Thu, 15 Jan 2015 20:14:29 -0400 diff --git a/src/Propellor/Property/Network.hs b/src/Propellor/Property/Network.hs index c557d453..e04290aa 100644 --- a/src/Propellor/Property/Network.hs +++ b/src/Propellor/Property/Network.hs @@ -5,21 +5,73 @@ import Propellor.Property.File type Interface = String -interfaces :: FilePath -interfaces = "/etc/network/interfaces" +ifUp :: Interface -> Property +ifUp iface = cmdProperty "ifup" [iface] -interfaceFile :: Interface -> FilePath -interfaceFile iface = "/etc/network/interfaces.d" iface +-- | Resets /etc/network/interfaces to a clean and empty state, +-- containing just the standard loopback interface, and with +-- interfacesD enabled. +-- +-- This can be used as a starting point to defining other interfaces. +-- +-- No interfaces are brought up or down by this property. +cleanInterfacesFile :: Property +cleanInterfacesFile = hasContent interfacesFile + [ "# Deployed by propellor, do not edit." + , "" + , "source-directory interfaces.d" + , "" + , "# The loopback network interface" + , "auto lo" + , "iface lo inet loopback" + ] + `describe` ("clean " ++ interfacesFile) --- | Enable source-directory interfaces.d -interfacesD :: Property -interfacesD = containsLine interfaces "source-directory interfaces.d" - `describe` "interfaces.d directory enabled" +-- | Writes a static interface file for the specified interface. +-- +-- The interface has to be up already. It could have been brought up by +-- DHCP, or by other means. The current ipv4 addresses +-- and routing configuration of the interface are written into the file. +-- +-- If the interface file already exists, this property does nothing, +-- no matter its content. +-- +-- (ipv6 addresses are not included because it's assumed they come up +-- automatically in most situations.) +static :: Interface -> Property +static iface = check (not <$> doesFileExist f) setup + `describe` desc + `requires` interfacesDEnabled + where + f = interfaceDFile iface + desc = "static " ++ iface + setup = property desc $ do + ls <- liftIO $ lines <$> readProcess "ip" + ["-o", "addr", "show", iface, "scope", "global"] + stanzas <- liftIO $ concat <$> mapM mkstanza ls + ensureProperty $ 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. + (_:iface':"inet":addr:_) | iface' == iface -> do + gw <- getgateway + return $ catMaybes + [ Just $ "iface " ++ iface ++ " inet static" + , Just $ "\taddress " ++ addr + , ("\tgateway " ++) <$> gw + ] + _ -> return [] + getgateway = do + rs <- lines <$> readProcess "ip" + ["route", "show", "scope", "global", "dev", iface] + return $ case words <$> headMaybe rs of + Just ("default":"via":gw:_) -> Just gw + _ -> Nothing -- | 6to4 ipv6 connection, should work anywhere ipv6to4 :: Property -ipv6to4 = hasContent (interfaceFile "sit0") - [ "# Automatically added by propeller" +ipv6to4 = hasContent (interfaceDFile "sit0") + [ "# Deployed by propellor, do not edit." , "iface sit0 inet6 static" , "\taddress 2002:5044:5531::1" , "\tnetmask 64" @@ -27,8 +79,17 @@ ipv6to4 = hasContent (interfaceFile "sit0") , "auto sit0" ] `describe` "ipv6to4" - `requires` interfacesD + `requires` interfacesDEnabled `onChange` ifUp "sit0" -ifUp :: Interface -> Property -ifUp iface = cmdProperty "ifup" [iface] +interfacesFile :: FilePath +interfacesFile = "/etc/network/interfaces" + +-- | A file in the interfaces.d directory. +interfaceDFile :: Interface -> FilePath +interfaceDFile iface = "/etc/network/interfaces.d" iface + +-- | Ensures that files in the the interfaces.d directory are used. +interfacesDEnabled :: Property +interfacesDEnabled = containsLine interfacesFile "source-directory interfaces.d" + `describe` "interfaces.d directory enabled" -- cgit v1.2.3 From 38eec6fc37054df1838be905670e1ed1ff308a65 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 23 Jan 2015 01:29:47 -0400 Subject: OS.preserveNetwork finally written --- debian/changelog | 1 + src/Propellor/Property/OS.hs | 15 +++++++++++++-- 2 files changed, 14 insertions(+), 2 deletions(-) (limited to 'debian') diff --git a/debian/changelog b/debian/changelog index 18a8a366..3d3e9e07 100644 --- a/debian/changelog +++ b/debian/changelog @@ -8,6 +8,7 @@ propellor (1.4.0) UNRELEASED; urgency=medium * Added systemd configuration properties. * Added journald configuration properties. * Added more network interface configuration properties. + * Implemented OS.preserveNetwork. -- Joey Hess Thu, 15 Jan 2015 20:14:29 -0400 diff --git a/src/Propellor/Property/OS.hs b/src/Propellor/Property/OS.hs index b60151e8..c1b085a6 100644 --- a/src/Propellor/Property/OS.hs +++ b/src/Propellor/Property/OS.hs @@ -10,6 +10,7 @@ module Propellor.Property.OS ( import Propellor import qualified Propellor.Property.Debootstrap as Debootstrap import qualified Propellor.Property.Ssh as Ssh +import qualified Propellor.Property.Network as Network import qualified Propellor.Property.User as User import qualified Propellor.Property.File as File import qualified Propellor.Property.Reboot as Reboot @@ -51,7 +52,7 @@ import Control.Exception (throw) -- > `onChange` propertyList "fixing up after clean install" -- > [ preserveNetwork -- > , preserveResolvConf --- > , preserverRootSshAuthorized +-- > , preserveRootSshAuthorized -- > , Apt.update -- > -- , Grub.boots "/dev/sda" -- > -- `requires` Grub.installed Grub.PC @@ -192,7 +193,17 @@ confirmed desc (Confirmed c) = property desc $ do -- interface that currently has a default route configured, using -- the same (static) IP address. preserveNetwork :: Property -preserveNetwork = undefined -- TODO +preserveNetwork = go `requires` Network.cleanInterfacesFile + where + go = property "preserve network configuration" $ do + ls <- liftIO $ lines <$> readProcess "ip" + ["route", "list", "scope", "global"] + case words <$> headMaybe ls of + Just ("default":"via":_:"dev":iface:_) -> + ensureProperty $ Network.static iface + _ -> do + warningMessage "did not find any default ipv4 route" + return FailedChange -- | is copied from the old OS preserveResolvConf :: Property -- cgit v1.2.3 From 0ee04ecc43e047b00437fb660e71f7dd67dd3afc Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 24 Jan 2015 22:38:10 -0400 Subject: GADT properties seem to work (untested) * Property has been converted to a GADT, and will be Property NoInfo or Property HasInfo. This was done to make sure that ensureProperty is only used on properties that do not have Info. Transition guide: - Change all "Property" to "Property NoInfo" or "Property WithInfo" (The compiler can tell you if you got it wrong!) - To construct a RevertableProperty, it is useful to use the new () operator - Constructing a list of properties can be problimatic, since Property NoInto and Property WithInfo are different types and cannot appear in the same list. To deal with this, "props" has been added, and can built up a list of properties of different types, using the same (&) and (!) operators that are used to build up a host's properties. --- config-joey.hs | 13 +- debian/changelog | 20 +- .../info_propigation_out_of_nested_properties.mdwn | 2 + propellor.cabal | 1 + src/Propellor.hs | 2 + src/Propellor/Engine.hs | 2 +- src/Propellor/Info.hs | 2 +- src/Propellor/PrivData.hs | 23 +- src/Propellor/PropAccum.hs | 33 +- src/Propellor/Property.hs | 100 ++--- src/Propellor/Property/Apache.hs | 14 +- src/Propellor/Property/Apt.hs | 52 +-- src/Propellor/Property/Chroot.hs | 18 +- src/Propellor/Property/Cmd.hs | 8 +- src/Propellor/Property/Cron.hs | 6 +- src/Propellor/Property/Debootstrap.hs | 15 +- src/Propellor/Property/Dns.hs | 29 +- src/Propellor/Property/DnsSec.hs | 14 +- src/Propellor/Property/Docker.hs | 64 +-- src/Propellor/Property/File.hs | 30 +- src/Propellor/Property/Firewall.hs | 4 +- src/Propellor/Property/Git.hs | 8 +- src/Propellor/Property/Gpg.hs | 4 +- src/Propellor/Property/Group.hs | 2 +- src/Propellor/Property/Grub.hs | 6 +- .../Property/HostingProvider/CloudAtCost.hs | 2 +- .../Property/HostingProvider/DigitalOcean.hs | 2 +- src/Propellor/Property/HostingProvider/Linode.hs | 2 +- src/Propellor/Property/Hostname.hs | 6 +- src/Propellor/Property/Journald.hs | 16 +- src/Propellor/Property/List.hs | 63 +++ src/Propellor/Property/Network.hs | 10 +- src/Propellor/Property/Nginx.hs | 10 +- src/Propellor/Property/OS.hs | 16 +- src/Propellor/Property/Obnam.hs | 14 +- src/Propellor/Property/OpenId.hs | 4 +- src/Propellor/Property/Postfix.hs | 22 +- src/Propellor/Property/Prosody.hs | 10 +- src/Propellor/Property/Reboot.hs | 4 +- src/Propellor/Property/Scheduled.hs | 8 +- src/Propellor/Property/Service.hs | 8 +- .../Property/SiteSpecific/GitAnnexBuilder.hs | 66 +-- src/Propellor/Property/SiteSpecific/GitHome.hs | 2 +- src/Propellor/Property/SiteSpecific/JoeySites.hs | 450 +++++++++++---------- src/Propellor/Property/Ssh.hs | 37 +- src/Propellor/Property/Sudo.hs | 2 +- src/Propellor/Property/Systemd.hs | 43 +- src/Propellor/Property/Systemd/Core.hs | 2 +- src/Propellor/Property/Tor.hs | 12 +- src/Propellor/Property/User.hs | 18 +- src/Propellor/Types.hs | 57 +-- 51 files changed, 728 insertions(+), 630 deletions(-) create mode 100644 src/Propellor/Property/List.hs (limited to 'debian') diff --git a/config-joey.hs b/config-joey.hs index e1587076..da364a3d 100644 --- a/config-joey.hs +++ b/config-joey.hs @@ -438,13 +438,12 @@ dockerImage (System (Debian Testing) arch) = "joeyh/debian-unstable-" ++ arch dockerImage (System (Debian (Stable _)) arch) = "joeyh/debian-stable-" ++ arch dockerImage _ = "debian-stable-official" -- does not currently exist! -myDnsSecondary :: Property -myDnsSecondary = propertyList "dns secondary for all my domains" $ map toProp - [ Dns.secondary hosts "kitenet.net" - , Dns.secondary hosts "joeyh.name" - , Dns.secondary hosts "ikiwiki.info" - , Dns.secondary hosts "olduse.net" - ] +myDnsSecondary :: Property HasInfo +myDnsSecondary = propertyList "dns secondary for all my domains" $ props + & Dns.secondary hosts "kitenet.net" + & Dns.secondary hosts "joeyh.name" + & Dns.secondary hosts "ikiwiki.info" + & Dns.secondary hosts "olduse.net" branchableSecondary :: RevertableProperty branchableSecondary = Dns.secondaryFor ["branchable.com"] hosts "branchable.com" diff --git a/debian/changelog b/debian/changelog index 3d3e9e07..abf6bd16 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,9 +1,23 @@ -propellor (1.4.0) UNRELEASED; urgency=medium - +propellor (2.0.0) UNRELEASED; urgency=medium + + * Property has been converted to a GADT, and will be Property NoInfo + or Property HasInfo. + This was done to make sure that ensureProperty is only used on + properties that do not have Info. + Transition guide: + - Change all "Property" to "Property NoInfo" or "Property WithInfo" + (The compiler can tell you if you got it wrong!) + - To construct a RevertableProperty, it is useful to use the new + () operator + - Constructing a list of properties can be problimatic, since + Property NoInto and Property WithInfo are different types and cannot + appear in the same list. To deal with this, "props" has been added, + and can built up a list of properties of different types, + using the same (&) and (!) operators that are used to build + up a host's properties. * Add descriptions of how to set missing fields to --list-fields output. * Properties now form a tree, instead of the flat list used before. This includes the properties used inside a container. - (API change) * Fix info propigation from fallback combinator's second Property. * Added systemd configuration properties. * Added journald configuration properties. diff --git a/doc/todo/info_propigation_out_of_nested_properties.mdwn b/doc/todo/info_propigation_out_of_nested_properties.mdwn index 1a586be6..e6427069 100644 --- a/doc/todo/info_propigation_out_of_nested_properties.mdwn +++ b/doc/todo/info_propigation_out_of_nested_properties.mdwn @@ -1,3 +1,5 @@ +> Now [[fixed|done]]!! --[[Joey]] + Currently, Info about a Host's Properties is manually gathered and propigated. propertyList combines the Info of the Properties in the list. Docker.docked extracts relevant Info from the Properties of the container diff --git a/propellor.cabal b/propellor.cabal index e1830c47..523cf19f 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -95,6 +95,7 @@ Library Propellor.Property.Postfix Propellor.Property.Prosody Propellor.Property.Reboot + Propellor.Property.List Propellor.Property.Scheduled Propellor.Property.Service Propellor.Property.Ssh diff --git a/src/Propellor.hs b/src/Propellor.hs index 3eddd8d7..51079ed0 100644 --- a/src/Propellor.hs +++ b/src/Propellor.hs @@ -32,6 +32,7 @@ module Propellor ( module Propellor.Types , module Propellor.Property + , module Propellor.Property.List , module Propellor.Property.Cmd , module Propellor.PropAccum , module Propellor.Info @@ -48,6 +49,7 @@ module Propellor ( import Propellor.Types import Propellor.Property import Propellor.Engine +import Propellor.Property.List import Propellor.Property.Cmd import Propellor.PrivData import Propellor.Types.PrivData diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs index 552b910c..99f1660d 100644 --- a/src/Propellor/Engine.hs +++ b/src/Propellor/Engine.hs @@ -36,7 +36,7 @@ import Utility.Monad mainProperties :: Host -> IO () mainProperties host = do ret <- runPropellor host $ - ensureProperties [mkProperty "overall" (ensureProperties ps) mempty mempty] + ensureProperties [ignoreInfo $ infoProperty "overall" (ensureProperties ps) mempty mempty] h <- mkMessageHandle whenConsole h $ setTitle "propellor: done" diff --git a/src/Propellor/Info.hs b/src/Propellor/Info.hs index 1d8e7ab2..f1f23b96 100644 --- a/src/Propellor/Info.hs +++ b/src/Propellor/Info.hs @@ -13,7 +13,7 @@ import Data.Monoid import Control.Applicative pureInfoProperty :: Desc -> Info -> Property HasInfo -pureInfoProperty desc i = mkProperty ("has " ++ desc) (return NoChange) i mempty +pureInfoProperty desc i = infoProperty ("has " ++ desc) (return NoChange) i mempty askInfo :: (Info -> Val a) -> Propellor (Maybe a) askInfo f = asks (fromVal . f . hostInfo) diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs index 1e7a9d28..71aa820d 100644 --- a/src/Propellor/PrivData.hs +++ b/src/Propellor/PrivData.hs @@ -1,4 +1,5 @@ {-# LANGUAGE PackageImports #-} +{-# LANGUAGE FlexibleContexts #-} module Propellor.PrivData ( withPrivData, @@ -60,29 +61,29 @@ import Utility.Table -- being used, which is necessary to ensure that the privdata is sent to -- the remote host by propellor. withPrivData - :: (IsContext c, IsPrivDataSource s) + :: (IsContext c, IsPrivDataSource s, IsProp (Property i)) => s -> c - -> (((PrivData -> Propellor Result) -> Propellor Result) -> Property) - -> Property + -> (((PrivData -> Propellor Result) -> Propellor Result) -> Property i) + -> Property HasInfo withPrivData s = withPrivData' snd [s] -- Like withPrivData, but here any one of a list of PrivDataFields can be used. withSomePrivData - :: (IsContext c, IsPrivDataSource s) + :: (IsContext c, IsPrivDataSource s, IsProp (Property i)) => [s] -> c - -> ((((PrivDataField, PrivData) -> Propellor Result) -> Propellor Result) -> Property) - -> Property + -> ((((PrivDataField, PrivData) -> Propellor Result) -> Propellor Result) -> Property i) + -> Property HasInfo withSomePrivData = withPrivData' id withPrivData' - :: (IsContext c, IsPrivDataSource s) + :: (IsContext c, IsPrivDataSource s, IsProp (Property i)) => ((PrivDataField, PrivData) -> v) -> [s] -> c - -> (((v -> Propellor Result) -> Propellor Result) -> Property) - -> Property + -> (((v -> Propellor Result) -> Propellor Result) -> Property i) + -> Property HasInfo withPrivData' feed srclist c mkprop = addinfo $ mkprop $ \a -> maybe missing (a . feed) =<< getM get fieldlist where @@ -97,7 +98,7 @@ withPrivData' feed srclist c mkprop = addinfo $ mkprop $ \a -> liftIO $ showSet $ map (\s -> (privDataField s, Context cname, describePrivDataSource s)) srclist return FailedChange - addinfo p = mkProperty + addinfo p = infoProperty (propertyDesc p) (propertySatisfy p) (propertyInfo p <> mempty { _privData = privset }) @@ -113,7 +114,7 @@ showSet l = forM_ l $ \(f, Context c, md) -> do maybe noop (\d -> putStrLn $ " " ++ d) md putStrLn "" -addPrivData :: (PrivDataField, Maybe PrivDataSourceDesc, HostContext) -> Property +addPrivData :: (PrivDataField, Maybe PrivDataSourceDesc, HostContext) -> Property HasInfo addPrivData v = pureInfoProperty (show v) $ mempty { _privData = S.singleton v } diff --git a/src/Propellor/PropAccum.hs b/src/Propellor/PropAccum.hs index ddbc1e66..139f1471 100644 --- a/src/Propellor/PropAccum.hs +++ b/src/Propellor/PropAccum.hs @@ -16,6 +16,15 @@ import Propellor.Property host :: HostName -> Host host hn = Host hn [] mempty +-- | Starts accumulating a list of properties. +-- +-- > propertyList "foo" $ props +-- > & someproperty +-- > ! oldproperty +-- > & otherproperty +props :: PropList +props = PropList [] + -- | Something that can accumulate properties. class PropAccum h where -- | Adds a property. @@ -23,13 +32,10 @@ class PropAccum h where -- Can add Properties and RevertableProperties (&) :: IsProp p => h -> p -> h - -- | Like (&), but adds the property as the - -- first property of the host. Normally, property - -- order should not matter, but this is useful - -- when it does. + -- | Like (&), but adds the property at the front of the list. (&^) :: IsProp p => h -> p -> h - getProperties :: h -> [Property] + getProperties :: h -> [Property HasInfo] instance PropAccum Host where (Host hn ps is) & p = Host hn (ps ++ [toProp p]) @@ -38,6 +44,13 @@ instance PropAccum Host where (getInfoRecursive p <> is) getProperties = hostProperties +data PropList = PropList [Property HasInfo] + +instance PropAccum PropList where + PropList l & p = PropList (l ++ [toProp p]) + PropList l &^ p = PropList ([toProp p] ++ l) + getProperties (PropList l) = l + -- | Adds a property in reverted form. (!) :: PropAccum h => h -> RevertableProperty -> h h ! p = h & revert p @@ -57,8 +70,12 @@ infixl 1 ! -- -- PrivData Info is propigated, so that properties used inside a -- PropAccum will have the necessary PrivData available. -propigateContainer :: PropAccum container => container -> Property -> Property -propigateContainer c prop = mkProperty +propigateContainer + :: (PropAccum container) + => container + -> Property HasInfo + -> Property HasInfo +propigateContainer c prop = infoProperty (propertyDesc prop) (propertySatisfy prop) (propertyInfo prop) @@ -72,4 +89,4 @@ propigateContainer c prop = mkProperty , _privData = _privData i } cs = map go (propertyChildren p) - in mkProperty (propertyDesc p) (propertySatisfy p) i' cs + in infoProperty (propertyDesc p) (propertySatisfy p) i' cs diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs index faf66074..40eb5d52 100644 --- a/src/Propellor/Property.hs +++ b/src/Propellor/Property.hs @@ -1,4 +1,5 @@ {-# LANGUAGE PackageImports #-} +{-# LANGUAGE FlexibleContexts #-} module Propellor.Property where @@ -11,47 +12,20 @@ import "mtl" Control.Monad.RWS.Strict import Propellor.Types import Propellor.Info -import Propellor.Engine import Utility.Monad -- Constructs a Property. -property :: Desc -> Propellor Result -> Property -property d s = mkProperty d s mempty mempty - --- | 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 propigate overall success/failure. -propertyList :: Desc -> [Property] -> Property -propertyList desc ps = mkProperty desc (ensureProperties ps) mempty ps - --- | Combines a list of properties, resulting in one property that --- ensures each in turn. Stops if a property fails. -combineProperties :: Desc -> [Property] -> Property -combineProperties desc ps = mkProperty desc (go ps NoChange) mempty ps - where - go [] rs = return rs - go (l:ls) rs = do - r <- ensureProperty l - case r of - FailedChange -> return FailedChange - _ -> go ls (r <> rs) - --- | Combines together two properties, resulting in one property --- that ensures the first, and if the first succeeds, ensures the second. --- The property uses the description of the first property. -before :: Property -> Property -> Property -p1 `before` p2 = p2 `requires` p1 - `describe` (propertyDesc p1) +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. -flagFile :: Property -> FilePath -> Property +flagFile :: Property i -> FilePath -> Property i flagFile p = flagFile' p . return -flagFile' :: Property -> IO FilePath -> Property -flagFile' p getflagfile = adjustProperty p $ \satisfy -> do +flagFile' :: Property i -> IO FilePath -> Property i +flagFile' p getflagfile = adjustPropertySatisfy p $ \satisfy -> do flagfile <- liftIO getflagfile go satisfy flagfile =<< liftIO (doesFileExist flagfile) where @@ -66,40 +40,38 @@ flagFile' p getflagfile = adjustProperty p $ \satisfy -> do --- | Whenever a change has to be made for a Property, causes a hook -- Property to also be run, but not otherwise. -onChange :: Property -> Property -> Property -p `onChange` hook = mkProperty (propertyDesc p) satisfy (propertyInfo p) cs - where - satisfy = do - r <- ensureProperty p - case r of - MadeChange -> do - r' <- ensureProperty hook - return $ r <> r' - _ -> return r - cs = propertyChildren p ++ [hook] - -(==>) :: Desc -> Property -> Property +onChange + :: (Combines (Property x) (Property y)) + => Property x + => Property y + => CombinedType (Property x) (Property y) +onChange = combineWith $ \p hook -> do + r <- p + case r of + MadeChange -> do + r' <- hook + return $ r <> r' + _ -> return r + +(==>) :: IsProp (Property i) => Desc -> Property i -> Property i (==>) = flip describe infixl 1 ==> -- | Makes a Property only need to do anything when a test succeeds. -check :: IO Bool -> Property -> Property -check c p = adjustProperty p $ \satisfy -> ifM (liftIO c) +check :: IO Bool -> Property i -> Property i +check c p = adjustPropertySatisfy p $ \satisfy -> ifM (liftIO c) ( satisfy , return NoChange ) -- | Tries the first property, but if it fails to work, instead uses -- the second. -fallback :: Property -> Property -> Property -fallback p1 p2 = mkProperty (propertyDesc p1) satisfy (propertyInfo p1) cs - where - cs = p2 : propertyChildren p1 - satisfy = do - r <- propertySatisfy p1 - if r == FailedChange - then propertySatisfy p2 - else return r +fallback :: (Combines (Property p1) (Property p2)) => Property p1 -> Property p2 -> Property (CInfo p1 p2) +fallback = combineWith $ \a1 a2 -> do + r <- a1 + if r == FailedChange + then a2 + else return r -- | Marks a Property as trivial. It can only return FailedChange or -- NoChange. @@ -107,35 +79,27 @@ fallback p1 p2 = mkProperty (propertyDesc p1) satisfy (propertyInfo p1) cs -- Useful when it's just as expensive to check if a change needs -- to be made as it is to just idempotently assure the property is -- satisfied. For example, chmodding a file. -trivial :: Property -> Property -trivial p = adjustProperty p $ \satisfy -> do +trivial :: Property i -> Property i +trivial p = adjustPropertySatisfy p $ \satisfy -> do r <- satisfy if r == MadeChange then return NoChange else return r -doNothing :: Property +doNothing :: Property NoInfo doNothing = property "noop property" noChange -- | Makes a property that is satisfied differently depending on the host's -- operating system. -- -- Note that the operating system may not be declared for some hosts. -withOS :: Desc -> (Maybe System -> Propellor Result) -> Property +withOS :: Desc -> (Maybe System -> Propellor Result) -> Property NoInfo withOS desc a = property desc $ a =<< getOS -- | Undoes the effect of a property. revert :: RevertableProperty -> RevertableProperty revert (RevertableProperty p1 p2) = RevertableProperty p2 p1 --- | Changes the action that is performed to satisfy a property. -adjustProperty :: Property -> (Propellor Result -> Propellor Result) -> Property -adjustProperty p f = mkProperty - (propertyDesc p) - (f (propertySatisfy p)) - (propertyInfo p) - (propertyChildren p) - makeChange :: IO () -> Propellor Result makeChange a = liftIO a >> return MadeChange diff --git a/src/Propellor/Property/Apache.hs b/src/Propellor/Property/Apache.hs index 1ce187d8..e598de1f 100644 --- a/src/Propellor/Property/Apache.hs +++ b/src/Propellor/Property/Apache.hs @@ -9,7 +9,7 @@ import Utility.SafeCommand type ConfigFile = [String] siteEnabled :: HostName -> ConfigFile -> RevertableProperty -siteEnabled hn cf = RevertableProperty enable disable +siteEnabled hn cf = enable disable where enable = combineProperties ("apache site enabled " ++ hn) [ siteAvailable hn cf @@ -28,14 +28,14 @@ siteEnabled hn cf = RevertableProperty enable disable `onChange` reloaded isenabled = boolSystem "a2query" [Param "-q", Param "-s", Param hn] -siteAvailable :: HostName -> ConfigFile -> Property +siteAvailable :: HostName -> ConfigFile -> Property NoInfo siteAvailable hn cf = combineProperties ("apache site available " ++ hn) $ map (`File.hasContent` (comment:cf)) (siteCfg hn) where comment = "# deployed with propellor, do not modify" modEnabled :: String -> RevertableProperty -modEnabled modname = RevertableProperty enable disable +modEnabled modname = enable disable where enable = check (not <$> isenabled) $ cmdProperty "a2enmod" ["--quiet", modname] @@ -59,18 +59,18 @@ siteCfg hn = , "/etc/apache2/sites-available/" ++ hn ++ ".conf" ] -installed :: Property +installed :: Property NoInfo installed = Apt.installed ["apache2"] -restarted :: Property +restarted :: Property NoInfo restarted = Service.restarted "apache2" -reloaded :: Property +reloaded :: Property NoInfo reloaded = Service.reloaded "apache2" -- | Configure apache to use SNI to differentiate between -- https hosts. -multiSSL :: Property +multiSSL :: Property NoInfo multiSSL = "/etc/apache2/conf.d/ssl" `File.hasContent` [ "NameVirtualHost *:443" , "SSLStrictSNIVHostCheck off" diff --git a/src/Propellor/Property/Apt.hs b/src/Propellor/Property/Apt.hs index 2dd9ca16..d567d0ec 100644 --- a/src/Propellor/Property/Apt.hs +++ b/src/Propellor/Property/Apt.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleContexts #-} + module Propellor.Property.Apt where import Data.Maybe @@ -77,36 +79,36 @@ securityUpdates suite -- -- Since the CDN is sometimes unreliable, also adds backup lines using -- kernel.org. -stdSourcesList :: Property +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 +stdSourcesListFor :: DebianSuite -> Property NoInfo 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 +stdSourcesList' :: DebianSuite -> [SourcesGenerator] -> Property NoInfo stdSourcesList' suite more = setSourcesList (concatMap (\gen -> gen suite) generators) `describe` ("standard sources.list for " ++ show suite) where generators = [debCdn, kernelOrg, securityUpdates] ++ more -setSourcesList :: [Line] -> Property +setSourcesList :: [Line] -> Property NoInfo setSourcesList ls = sourcesList `File.hasContent` ls `onChange` update -setSourcesListD :: [Line] -> FilePath -> Property +setSourcesListD :: [Line] -> FilePath -> Property NoInfo setSourcesListD ls basename = f `File.hasContent` ls `onChange` update where f = "/etc/apt/sources.list.d/" ++ basename ++ ".list" -runApt :: [String] -> Property +runApt :: [String] -> Property NoInfo runApt ps = cmdProperty' "apt-get" ps noninteractiveEnv noninteractiveEnv :: [(String, String)] @@ -115,26 +117,26 @@ noninteractiveEnv = , ("APT_LISTCHANGES_FRONTEND", "none") ] -update :: Property +update :: Property NoInfo update = runApt ["update"] `describe` "apt update" -upgrade :: Property +upgrade :: Property NoInfo upgrade = runApt ["-y", "dist-upgrade"] `describe` "apt dist-upgrade" type Package = String -installed :: [Package] -> Property +installed :: [Package] -> Property NoInfo installed = installed' ["-y"] -installed' :: [String] -> [Package] -> Property +installed' :: [String] -> [Package] -> Property NoInfo installed' params ps = robustly $ check (isInstallable ps) go `describe` (unwords $ "apt installed":ps) where go = runApt $ params ++ ["install"] ++ ps -installedBackport :: [Package] -> Property +installedBackport :: [Package] -> Property NoInfo installedBackport ps = trivial $ withOS desc $ \o -> case o of Nothing -> error "cannot install backports; os not declared" (Just (System (Debian suite) _)) -> case backportSuite suite of @@ -147,16 +149,16 @@ installedBackport ps = trivial $ withOS desc $ \o -> case o of notsupported o = error $ "backports not supported on " ++ show o -- | Minimal install of package, without recommends. -installedMin :: [Package] -> Property +installedMin :: [Package] -> Property NoInfo installedMin = installed' ["--no-install-recommends", "-y"] -removed :: [Package] -> Property +removed :: [Package] -> Property NoInfo removed ps = check (or <$> isInstalled' ps) go `describe` (unwords $ "apt removed":ps) where go = runApt $ ["-y", "remove"] ++ ps -buildDep :: [Package] -> Property +buildDep :: [Package] -> Property NoInfo buildDep ps = robustly go `describe` (unwords $ "apt build-dep":ps) where @@ -165,7 +167,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 +buildDepIn :: FilePath -> Property NoInfo buildDepIn dir = go `requires` installedMin ["devscripts", "equivs"] where go = cmdProperty' "sh" ["-c", "cd '" ++ dir ++ "' && mk-build-deps debian/control --install --tool 'apt-get -y --no-install-recommends' --remove"] @@ -173,11 +175,13 @@ buildDepIn dir = go `requires` installedMin ["devscripts", "equivs"] -- | Package installation may fail becuse the archive has changed. -- Run an update in that case and retry. -robustly :: Property -> Property -robustly p = adjustProperty p $ \satisfy -> do +robustly :: (Combines (Property i) (Property NoInfo)) => Property i -> Property i +robustly p = adjustPropertySatisfy p $ \satisfy -> do r <- satisfy if r == FailedChange - then ensureProperty $ p `requires` update + -- Safe to use ignoreInfo because we're re-running + -- the same property. + then ensureProperty $ ignoreInfo $ p `requires` update else return r isInstallable :: [Package] -> IO Bool @@ -203,13 +207,13 @@ isInstalled' ps = catMaybes . map parse . lines <$> policy environ <- addEntry "LANG" "C" <$> getEnvironment readProcessEnv "apt-cache" ("policy":ps) (Just environ) -autoRemove :: Property +autoRemove :: Property NoInfo autoRemove = runApt ["-y", "autoremove"] `describe` "apt autoremove" -- | Enables unattended upgrades. Revert to disable. unattendedUpgrades :: RevertableProperty -unattendedUpgrades = RevertableProperty enable disable +unattendedUpgrades = enable disable where enable = setup True `before` Service.running "cron" @@ -237,7 +241,7 @@ unattendedUpgrades = RevertableProperty enable disable -- | Preseeds debconf values and reconfigures the package so it takes -- effect. -reConfigure :: Package -> [(String, String, String)] -> Property +reConfigure :: Package -> [(String, String, String)] -> Property NoInfo reConfigure package vals = reconfigure `requires` setselections `describe` ("reconfigure " ++ package) where @@ -253,7 +257,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 +serviceInstalledRunning :: Package -> Property NoInfo serviceInstalledRunning svc = Service.running svc `requires` installed [svc] data AptKey = AptKey @@ -262,7 +266,7 @@ data AptKey = AptKey } trustsKey :: AptKey -> RevertableProperty -trustsKey k = RevertableProperty trust untrust +trustsKey k = trust untrust where desc = "apt trusts key " ++ keyname k f = "/etc/apt/trusted.gpg.d" keyname k ++ ".gpg" @@ -276,6 +280,6 @@ trustsKey k = RevertableProperty trust untrust -- | Cleans apt's cache of downloaded packages to avoid using up disk -- space. -cacheCleaned :: Property +cacheCleaned :: Property NoInfo cacheCleaned = trivial $ cmdProperty "apt-get" ["clean"] `describe` "apt cache cleaned" diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs index 0ef6e7dd..e56cb6ed 100644 --- a/src/Propellor/Property/Chroot.hs +++ b/src/Propellor/Property/Chroot.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleContexts #-} + module Propellor.Property.Chroot ( Chroot(..), BuilderConf(..), @@ -59,12 +61,13 @@ debootstrapped system conf location = case system of provisioned :: Chroot -> RevertableProperty provisioned c = provisioned' (propigateChrootInfo c) c False -provisioned' :: (Property -> Property) -> Chroot -> Bool -> RevertableProperty -provisioned' propigator c@(Chroot loc system builderconf _) systemdonly = RevertableProperty +provisioned' :: (Property HasInfo -> Property HasInfo) -> Chroot -> Bool -> RevertableProperty +provisioned' propigator c@(Chroot loc system builderconf _) systemdonly = (propigator $ go "exists" setup) + (go "removed" teardown) where - go desc a = property (chrootDesc c desc) $ ensureProperties [a] + go desc a = propertyList (chrootDesc c desc) [a] setup = propellChroot c (inChrootProcess c) systemdonly `requires` toProp built @@ -77,10 +80,10 @@ provisioned' propigator c@(Chroot loc system builderconf _) systemdonly = Revert teardown = toProp (revert built) -propigateChrootInfo :: Chroot -> Property -> Property +propigateChrootInfo :: (IsProp (Property i)) => Chroot -> Property i -> Property HasInfo propigateChrootInfo c p = propigateContainer c p' where - p' = mkProperty + p' = infoProperty (propertyDesc p) (propertySatisfy p) (propertyInfo p <> chrootInfo c) @@ -91,7 +94,7 @@ chrootInfo (Chroot loc _ _ h) = mempty { _chrootinfo = mempty { _chroots = M.singleton loc h } } -- | Propellor is run inside the chroot to provision it. -propellChroot :: Chroot -> ([String] -> CreateProcess) -> Bool -> Property +propellChroot :: Chroot -> ([String] -> CreateProcess) -> Bool -> Property NoInfo propellChroot c@(Chroot loc _ _ _) mkproc systemdonly = property (chrootDesc c "provisioned") $ do let d = localdir shimdir c let me = localdir "propellor" @@ -148,7 +151,8 @@ chain hostlist (ChrootChain hn loc systemdonly onconsole) = r <- runPropellor h $ ensureProperties $ if systemdonly then [Systemd.installed] - else hostProperties h + else map ignoreInfo $ + hostProperties h putStrLn $ "\n" ++ show r chain _ _ = errorMessage "bad chain command" diff --git a/src/Propellor/Property/Cmd.hs b/src/Propellor/Property/Cmd.hs index d24b1a8a..7fd189df 100644 --- a/src/Propellor/Property/Cmd.hs +++ b/src/Propellor/Property/Cmd.hs @@ -19,12 +19,12 @@ import Utility.Env -- | A property that can be satisfied by running a command. -- -- The command must exit 0 on success. -cmdProperty :: String -> [String] -> Property +cmdProperty :: String -> [String] -> Property NoInfo cmdProperty cmd params = cmdProperty' cmd params [] -- | A property that can be satisfied by running a command, -- with added environment. -cmdProperty' :: String -> [String] -> [(String, String)] -> Property +cmdProperty' :: String -> [String] -> [(String, String)] -> Property NoInfo cmdProperty' cmd params env = property desc $ liftIO $ do env' <- addEntries env <$> getEnvironment toResult <$> boolSystemEnv cmd (map Param params) (Just env') @@ -32,14 +32,14 @@ cmdProperty' cmd params env = property desc $ liftIO $ do desc = unwords $ cmd : params -- | A property that can be satisfied by running a series of shell commands. -scriptProperty :: [String] -> Property +scriptProperty :: [String] -> Property NoInfo scriptProperty script = cmdProperty "sh" ["-c", shellcmd] where shellcmd = intercalate " ; " ("set -e" : script) -- | A property that can satisfied by running a series of shell commands, -- as user (cd'd to their home directory). -userScriptProperty :: UserName -> [String] -> Property +userScriptProperty :: UserName -> [String] -> Property NoInfo userScriptProperty user script = cmdProperty "su" ["-c", shellcmd, user] where shellcmd = intercalate " ; " ("set -e" : "cd" : script) diff --git a/src/Propellor/Property/Cron.hs b/src/Propellor/Property/Cron.hs index 26cf312f..15cdd983 100644 --- a/src/Propellor/Property/Cron.hs +++ b/src/Propellor/Property/Cron.hs @@ -19,7 +19,7 @@ type CronTimes = String -- job file. -- -- The cron job's output will only be emailed if it exits nonzero. -job :: Desc -> CronTimes -> UserName -> FilePath -> String -> Property +job :: Desc -> CronTimes -> UserName -> FilePath -> String -> Property NoInfo job desc times user cddir command = combineProperties ("cronned " ++ desc) [ cronjobfile `File.hasContent` [ "# Generated by propellor" @@ -52,10 +52,10 @@ job desc times user cddir command = combineProperties ("cronned " ++ desc) | otherwise = '_' -- | Installs a cron job, and runs it niced and ioniced. -niceJob :: Desc -> CronTimes -> UserName -> FilePath -> String -> Property +niceJob :: Desc -> CronTimes -> UserName -> FilePath -> String -> Property NoInfo 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 :: CronTimes -> Property +runPropellor :: CronTimes -> Property NoInfo runPropellor times = niceJob "propellor" times "root" localdir "./propellor" diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs index 300edb42..3feb280c 100644 --- a/src/Propellor/Property/Debootstrap.hs +++ b/src/Propellor/Property/Debootstrap.hs @@ -58,9 +58,8 @@ toParams (c1 :+ c2) = toParams c1 <> toParams c2 built :: FilePath -> System -> DebootstrapConfig -> RevertableProperty built = built' (toProp installed) -built' :: Property -> FilePath -> System -> DebootstrapConfig -> RevertableProperty -built' installprop target system@(System _ arch) config = - RevertableProperty setup teardown +built' :: Property HasInfo -> FilePath -> System -> DebootstrapConfig -> RevertableProperty +built' installprop target system@(System _ arch) config = setup teardown where setup = check (unpopulated target <||> ispartial) setupprop `requires` installprop @@ -122,7 +121,7 @@ extractSuite (System (Ubuntu r) _) = Just r -- Note that installation from source is done by downloading the tarball -- from a Debian mirror, with no cryptographic verification. installed :: RevertableProperty -installed = RevertableProperty install remove +installed = install remove where install = withOS "debootstrap installed" $ \o -> ifM (liftIO $ isJust <$> programPath) @@ -142,18 +141,18 @@ installed = RevertableProperty install remove aptinstall = Apt.installed ["debootstrap"] aptremove = Apt.removed ["debootstrap"] -sourceInstall :: Property +sourceInstall :: Property NoInfo sourceInstall = property "debootstrap installed from source" (liftIO sourceInstall') `requires` perlInstalled `requires` arInstalled -perlInstalled :: Property +perlInstalled :: Property NoInfo perlInstalled = check (not <$> inPath "perl") $ property "perl installed" $ liftIO $ toResult . isJust <$> firstM id [ yumInstall "perl" ] -arInstalled :: Property +arInstalled :: Property NoInfo arInstalled = check (not <$> inPath "ar") $ property "ar installed" $ liftIO $ toResult . isJust <$> firstM id [ yumInstall "binutils" @@ -197,7 +196,7 @@ sourceInstall' = withTmpDir "debootstrap" $ \tmpd -> do return MadeChange _ -> errorMessage "debootstrap tar file did not contain exactly one dirctory" -sourceRemove :: Property +sourceRemove :: Property NoInfo sourceRemove = property "debootstrap not installed from source" $ liftIO $ ifM (doesDirectoryExist sourceInstallDir) ( do diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs index d6666618..a7dbf86a 100644 --- a/src/Propellor/Property/Dns.hs +++ b/src/Propellor/Property/Dns.hs @@ -58,7 +58,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 -primary hosts domain soa rs = RevertableProperty setup cleanup +primary hosts domain soa rs = setup cleanup where setup = setupPrimary zonefile id hosts domain soa rs `onChange` Service.reloaded "bind9" @@ -67,7 +67,7 @@ primary hosts domain soa rs = RevertableProperty setup cleanup zonefile = "/etc/bind/propellor/db." ++ domain -setupPrimary :: FilePath -> (FilePath -> FilePath) -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> Property +setupPrimary :: FilePath -> (FilePath -> FilePath) -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> Property HasInfo setupPrimary zonefile mknamedconffile hosts domain soa rs = withwarnings baseprop `requires` servingZones @@ -77,7 +77,7 @@ 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 = mkProperty ("dns primary for " ++ domain) satisfy + baseprop = infoProperty ("dns primary for " ++ domain) satisfy (addNamedConf conf) [] satisfy = do sshfps <- concat <$> mapM (genSSHFP domain) (M.elems hostmap) @@ -87,7 +87,7 @@ setupPrimary zonefile mknamedconffile hosts domain soa rs = ( makeChange $ writeZoneFile zone zonefile , noChange ) - withwarnings p = adjustProperty p $ \a -> do + withwarnings p = adjustPropertySatisfy p $ \a -> do mapM_ warningMessage $ zonewarnings ++ secondarywarnings a conf = NamedConf @@ -117,7 +117,7 @@ setupPrimary zonefile mknamedconffile hosts domain soa rs = in z /= oldzone || oldserial < sSerial (zSOA zone) -cleanupPrimary :: FilePath -> Domain -> Property +cleanupPrimary :: FilePath -> Domain -> Property NoInfo cleanupPrimary zonefile domain = check (doesFileExist zonefile) $ property ("removed dns primary for " ++ domain) (makeChange $ removeZoneFile zonefile) @@ -150,13 +150,14 @@ cleanupPrimary zonefile domain = check (doesFileExist zonefile) $ -- 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 -signedPrimary recurrance hosts domain soa rs = RevertableProperty setup cleanup +signedPrimary recurrance hosts domain soa rs = setup cleanup where - setup = combineProperties ("dns primary for " ++ domain ++ " (signed)") - [ setupPrimary zonefile signedZoneFile hosts domain soa rs' - , toProp (zoneSigned domain zonefile) - , forceZoneSigned domain zonefile `period` recurrance - ] + setup = combineProperties ("dns primary for " ++ domain ++ " (signed)") + (props + & setupPrimary zonefile signedZoneFile hosts domain soa rs' + & zoneSigned domain zonefile + & forceZoneSigned domain zonefile `period` recurrance + ) `onChange` Service.reloaded "bind9" cleanup = cleanupPrimary zonefile domain @@ -186,7 +187,7 @@ secondary hosts domain = secondaryFor (otherServers Master hosts domain) hosts d -- | This variant is useful if the primary server does not have its DNS -- configured via propellor. secondaryFor :: [HostName] -> [Host] -> Domain -> RevertableProperty -secondaryFor masters hosts domain = RevertableProperty setup cleanup +secondaryFor masters hosts domain = setup cleanup where setup = pureInfoProperty desc (addNamedConf conf) `requires` servingZones @@ -214,12 +215,12 @@ 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 +servingZones :: Property NoInfo servingZones = namedConfWritten `onChange` Service.reloaded "bind9" `requires` Apt.serviceInstalledRunning "bind9" -namedConfWritten :: Property +namedConfWritten :: Property NoInfo namedConfWritten = property "named.conf configured" $ do zs <- getNamedConf ensureProperty $ diff --git a/src/Propellor/Property/DnsSec.hs b/src/Propellor/Property/DnsSec.hs index b7557006..3acaee8d 100644 --- a/src/Propellor/Property/DnsSec.hs +++ b/src/Propellor/Property/DnsSec.hs @@ -8,7 +8,7 @@ import qualified Propellor.Property.File as File -- signedPrimary uses this, so this property does not normally need to be -- used directly. keysInstalled :: Domain -> RevertableProperty -keysInstalled domain = RevertableProperty setup cleanup +keysInstalled domain = setup cleanup where setup = propertyList "DNSSEC keys installed" $ map installkey keys @@ -38,16 +38,14 @@ keysInstalled domain = RevertableProperty setup cleanup -- signedPrimary uses this, so this property does not normally need to be -- used directly. zoneSigned :: Domain -> FilePath -> RevertableProperty -zoneSigned domain zonefile = RevertableProperty setup cleanup +zoneSigned domain zonefile = setup cleanup where setup = check needupdate (forceZoneSigned domain zonefile) `requires` toProp (keysInstalled domain) - cleanup = combineProperties ("removed signed zone for " ++ domain) - [ File.notPresent (signedZoneFile zonefile) - , File.notPresent dssetfile - , toProp (revert (keysInstalled domain)) - ] + cleanup = File.notPresent (signedZoneFile zonefile) + `before` File.notPresent dssetfile + `before` toProp (revert (keysInstalled domain)) dssetfile = dir "-" ++ domain ++ "." dir = takeDirectory zonefile @@ -65,7 +63,7 @@ zoneSigned domain zonefile = RevertableProperty setup cleanup t2 <- getModificationTime f return (t2 >= t1) -forceZoneSigned :: Domain -> FilePath -> Property +forceZoneSigned :: Domain -> FilePath -> Property NoInfo 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 9645bfe7..6ca5005c 100644 --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} -- | Docker support for propellor -- @@ -56,12 +56,12 @@ import Data.List hiding (init) import Data.List.Utils import qualified Data.Map as M -installed :: Property +installed :: Property NoInfo installed = Apt.installed ["docker.io"] -- | Configures docker with an authentication file, so that images can be -- pushed to index.docker.io. Optional. -configured :: Property +configured :: Property HasInfo configured = prop `requires` installed where prop = withPrivData src anyContext $ \getcfg -> @@ -106,8 +106,9 @@ container cn image = Container image (Host cn [] info) -- Reverting this property ensures that the container is stopped and -- removed. docked :: Container -> RevertableProperty -docked ctr@(Container _ h) = RevertableProperty +docked ctr@(Container _ h) = (propigateContainerInfo ctr (go "docked" setup)) + (go "undocked" teardown) where cn = hostName h @@ -134,10 +135,10 @@ docked ctr@(Container _ h) = RevertableProperty ] ] -propigateContainerInfo :: Container -> Property -> Property +propigateContainerInfo :: (IsProp (Property i)) => Container -> Property i -> Property HasInfo propigateContainerInfo ctr@(Container _ h) p = propigateContainer ctr p' where - p' = mkProperty + p' = infoProperty (propertyDesc p) (propertySatisfy p) (propertyInfo p <> dockerinfo) @@ -169,7 +170,7 @@ 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 +garbageCollected :: Property NoInfo garbageCollected = propertyList "docker garbage collected" [ gccontainers , gcimages @@ -185,7 +186,7 @@ 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 +tweaked :: Property NoInfo tweaked = trivial $ cmdProperty "sh" ["-c", "sed -ri 's/^session\\s+required\\s+pam_loginuid.so$/session optional pam_loginuid.so/' /etc/pam.d/*"] `describe` "tweaked for docker" @@ -196,7 +197,7 @@ tweaked = trivial $ -- other GRUB_CMDLINE_LINUX_DEFAULT settings. -- -- Only takes effect after reboot. (Not automated.) -memoryLimited :: Property +memoryLimited :: Property NoInfo memoryLimited = "/etc/default/grub" `File.containsLine` cfg `describe` "docker memory limited" `onChange` cmdProperty "update-grub" [] @@ -213,44 +214,44 @@ type RunParam = String type Image = String -- | Set custom dns server for container. -dns :: String -> Property +dns :: String -> Property HasInfo dns = runProp "dns" -- | Set container host name. -hostname :: String -> Property +hostname :: String -> Property HasInfo hostname = runProp "hostname" -- | Set name of container. -name :: String -> Property +name :: String -> Property HasInfo name = runProp "name" -- | Publish a container's port to the host -- (format: ip:hostPort:containerPort | ip::containerPort | hostPort:containerPort) -publish :: String -> Property +publish :: String -> Property HasInfo publish = runProp "publish" -- | Expose a container's port without publishing it. -expose :: String -> Property +expose :: String -> Property HasInfo expose = runProp "expose" -- | Username or UID for container. -user :: String -> Property +user :: String -> Property HasInfo user = runProp "user" -- | Mount a volume -- Create a bind mount with: [host-dir]:[container-dir]:[rw|ro] -- With just a directory, creates a volume in the container. -volume :: String -> Property +volume :: String -> Property HasInfo volume = runProp "volume" -- | Mount a volume from the specified container into the current -- container. -volumes_from :: ContainerName -> Property +volumes_from :: ContainerName -> Property HasInfo volumes_from cn = genProp "volumes-from" $ \hn -> fromContainerId (ContainerId hn cn) -- | Work dir inside the container. -workdir :: String -> Property +workdir :: String -> Property HasInfo workdir = runProp "workdir" -- | Memory limit for container. @@ -258,18 +259,18 @@ workdir = runProp "workdir" -- -- Note: Only takes effect when the host has the memoryLimited property -- enabled. -memory :: String -> Property +memory :: String -> Property HasInfo 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 +cpuShares :: Int -> Property HasInfo cpuShares = runProp "cpu-shares" . show -- | Link with another container on the same host. -link :: ContainerName -> ContainerAlias -> Property +link :: ContainerName -> ContainerAlias -> Property HasInfo link linkwith calias = genProp "link" $ \hn -> fromContainerId (ContainerId hn linkwith) ++ ":" ++ calias @@ -281,19 +282,19 @@ 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 +restartAlways :: Property HasInfo 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 +restartOnFailure :: Maybe Int -> Property HasInfo 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 +restartNever :: Property HasInfo restartNever = runProp "restart" "no" -- | A container is identified by its name, and the host @@ -327,12 +328,12 @@ fromContainerId (ContainerId hn cn) = cn++"."++hn++myContainerSuffix myContainerSuffix :: String myContainerSuffix = ".propellor" -containerDesc :: ContainerId -> Property -> Property +containerDesc :: (IsProp (Property i)) => ContainerId -> Property i -> Property i containerDesc cid p = p `describe` desc where desc = "container " ++ fromContainerId cid ++ " " ++ propertyDesc p -runningContainer :: ContainerId -> Image -> [RunParam] -> Property +runningContainer :: ContainerId -> Image -> [RunParam] -> Property NoInfo runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ property "running" $ do l <- liftIO $ listContainers RunningContainers if cid `elem` l @@ -447,7 +448,7 @@ init s = case toContainerId s of -- | Once a container is running, propellor can be run inside -- it to provision it. -provisionContainer :: ContainerId -> Property +provisionContainer :: ContainerId -> Property NoInfo provisionContainer cid = containerDesc cid $ property "provisioned" $ liftIO $ do let shim = Shim.file (localdir "propellor") (localdir shimdir cid) let params = ["--continue", show $ toChain cid] @@ -477,7 +478,8 @@ chain hostlist hn s = case toContainerId s of changeWorkingDirectory localdir onlyProcess (provisioningLock cid) $ do r <- runPropellor h $ ensureProperties $ - hostProperties h + map ignoreInfo $ + hostProperties h putStrLn $ "\n" ++ show r stopContainer :: ContainerId -> IO Bool @@ -486,7 +488,7 @@ stopContainer cid = boolSystem dockercmd [Param "stop", Param $ fromContainerId startContainer :: ContainerId -> IO Bool startContainer cid = boolSystem dockercmd [Param "start", Param $ fromContainerId cid ] -stoppedContainer :: ContainerId -> Property +stoppedContainer :: ContainerId -> Property NoInfo stoppedContainer cid = containerDesc cid $ property desc $ ifM (liftIO $ elem cid <$> listContainers RunningContainers) ( liftIO cleanup `after` ensureProperty @@ -538,13 +540,13 @@ listContainers status = listImages :: IO [Image] listImages = lines <$> readProcess dockercmd ["images", "--all", "--quiet"] -runProp :: String -> RunParam -> Property +runProp :: String -> RunParam -> Property HasInfo runProp field val = pureInfoProperty (param) $ dockerInfo $ mempty { _dockerRunParams = [DockerRunParam (\_ -> "--"++param)] } where param = field++"="++val -genProp :: String -> (HostName -> RunParam) -> Property +genProp :: String -> (HostName -> RunParam) -> Property HasInfo genProp field mkval = pureInfoProperty field $ dockerInfo $ mempty { _dockerRunParams = [DockerRunParam (\hn -> "--"++field++"=" ++ mkval hn)] } diff --git a/src/Propellor/Property/File.hs b/src/Propellor/Property/File.hs index 032268c4..7167d61e 100644 --- a/src/Propellor/Property/File.hs +++ b/src/Propellor/Property/File.hs @@ -9,7 +9,7 @@ import System.PosixCompat.Types type Line = String -- | Replaces all the content of a file. -hasContent :: FilePath -> [Line] -> Property +hasContent :: FilePath -> [Line] -> Property NoInfo f `hasContent` newcontent = fileProperty ("replace " ++ f) (\_oldcontent -> newcontent) f @@ -17,25 +17,25 @@ f `hasContent` newcontent = fileProperty ("replace " ++ f) -- -- The file's permissions are preserved if the file already existed. -- Otherwise, they're set to 600. -hasPrivContent :: IsContext c => FilePath -> c -> Property +hasPrivContent :: IsContext c => FilePath -> c -> Property HasInfo 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 +hasPrivContentFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property HasInfo 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 +hasPrivContentExposed :: IsContext c => FilePath -> c -> Property HasInfo hasPrivContentExposed f = hasPrivContentExposedFrom (PrivDataSourceFile (PrivFile f) f) f -hasPrivContentExposedFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property +hasPrivContentExposedFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property HasInfo hasPrivContentExposedFrom = hasPrivContent' writeFile -hasPrivContent' :: (IsContext c, IsPrivDataSource s) => (String -> FilePath -> IO ()) -> s -> FilePath -> c -> Property +hasPrivContent' :: (IsContext c, IsPrivDataSource s) => (String -> FilePath -> IO ()) -> s -> FilePath -> c -> Property HasInfo hasPrivContent' writer source f context = withPrivData source context $ \getcontent -> property desc $ getcontent $ \privcontent -> @@ -45,10 +45,10 @@ hasPrivContent' writer source f context = desc = "privcontent " ++ f -- | Ensures that a line is present in a file, adding it to the end if not. -containsLine :: FilePath -> Line -> Property +containsLine :: FilePath -> Line -> Property NoInfo f `containsLine` l = f `containsLines` [l] -containsLines :: FilePath -> [Line] -> Property +containsLines :: FilePath -> [Line] -> Property NoInfo f `containsLines` ls = fileProperty (f ++ " contains:" ++ show ls) go f where go content = content ++ filter (`notElem` content) ls @@ -56,17 +56,17 @@ 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 +lacksLine :: FilePath -> Line -> Property NoInfo f `lacksLine` l = fileProperty (f ++ " remove: " ++ l) (filter (/= l)) f -- | Removes a file. Does not remove symlinks or non-plain-files. -notPresent :: FilePath -> Property +notPresent :: FilePath -> Property NoInfo notPresent f = check (doesFileExist f) $ property (f ++ " not present") $ makeChange $ nukeFile f -fileProperty :: Desc -> ([Line] -> [Line]) -> FilePath -> Property +fileProperty :: Desc -> ([Line] -> [Line]) -> FilePath -> Property NoInfo fileProperty = fileProperty' writeFile -fileProperty' :: (FilePath -> String -> IO ()) -> Desc -> ([Line] -> [Line]) -> FilePath -> Property +fileProperty' :: (FilePath -> String -> IO ()) -> Desc -> ([Line] -> [Line]) -> FilePath -> Property NoInfo fileProperty' writer desc a f = property desc $ go =<< liftIO (doesFileExist f) where go True = do @@ -86,12 +86,12 @@ fileProperty' writer desc a f = property desc $ go =<< liftIO (doesFileExist f) setOwnerAndGroup f' (fileOwner s) (fileGroup s) -- | Ensures a directory exists. -dirExists :: FilePath -> Property +dirExists :: FilePath -> Property NoInfo dirExists d = check (not <$> doesDirectoryExist d) $ property (d ++ " exists") $ makeChange $ createDirectoryIfMissing True d -- | Ensures that a file/dir has the specified owner and group. -ownerGroup :: FilePath -> UserName -> GroupName -> Property +ownerGroup :: FilePath -> UserName -> GroupName -> Property NoInfo ownerGroup f owner group = property (f ++ " owner " ++ og) $ do r <- ensureProperty $ cmdProperty "chown" [og, f] if r == FailedChange @@ -101,7 +101,7 @@ ownerGroup f owner group = property (f ++ " owner " ++ og) $ do og = owner ++ ":" ++ group -- | Ensures that a file/dir has the specfied mode. -mode :: FilePath -> FileMode -> Property +mode :: FilePath -> FileMode -> Property NoInfo mode f v = property (f ++ " mode " ++ show v) $ do liftIO $ modifyFileMode f (\_old -> v) noChange diff --git a/src/Propellor/Property/Firewall.hs b/src/Propellor/Property/Firewall.hs index f9a027be..66292c8b 100644 --- a/src/Propellor/Property/Firewall.hs +++ b/src/Propellor/Property/Firewall.hs @@ -22,10 +22,10 @@ import Utility.SafeCommand import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Network as Network -installed :: Property +installed :: Property NoInfo installed = Apt.installed ["iptables"] -rule :: Chain -> Target -> Rules -> Property +rule :: Chain -> Target -> Rules -> Property NoInfo rule c t rs = property ("firewall rule: " <> show r) addIpTable where r = Rule c t rs diff --git a/src/Propellor/Property/Git.hs b/src/Propellor/Property/Git.hs index eb7801c1..c363d8c8 100644 --- a/src/Propellor/Property/Git.hs +++ b/src/Propellor/Property/Git.hs @@ -13,7 +13,7 @@ import Data.List -- -- Note that reverting this property does not remove or stop inetd. daemonRunning :: FilePath -> RevertableProperty -daemonRunning exportdir = RevertableProperty setup unsetup +daemonRunning exportdir = setup unsetup where setup = containsLine conf (mkl "tcp4") `requires` @@ -48,7 +48,7 @@ daemonRunning exportdir = RevertableProperty setup unsetup , exportdir ] -installed :: Property +installed :: Property NoInfo installed = Apt.installed ["git"] type RepoUrl = String @@ -62,7 +62,7 @@ type Branch = String -- it will be recursively deleted first. -- -- A branch can be specified, to check out. -cloned :: UserName -> RepoUrl -> FilePath -> Maybe Branch -> Property +cloned :: UserName -> RepoUrl -> FilePath -> Maybe Branch -> Property NoInfo cloned owner url dir mbranch = check originurl (property desc checkout) `requires` installed where @@ -98,7 +98,7 @@ isGitDir dir = isNothing <$> catchMaybeIO (readProcess "git" ["rev-parse", "--re data GitShared = Shared GroupName | SharedAll | NotShared -bareRepo :: FilePath -> UserName -> GitShared -> Property +bareRepo :: FilePath -> UserName -> GitShared -> Property NoInfo bareRepo repo user gitshared = check (isRepo repo) $ propertyList ("git repo: " ++ repo) $ dirExists repo : case gitshared of NotShared -> diff --git a/src/Propellor/Property/Gpg.hs b/src/Propellor/Property/Gpg.hs index 4a3e1872..dfb9d429 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 +installed :: Property NoInfo installed = Apt.installed ["gnupg"] -- A numeric id, or a description of the key, in a form understood by gpg. @@ -20,7 +20,7 @@ newtype GpgKeyId = GpgKeyId { getGpgKeyId :: String } -- -- 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 -> UserName -> Property +keyImported :: GpgKeyId -> UserName -> Property HasInfo keyImported (GpgKeyId keyid) user = flagFile' prop genflag `requires` installed where diff --git a/src/Propellor/Property/Group.hs b/src/Propellor/Property/Group.hs index 978d3bff..15524eb4 100644 --- a/src/Propellor/Property/Group.hs +++ b/src/Propellor/Property/Group.hs @@ -4,7 +4,7 @@ import Propellor type GID = Int -exists :: GroupName -> Maybe GID -> Property +exists :: GroupName -> Maybe GID -> Property NoInfo exists 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 0e89196c..1084ef9e 100644 --- a/src/Propellor/Property/Grub.hs +++ b/src/Propellor/Property/Grub.hs @@ -21,7 +21,7 @@ data BIOS = PC | EFI64 | EFI32 | Coreboot | Xen -- This includes running update-grub, so that the grub boot menu is -- created. It will be automatically updated when kernel packages are -- installed. -installed :: BIOS -> Property +installed :: BIOS -> Property NoInfo installed bios = Apt.installed [pkg] `describe` "grub package installed" `before` @@ -43,7 +43,7 @@ installed bios = -- 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 +boots :: OSDevice -> Property NoInfo boots dev = cmdProperty "grub-install" [dev] `describe` ("grub boots " ++ dev) @@ -55,7 +55,7 @@ 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 +chainPVGrub :: GrubDevice -> GrubDevice -> TimeoutSecs -> Property NoInfo chainPVGrub rootdev bootdev timeout = combineProperties desc [ File.dirExists "/boot/grub" , "/boot/grub/menu.lst" `File.hasContent` diff --git a/src/Propellor/Property/HostingProvider/CloudAtCost.hs b/src/Propellor/Property/HostingProvider/CloudAtCost.hs index 84c8a787..2cfdb951 100644 --- a/src/Propellor/Property/HostingProvider/CloudAtCost.hs +++ b/src/Propellor/Property/HostingProvider/CloudAtCost.hs @@ -6,7 +6,7 @@ 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 +decruft :: Property NoInfo decruft = propertyList "cloudatcost cleanup" [ Hostname.sane , "worked around grub/lvm boot bug #743126" ==> diff --git a/src/Propellor/Property/HostingProvider/DigitalOcean.hs b/src/Propellor/Property/HostingProvider/DigitalOcean.hs index 4d2534ec..be62ccdc 100644 --- a/src/Propellor/Property/HostingProvider/DigitalOcean.hs +++ b/src/Propellor/Property/HostingProvider/DigitalOcean.hs @@ -18,7 +18,7 @@ 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 +distroKernel :: Property NoInfo distroKernel = propertyList "digital ocean distro kernel hack" [ Apt.installed ["grub-pc", "kexec-tools", "file"] , "/etc/default/kexec" `File.containsLines` diff --git a/src/Propellor/Property/HostingProvider/Linode.hs b/src/Propellor/Property/HostingProvider/Linode.hs index 34d72184..90f41bf8 100644 --- a/src/Propellor/Property/HostingProvider/Linode.hs +++ b/src/Propellor/Property/HostingProvider/Linode.hs @@ -6,5 +6,5 @@ import qualified Propellor.Property.Grub as Grub -- | Linode's pv-grub-x86_64 does not currently support booting recent -- Debian kernels compressed with xz. This sets up pv-grub chaing to enable -- it. -chainPVGrub :: Grub.TimeoutSecs -> Property +chainPVGrub :: Grub.TimeoutSecs -> Property NoInfo chainPVGrub = Grub.chainPVGrub "hd0" "xen/xvda" diff --git a/src/Propellor/Property/Hostname.hs b/src/Propellor/Property/Hostname.hs index f1709d4d..20181213 100644 --- a/src/Propellor/Property/Hostname.hs +++ b/src/Propellor/Property/Hostname.hs @@ -17,10 +17,10 @@ import Data.List -- 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 +sane :: Property NoInfo sane = property ("sane hostname") (ensureProperty . setTo =<< asks hostName) -setTo :: HostName -> Property +setTo :: HostName -> Property NoInfo setTo hn = combineProperties desc go where desc = "hostname " ++ hn @@ -46,7 +46,7 @@ setTo hn = combineProperties desc go -- | Makes contain search and domain lines for -- the domain that the hostname is in. -searchDomain :: Property +searchDomain :: Property NoInfo searchDomain = property desc (ensureProperty . go =<< asks hostName) where desc = "resolv.conf search and domain configured" diff --git a/src/Propellor/Property/Journald.hs b/src/Propellor/Property/Journald.hs index d21def0a..3ab4e9d7 100644 --- a/src/Propellor/Property/Journald.hs +++ b/src/Propellor/Property/Journald.hs @@ -4,7 +4,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 +configured :: Systemd.Option -> String -> Property NoInfo configured option value = Systemd.configured "/etc/systemd/journald.conf" option value `onChange` Systemd.restarted "systemd-journald" @@ -13,27 +13,27 @@ configured option value = -- Examples: "100 megabytes" or "0.5tb" type DataSize = String -configuredSize :: Systemd.Option -> DataSize -> Property +configuredSize :: Systemd.Option -> DataSize -> Property NoInfo configuredSize option s = case readSize dataUnits s of Just sz -> configured option (systemdSizeUnits sz) Nothing -> property ("unable to parse " ++ option ++ " data size " ++ s) noChange -systemMaxUse :: DataSize -> Property +systemMaxUse :: DataSize -> Property NoInfo systemMaxUse = configuredSize "SystemMaxUse" -runtimeMaxUse :: DataSize -> Property +runtimeMaxUse :: DataSize -> Property NoInfo runtimeMaxUse = configuredSize "RuntimeMaxUse" -systemKeepFree :: DataSize -> Property +systemKeepFree :: DataSize -> Property NoInfo systemKeepFree = configuredSize "SystemKeepFree" -runtimeKeepFree :: DataSize -> Property +runtimeKeepFree :: DataSize -> Property NoInfo runtimeKeepFree = configuredSize "RuntimeKeepFree" -systemMaxFileSize :: DataSize -> Property +systemMaxFileSize :: DataSize -> Property NoInfo systemMaxFileSize = configuredSize "SystemMaxFileSize" -runtimeMaxFileSize :: DataSize -> Property +runtimeMaxFileSize :: DataSize -> Property NoInfo runtimeMaxFileSize = configuredSize "RuntimeMaxFileSize" -- Generates size units as used in journald.conf. diff --git a/src/Propellor/Property/List.hs b/src/Propellor/Property/List.hs new file mode 100644 index 00000000..283c5ec7 --- /dev/null +++ b/src/Propellor/Property/List.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} + +module Propellor.Property.List ( + PropertyList(..), + PropertyListType, +) where + +import Propellor.Types +import Propellor.Engine +import Propellor.PropAccum + +import Data.Monoid + +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 propigate 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 "foo" $ props + -- > & someproperty + -- > ! oldproperty + -- > & otherproperty + 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 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 PropList where + propertyList desc = propertyList desc . getProperties + combineProperties desc = combineProperties desc . getProperties + +combineSatisfy :: [Property i] -> Result -> Propellor Result +combineSatisfy [] rs = return rs +combineSatisfy (l:ls) rs = do + r <- ensureProperty $ ignoreInfo l + case r of + FailedChange -> return FailedChange + _ -> combineSatisfy ls (r <> rs) diff --git a/src/Propellor/Property/Network.hs b/src/Propellor/Property/Network.hs index e04290aa..4d7ccffb 100644 --- a/src/Propellor/Property/Network.hs +++ b/src/Propellor/Property/Network.hs @@ -5,7 +5,7 @@ import Propellor.Property.File type Interface = String -ifUp :: Interface -> Property +ifUp :: Interface -> Property NoInfo ifUp iface = cmdProperty "ifup" [iface] -- | Resets /etc/network/interfaces to a clean and empty state, @@ -15,7 +15,7 @@ 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 +cleanInterfacesFile :: Property NoInfo cleanInterfacesFile = hasContent interfacesFile [ "# Deployed by propellor, do not edit." , "" @@ -38,7 +38,7 @@ cleanInterfacesFile = hasContent interfacesFile -- -- (ipv6 addresses are not included because it's assumed they come up -- automatically in most situations.) -static :: Interface -> Property +static :: Interface -> Property NoInfo static iface = check (not <$> doesFileExist f) setup `describe` desc `requires` interfacesDEnabled @@ -69,7 +69,7 @@ static iface = check (not <$> doesFileExist f) setup _ -> Nothing -- | 6to4 ipv6 connection, should work anywhere -ipv6to4 :: Property +ipv6to4 :: Property NoInfo ipv6to4 = hasContent (interfaceDFile "sit0") [ "# Deployed by propellor, do not edit." , "iface sit0 inet6 static" @@ -90,6 +90,6 @@ interfaceDFile :: Interface -> FilePath interfaceDFile iface = "/etc/network/interfaces.d" iface -- | Ensures that files in the the interfaces.d directory are used. -interfacesDEnabled :: Property +interfacesDEnabled :: Property NoInfo interfacesDEnabled = 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 397570d2..02ca202f 100644 --- a/src/Propellor/Property/Nginx.hs +++ b/src/Propellor/Property/Nginx.hs @@ -9,7 +9,7 @@ import System.Posix.Files type ConfigFile = [String] siteEnabled :: HostName -> ConfigFile -> RevertableProperty -siteEnabled hn cf = RevertableProperty enable disable +siteEnabled hn cf = enable disable where enable = check test prop `describe` ("nginx site enabled " ++ hn) @@ -27,7 +27,7 @@ siteEnabled hn cf = RevertableProperty enable disable `requires` installed `onChange` reloaded -siteAvailable :: HostName -> ConfigFile -> Property +siteAvailable :: HostName -> ConfigFile -> Property NoInfo siteAvailable hn cf = ("nginx site available " ++ hn) ==> siteCfg hn `File.hasContent` (comment : cf) where @@ -42,11 +42,11 @@ siteVal hn = "/etc/nginx/sites-enabled/" ++ hn siteValRelativeCfg :: HostName -> FilePath siteValRelativeCfg hn = "../sites-available/" ++ hn -installed :: Property +installed :: Property NoInfo installed = Apt.installed ["nginx"] -restarted :: Property +restarted :: Property NoInfo restarted = Service.restarted "nginx" -reloaded :: Property +reloaded :: Property NoInfo reloaded = Service.reloaded "nginx" diff --git a/src/Propellor/Property/OS.hs b/src/Propellor/Property/OS.hs index c1b085a6..710428d4 100644 --- a/src/Propellor/Property/OS.hs +++ b/src/Propellor/Property/OS.hs @@ -65,7 +65,7 @@ import Control.Exception (throw) -- > & User.accountFor "joey" -- > & User.hasSomePassword "joey" -- > -- rest of system properties here -cleanInstallOnce :: Confirmation -> Property +cleanInstallOnce :: Confirmation -> Property NoInfo cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $ go `requires` confirmed "clean install confirmed" confirmation where @@ -89,10 +89,10 @@ cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $ (Just u@(System (Ubuntu _) _)) -> debootstrap u _ -> error "os is not declared to be Debian or Ubuntu" - debootstrap targetos = ensureProperty $ toProp $ + debootstrap targetos = ensureProperty $ fromJust $ toSimpleProp $ -- Ignore the os setting, and install debootstrap from -- source, since we don't know what OS we're running in yet. - Debootstrap.built' Debootstrap.sourceInstall + Debootstrap.built' (toProp Debootstrap.sourceInstall) newOSDir targetos Debootstrap.DefaultConfig -- debootstrap, I wish it was faster.. -- TODO eatmydata to speed it up @@ -180,7 +180,7 @@ massRename = go [] data Confirmation = Confirmed HostName -confirmed :: Desc -> Confirmation -> Property +confirmed :: Desc -> Confirmation -> Property NoInfo confirmed desc (Confirmed c) = property desc $ do hostname <- asks hostName if hostname /= c @@ -192,7 +192,7 @@ 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 +preserveNetwork :: Property NoInfo preserveNetwork = go `requires` Network.cleanInterfacesFile where go = property "preserve network configuration" $ do @@ -206,7 +206,7 @@ preserveNetwork = go `requires` Network.cleanInterfacesFile return FailedChange -- | is copied from the old OS -preserveResolvConf :: Property +preserveResolvConf :: Property NoInfo preserveResolvConf = check (fileExist oldloc) $ property (newloc ++ " copied from old OS") $ do ls <- liftIO $ lines <$> readFile oldloc @@ -218,7 +218,7 @@ 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 +preserveRootSshAuthorized :: Property NoInfo preserveRootSshAuthorized = check (fileExist oldloc) $ property (newloc ++ " copied from old OS") $ do ks <- liftIO $ lines <$> readFile oldloc @@ -228,7 +228,7 @@ preserveRootSshAuthorized = check (fileExist oldloc) $ oldloc = oldOSDir ++ newloc -- Removes the old OS's backup from -oldOSRemoved :: Confirmation -> Property +oldOSRemoved :: Confirmation -> Property NoInfo oldOSRemoved confirmation = check (doesDirectoryExist oldOSDir) $ go `requires` confirmed "old OS backup removal confirmed" confirmation where diff --git a/src/Propellor/Property/Obnam.hs b/src/Propellor/Property/Obnam.hs index 4dc895ef..9d283527 100644 --- a/src/Propellor/Property/Obnam.hs +++ b/src/Propellor/Property/Obnam.hs @@ -36,7 +36,7 @@ data NumClients = OnlyClient | MultipleClients -- > `requires` Ssh.keyImported SshRsa "root" (Context hostname) -- -- How awesome is that? -backup :: FilePath -> Cron.CronTimes -> [ObnamParam] -> NumClients -> Property +backup :: FilePath -> Cron.CronTimes -> [ObnamParam] -> NumClients -> Property NoInfo backup dir crontimes params numclients = backup' dir crontimes params numclients `requires` restored dir params @@ -46,7 +46,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.CronTimes -> [ObnamParam] -> NumClients -> Gpg.GpgKeyId -> Property +backupEncrypted :: FilePath -> Cron.CronTimes -> [ObnamParam] -> NumClients -> Gpg.GpgKeyId -> Property HasInfo backupEncrypted dir crontimes params numclients keyid = backup dir crontimes params' numclients `requires` Gpg.keyImported keyid "root" @@ -54,7 +54,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.CronTimes -> [ObnamParam] -> NumClients -> Property +backup' :: FilePath -> Cron.CronTimes -> [ObnamParam] -> NumClients -> Property NoInfo backup' dir crontimes params numclients = cronjob `describe` desc where desc = dir ++ " backed up by obnam" @@ -80,7 +80,7 @@ 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 +restored :: FilePath -> [ObnamParam] -> Property NoInfo restored dir params = property (dir ++ " restored by obnam") go `requires` installed where @@ -108,17 +108,17 @@ restored dir params = property (dir ++ " restored by obnam") go , return FailedChange ) -installed :: Property +installed :: Property NoInfo installed = Apt.installed ["obnam"] -- | Ensures that a recent version of obnam gets installed. -- -- Only does anything for Debian Stable. -latestVersion :: Property +latestVersion :: Property NoInfo latestVersion = withOS "obnam latest version" $ \o -> case o of (Just (System (Debian suite) _)) | isStable suite -> ensureProperty $ Apt.setSourcesListD (stablesources suite) "obnam" - `requires` toProp (Apt.trustsKey key) + `requires` (fromJust (toSimpleProp (Apt.trustsKey key))) _ -> noChange where stablesources suite = diff --git a/src/Propellor/Property/OpenId.hs b/src/Propellor/Property/OpenId.hs index f8045027..7ecf345f 100644 --- a/src/Propellor/Property/OpenId.hs +++ b/src/Propellor/Property/OpenId.hs @@ -7,8 +7,8 @@ import qualified Propellor.Property.Service as Service import Data.List -providerFor :: [UserName] -> String -> Property -providerFor users baseurl = propertyList desc $ +providerFor :: [UserName] -> String -> Property HasInfo +providerFor users baseurl = propertyList desc $ map toProp [ Apt.serviceInstalledRunning "apache2" , Apt.installed ["simpleid"] `onChange` Service.restarted "apache2" diff --git a/src/Propellor/Property/Postfix.hs b/src/Propellor/Property/Postfix.hs index cdb7bdee..fbb1ea51 100644 --- a/src/Propellor/Property/Postfix.hs +++ b/src/Propellor/Property/Postfix.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleContexts #-} + module Propellor.Property.Postfix where import Propellor @@ -9,13 +11,13 @@ import qualified Data.Map as M import Data.List import Data.Char -installed :: Property +installed :: Property NoInfo installed = Apt.serviceInstalledRunning "postfix" -restarted :: Property +restarted :: Property NoInfo restarted = Service.restarted "postfix" -reloaded :: Property +reloaded :: Property NoInfo reloaded = Service.reloaded "postfix" -- | Configures postfix as a satellite system, which @@ -24,7 +26,7 @@ reloaded = Service.reloaded "postfix" -- The smarthost may refuse to relay mail on to other domains, without -- futher coniguration/keys. But this should be enough to get cron job -- mail flowing to a place where it will be seen. -satellite :: Property +satellite :: Property NoInfo satellite = check (not <$> mainCfIsSet "relayhost") setup `requires` installed where @@ -45,13 +47,17 @@ satellite = check (not <$> mainCfIsSet "relayhost") setup -- | 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 :: FilePath -> (FilePath -> Property) -> Property +mappedFile + :: Combines (Property x) (Property NoInfo) + => FilePath + -> (FilePath -> Property x) + -> Property (CInfo x NoInfo) mappedFile f setup = setup f `onChange` cmdProperty "postmap" [f] -- | Run newaliases command, which should be done after changing -- . -newaliases :: Property +newaliases :: Property NoInfo newaliases = trivial $ cmdProperty "newaliases" [] -- | The main config file for postfix. @@ -59,7 +65,7 @@ mainCfFile :: FilePath mainCfFile = "/etc/postfix/main.cf" -- | Sets a main.cf name=value pair. Does not reload postfix immediately. -mainCf :: (String, String) -> Property +mainCf :: (String, String) -> Property NoInfo mainCf (name, value) = check notset set `describe` ("postfix main.cf " ++ setting) where @@ -96,7 +102,7 @@ mainCfIsSet name = do -- -- Note that multiline configurations that continue onto the next line -- are not currently supported. -dedupMainCf :: Property +dedupMainCf :: Property NoInfo dedupMainCf = fileProperty "postfix main.cf dedupped" dedupCf mainCfFile dedupCf :: [String] -> [String] diff --git a/src/Propellor/Property/Prosody.hs b/src/Propellor/Property/Prosody.hs index 06e2355f..31b6a624 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 -confEnabled conf cf = RevertableProperty enable disable +confEnabled conf cf = enable disable where enable = check test prop `describe` ("prosody conf enabled " ++ conf) @@ -30,7 +30,7 @@ confEnabled conf cf = RevertableProperty enable disable `requires` installed `onChange` reloaded -confAvailable :: Conf -> ConfigFile -> Property +confAvailable :: Conf -> ConfigFile -> Property NoInfo confAvailable conf cf = ("prosody conf available " ++ conf) ==> confAvailPath conf `File.hasContent` (comment : cf) where @@ -42,11 +42,11 @@ confAvailPath conf = "/etc/prosody/conf.avail" conf <.> "cfg.lua" confValPath :: Conf -> FilePath confValPath conf = "/etc/prosody/conf.d" conf <.> "cfg.lua" -installed :: Property +installed :: Property NoInfo installed = Apt.installed ["prosody"] -restarted :: Property +restarted :: Property NoInfo restarted = Service.restarted "prosody" -reloaded :: Property +reloaded :: Property NoInfo reloaded = Service.reloaded "prosody" diff --git a/src/Propellor/Property/Reboot.hs b/src/Propellor/Property/Reboot.hs index ac6f3a44..750968ff 100644 --- a/src/Propellor/Property/Reboot.hs +++ b/src/Propellor/Property/Reboot.hs @@ -3,7 +3,7 @@ module Propellor.Property.Reboot where import Propellor import Utility.SafeCommand -now :: Property +now :: Property NoInfo now = cmdProperty "reboot" [] `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 +atEnd :: Bool -> (Result -> Bool) -> Property NoInfo atEnd force resultok = property "scheduled reboot at end of propellor run" $ do endAction "rebooting" atend return NoChange diff --git a/src/Propellor/Property/Scheduled.hs b/src/Propellor/Property/Scheduled.hs index f2911e50..06efacdf 100644 --- a/src/Propellor/Property/Scheduled.hs +++ b/src/Propellor/Property/Scheduled.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleContexts #-} + module Propellor.Property.Scheduled ( period , periodParse @@ -18,8 +20,8 @@ import qualified Data.Map as M -- -- This uses the description of the Property to keep track of when it was -- last run. -period :: Property -> Recurrance -> Property -period prop recurrance = flip describe desc $ adjustProperty prop $ \satisfy -> do +period :: (IsProp (Property i)) => Property i -> Recurrance -> Property i +period prop recurrance = flip describe desc $ adjustPropertySatisfy prop $ \satisfy -> do lasttime <- liftIO $ getLastChecked (propertyDesc prop) nexttime <- liftIO $ fmap startTime <$> nextTime schedule lasttime t <- liftIO localNow @@ -34,7 +36,7 @@ period prop recurrance = flip describe desc $ adjustProperty prop $ \satisfy -> desc = propertyDesc prop ++ " (period " ++ fromRecurrance recurrance ++ ")" -- | Like period, but parse a human-friendly string. -periodParse :: Property -> String -> Property +periodParse :: Property NoInfo -> String -> Property NoInfo periodParse prop s = case toRecurrance s of Just recurrance -> period prop recurrance Nothing -> property "periodParse" $ do diff --git a/src/Propellor/Property/Service.hs b/src/Propellor/Property/Service.hs index 93e959c6..8da502f7 100644 --- a/src/Propellor/Property/Service.hs +++ b/src/Propellor/Property/Service.hs @@ -12,16 +12,16 @@ 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 +running :: ServiceName -> Property NoInfo running = signaled "start" "running" -restarted :: ServiceName -> Property +restarted :: ServiceName -> Property NoInfo restarted = signaled "restart" "restarted" -reloaded :: ServiceName -> Property +reloaded :: ServiceName -> Property NoInfo reloaded = signaled "reload" "reloaded" -signaled :: String -> Desc -> ServiceName -> Property +signaled :: String -> Desc -> ServiceName -> Property NoInfo signaled cmd desc svc = property (desc ++ " " ++ svc) $ do void $ ensureProperty $ scriptProperty ["service " ++ shellEscape svc ++ " " ++ cmd ++ " >/dev/null 2>&1 || true"] diff --git a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs index bf87b210..7fc523f9 100644 --- a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs +++ b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleContexts #-} + module Propellor.Property.SiteSpecific.GitAnnexBuilder where import Propellor @@ -23,54 +25,56 @@ builddir = gitbuilderdir "build" type TimeOut = String -- eg, 5h -autobuilder :: Architecture -> CronTimes -> TimeOut -> Property -autobuilder arch crontimes timeout = combineProperties "gitannexbuilder" - [ Apt.serviceInstalledRunning "cron" - , Cron.niceJob "gitannexbuilder" crontimes builduser gitbuilderdir $ - "git pull ; timeout " ++ timeout ++ " ./autobuild" +autobuilder :: Architecture -> CronTimes -> TimeOut -> Property HasInfo +autobuilder arch crontimes timeout = combineProperties "gitannexbuilder" $ props + & Apt.serviceInstalledRunning "cron" + & Cron.niceJob "gitannexbuilder" crontimes builduser gitbuilderdir + ("git pull ; timeout " ++ timeout ++ " ./autobuild") + & rsyncpassword + where + context = Context ("gitannexbuilder " ++ arch) + pwfile = homedir "rsyncpassword" -- 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. - , withPrivData (Password builduser) context $ \getpw -> + rsyncpassword = withPrivData (Password builduser) context $ \getpw -> property "rsync password" $ getpw $ \pw -> do oldpw <- liftIO $ catchDefaultIO "" $ readFileStrict pwfile if pw /= oldpw then makeChange $ writeFile pwfile pw else noChange - ] - where - context = Context ("gitannexbuilder " ++ arch) - pwfile = homedir "rsyncpassword" -tree :: Architecture -> Property -tree buildarch = combineProperties "gitannexbuilder tree" - [ Apt.installed ["git"] +tree :: Architecture -> Property HasInfo +tree buildarch = combineProperties "gitannexbuilder tree" $ props + & Apt.installed ["git"] -- gitbuilderdir directory already exists when docker volume is used, -- but with wrong owner. - , File.dirExists gitbuilderdir - , File.ownerGroup gitbuilderdir builduser builduser - , check (not <$> (doesDirectoryExist (gitbuilderdir ".git"))) $ + & File.dirExists gitbuilderdir + & File.ownerGroup gitbuilderdir builduser builduser + & gitannexbuildercloned + & builddircloned + where + gitannexbuildercloned = check (not <$> (doesDirectoryExist (gitbuilderdir ".git"))) $ userScriptProperty builduser [ "git clone git://git.kitenet.net/gitannexbuilder " ++ gitbuilderdir , "cd " ++ gitbuilderdir , "git checkout " ++ buildarch ] `describe` "gitbuilder setup" - , check (not <$> doesDirectoryExist builddir) $ userScriptProperty builduser + builddircloned = check (not <$> doesDirectoryExist builddir) $ userScriptProperty builduser [ "git clone git://git-annex.branchable.com/ " ++ builddir ] - ] -buildDepsApt :: Property -buildDepsApt = combineProperties "gitannexbuilder build deps" - [ Apt.buildDep ["git-annex"] - , Apt.installed ["liblockfile-simple-perl"] - , buildDepsNoHaskellLibs - , "git-annex source build deps installed" ==> Apt.buildDepIn builddir - ] +buildDepsApt :: Property HasInfo +buildDepsApt = combineProperties "gitannexbuilder build deps" $ props + & Apt.buildDep ["git-annex"] + & Apt.installed ["liblockfile-simple-perl"] + & buildDepsNoHaskellLibs + & Apt.buildDepIn builddir + `describe` "git-annex source build deps installed" -buildDepsNoHaskellLibs :: Property +buildDepsNoHaskellLibs :: Property NoInfo buildDepsNoHaskellLibs = Apt.installed ["git", "rsync", "moreutils", "ca-certificates", "debhelper", "ghc", "curl", "openssh-client", "git-remote-gcrypt", @@ -82,7 +86,7 @@ buildDepsNoHaskellLibs = Apt.installed -- Installs current versions of git-annex's deps from cabal, but only -- does so once. -cabalDeps :: Property +cabalDeps :: Property NoInfo cabalDeps = flagFile go cabalupdated where go = userScriptProperty builduser ["cabal update && cabal install git-annex --only-dependencies || true"] @@ -108,7 +112,13 @@ androidAutoBuilderContainer dockerImage crontimes timeout = & autobuilder "android" crontimes timeout -- Android is cross-built in a Debian i386 container, using the Android NDK. -androidContainer :: (System -> Docker.Image) -> Docker.ContainerName -> Property -> FilePath -> Docker.Container +androidContainer + :: (IsProp (Property (CInfo NoInfo i)), (Combines (Property NoInfo) (Property i))) + => (System -> Docker.Image) + -> Docker.ContainerName + -> Property i + -> FilePath + -> Docker.Container androidContainer dockerImage name setupgitannexdir gitannexdir = Docker.container name (dockerImage osver) & os osver diff --git a/src/Propellor/Property/SiteSpecific/GitHome.hs b/src/Propellor/Property/SiteSpecific/GitHome.hs index 6ed02146..59e62d80 100644 --- a/src/Propellor/Property/SiteSpecific/GitHome.hs +++ b/src/Propellor/Property/SiteSpecific/GitHome.hs @@ -6,7 +6,7 @@ import Propellor.Property.User import Utility.SafeCommand -- | Clones Joey Hess's git home directory, and runs its fixups script. -installedFor :: UserName -> Property +installedFor :: UserName -> Property NoInfo installedFor user = check (not <$> hasGitDir user) $ property ("githome " ++ user) (go =<< liftIO (homedir user)) `requires` Apt.installed ["git"] diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs index 10312b4e..34a5f02f 100644 --- a/src/Propellor/Property/SiteSpecific/JoeySites.hs +++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs @@ -22,22 +22,18 @@ import Data.List import System.Posix.Files import Data.String.Utils -oldUseNetServer :: [Host] -> Property -oldUseNetServer hosts = propertyList ("olduse.net server") - [ oldUseNetInstalled "oldusenet-server" - , Obnam.latestVersion - , Obnam.backup datadir "33 4 * * *" - [ "--repository=sftp://2318@usw-s002.rsync.net/~/olduse.net" - , "--client-name=spool" - ] Obnam.OnlyClient - `requires` Ssh.keyImported SshRsa "root" (Context "olduse.net") - `requires` Ssh.knownHost hosts "usw-s002.rsync.net" "root" - , check (not . isSymbolicLink <$> getSymbolicLinkStatus newsspool) $ - property "olduse.net spool in place" $ makeChange $ do +oldUseNetServer :: [Host] -> Property HasInfo +oldUseNetServer hosts = propertyList "olduse.net server" $ props + & oldUseNetInstalled "oldusenet-server" + & Obnam.latestVersion + & oldUseNetBackup + & check (not . isSymbolicLink <$> getSymbolicLinkStatus newsspool) + (property "olduse.net spool in place" $ makeChange $ do removeDirectoryRecursive newsspool createSymbolicLink (datadir "news") newsspool - , Apt.installed ["leafnode"] - , "/etc/news/leafnode/config" `File.hasContent` + ) + & Apt.installed ["leafnode"] + & "/etc/news/leafnode/config" `File.hasContent` [ "# olduse.net configuration (deployed by propellor)" , "expire = 1000000" -- no expiry via texpire , "server = " -- no upstream server @@ -45,17 +41,22 @@ oldUseNetServer hosts = propertyList ("olduse.net server") , "allowSTRANGERS = 42" -- lets anyone connect , "nopost = 1" -- no new posting (just gather them) ] - , "/etc/hosts.deny" `File.lacksLine` "leafnode: ALL" - , Apt.serviceInstalledRunning "openbsd-inetd" - , File.notPresent "/etc/cron.daily/leafnode" - , File.notPresent "/etc/cron.d/leafnode" - , Cron.niceJob "oldusenet-expire" "11 1 * * *" "news" newsspool $ intercalate ";" + & "/etc/hosts.deny" `File.lacksLine` "leafnode: ALL" + & Apt.serviceInstalledRunning "openbsd-inetd" + & File.notPresent "/etc/cron.daily/leafnode" + & File.notPresent "/etc/cron.d/leafnode" + & Cron.niceJob "oldusenet-expire" "11 1 * * *" "news" newsspool expirecommand + & Cron.niceJob "oldusenet-uucp" "*/5 * * * *" "news" "/" uucpcommand + & Apache.siteEnabled "nntp.olduse.net" nntpcfg + where + newsspool = "/var/spool/news" + datadir = "/var/spool/oldusenet" + expirecommand = intercalate ";" [ "find \\( -path ./out.going -or -path ./interesting.groups -or -path './*/.overview' \\) -prune -or -type f -ctime +60 -print | xargs --no-run-if-empty rm" , "find -type d -empty | xargs --no-run-if-empty rmdir" ] - , Cron.niceJob "oldusenet-uucp" "*/5 * * * *" "news" "/" $ - "/usr/bin/uucp " ++ datadir - , toProp $ Apache.siteEnabled "nntp.olduse.net" $ apachecfg "nntp.olduse.net" False + uucpcommand = "/usr/bin/uucp " ++ datadir + nntpcfg = apachecfg "nntp.olduse.net" False [ " DocumentRoot " ++ datadir ++ "/" , " " , " Options Indexes FollowSymlinks" @@ -63,23 +64,25 @@ oldUseNetServer hosts = propertyList ("olduse.net server") , Apache.allowAll , " " ] - ] - where - newsspool = "/var/spool/news" - datadir = "/var/spool/oldusenet" -oldUseNetShellBox :: Property -oldUseNetShellBox = propertyList "olduse.net shellbox" - [ oldUseNetInstalled "oldusenet" - , Service.running "shellinabox" - ] + oldUseNetBackup = Obnam.backup datadir "33 4 * * *" + [ "--repository=sftp://2318@usw-s002.rsync.net/~/olduse.net" + , "--client-name=spool" + ] Obnam.OnlyClient + `requires` Ssh.keyImported SshRsa "root" (Context "olduse.net") + `requires` Ssh.knownHost hosts "usw-s002.rsync.net" "root" + +oldUseNetShellBox :: Property HasInfo +oldUseNetShellBox = propertyList "olduse.net shellbox" $ props + & oldUseNetInstalled "oldusenet" + & Service.running "shellinabox" -oldUseNetInstalled :: Apt.Package -> Property +oldUseNetInstalled :: Apt.Package -> Property HasInfo oldUseNetInstalled pkg = check (not <$> Apt.isInstalled pkg) $ - propertyList ("olduse.net " ++ pkg) - [ 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") + 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") `describe` "olduse.net build deps" - , scriptProperty + & scriptProperty [ "rm -rf /root/tmp/oldusenet" -- idenpotency , "git clone git://olduse.net/ /root/tmp/oldusenet/source" , "cd /root/tmp/oldusenet/source/" @@ -88,12 +91,15 @@ oldUseNetInstalled pkg = check (not <$> Apt.isInstalled pkg) $ , "apt-get -fy install" -- dependencies , "rm -rf /root/tmp/oldusenet" ] `describe` "olduse.net built" - ] - -kgbServer :: Property -kgbServer = propertyList desc - [ withOS desc $ \o -> case o of +kgbServer :: Property HasInfo +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 (Just (System (Debian Unstable) _)) -> ensureProperty $ propertyList desc [ Apt.serviceInstalledRunning "kgb-bot" @@ -102,28 +108,22 @@ kgbServer = propertyList desc `onChange` Service.running "kgb-bot" ] _ -> error "kgb server needs Debian unstable (for kgb-bot 1.31+)" - , File.hasPrivContent "/etc/kgb-bot/kgb.conf" anyContext - `onChange` Service.restarted "kgb-bot" - ] - where - desc = "kgb.kitenet.net setup" -mumbleServer :: [Host] -> Property -mumbleServer hosts = combineProperties hn - [ Apt.serviceInstalledRunning "mumble-server" - , Obnam.latestVersion - , Obnam.backup "/var/lib/mumble-server" "55 5 * * *" +mumbleServer :: [Host] -> Property HasInfo +mumbleServer hosts = combineProperties hn $ props + & Apt.serviceInstalledRunning "mumble-server" + & Obnam.latestVersion + & Obnam.backup "/var/lib/mumble-server" "55 5 * * *" [ "--repository=sftp://joey@usbackup.kitenet.net/~/lib/backup/" ++ hn ++ ".obnam" , "--client-name=mumble" ] Obnam.OnlyClient `requires` Ssh.keyImported SshRsa "root" (Context hn) `requires` Ssh.knownHost hosts "usbackup.kitenet.net" "root" - , trivial $ cmdProperty "chown" ["-R", "mumble-server:mumble-server", "/var/lib/mumble-server"] - ] + & trivial (cmdProperty "chown" ["-R", "mumble-server:mumble-server", "/var/lib/mumble-server"]) where hn = "mumble.debian.net" -obnamLowMem :: Property +obnamLowMem :: Property NoInfo obnamLowMem = combineProperties "obnam tuned for low memory use" [ Obnam.latestVersion , "/etc/obnam.conf" `File.containsLines` @@ -135,10 +135,10 @@ obnamLowMem = combineProperties "obnam tuned for low memory use" ] -- git.kitenet.net and git.joeyh.name -gitServer :: [Host] -> Property -gitServer hosts = propertyList "git.kitenet.net setup" - [ Obnam.latestVersion - , Obnam.backupEncrypted "/srv/git" "33 3 * * *" +gitServer :: [Host] -> Property HasInfo +gitServer hosts = propertyList "git.kitenet.net setup" $ props + & Obnam.latestVersion + & Obnam.backupEncrypted "/srv/git" "33 3 * * *" [ "--repository=sftp://2318@usw-s002.rsync.net/~/git.kitenet.net" , "--client-name=wren" -- historical ] Obnam.OnlyClient (Gpg.GpgKeyId "1B169BE1") @@ -146,14 +146,14 @@ gitServer hosts = propertyList "git.kitenet.net setup" `requires` Ssh.knownHost hosts "usw-s002.rsync.net" "root" `requires` Ssh.authorizedKeys "family" (Context "git.kitenet.net") `requires` User.accountFor "family" - , Apt.installed ["git", "rsync", "gitweb"] + & Apt.installed ["git", "rsync", "gitweb"] -- backport avoids channel flooding on branch merge - , Apt.installedBackport ["kgb-client"] + & Apt.installedBackport ["kgb-client"] -- backport supports ssh event notification - , Apt.installedBackport ["git-annex"] - , File.hasPrivContentExposed "/etc/kgb-bot/kgb-client.conf" anyContext - , toProp $ Git.daemonRunning "/srv/git" - , "/etc/gitweb.conf" `File.containsLines` + & Apt.installedBackport ["git-annex"] + & File.hasPrivContentExposed "/etc/kgb-bot/kgb-client.conf" anyContext + & Git.daemonRunning "/srv/git" + & "/etc/gitweb.conf" `File.containsLines` [ "$projectroot = '/srv/git';" , "@git_base_url_list = ('git://git.kitenet.net', 'http://git.kitenet.net/git', 'https://git.kitenet.net/git', 'ssh://git.kitenet.net/srv/git');" , "# disable snapshot download; overloads server" @@ -161,15 +161,14 @@ gitServer hosts = propertyList "git.kitenet.net setup" ] `describe` "gitweb configured" -- Repos push on to github. - , Ssh.knownHost hosts "github.com" "joey" + & Ssh.knownHost hosts "github.com" "joey" -- I keep the website used for gitweb checked into git.. - , Git.cloned "root" "/srv/git/joey/git.kitenet.net.git" "/srv/web/git.kitenet.net" Nothing - , website "git.kitenet.net" - , website "git.joeyh.name" - , toProp $ Apache.modEnabled "cgi" - ] + & Git.cloned "root" "/srv/git/joey/git.kitenet.net.git" "/srv/web/git.kitenet.net" Nothing + & website "git.kitenet.net" + & website "git.joeyh.name" + & Apache.modEnabled "cgi" where - website hn = toProp $ Apache.siteEnabled hn $ apachecfg hn True + website hn = apacheSite hn True [ " DocumentRoot /srv/web/git.kitenet.net/" , " " , " Options Indexes ExecCGI FollowSymlinks" @@ -188,18 +187,17 @@ gitServer hosts = propertyList "git.kitenet.net setup" type AnnexUUID = String -- | A website, with files coming from a git-annex repository. -annexWebSite :: Git.RepoUrl -> HostName -> AnnexUUID -> [(String, Git.RepoUrl)] -> Property -annexWebSite origin hn uuid remotes = propertyList (hn ++" website using git-annex") - [ Git.cloned "joey" origin dir Nothing +annexWebSite :: Git.RepoUrl -> HostName -> AnnexUUID -> [(String, Git.RepoUrl)] -> Property HasInfo +annexWebSite origin hn uuid remotes = propertyList (hn ++" website using git-annex") $ props + & Git.cloned "joey" origin dir Nothing `onChange` setup - , alias hn - , postupdatehook `File.hasContent` + & alias hn + & postupdatehook `File.hasContent` [ "#!/bin/sh" , "exec git update-server-info" ] `onChange` (postupdatehook `File.mode` (combineModes (ownerWriteMode:readModes ++ executeModes))) - , setupapache - ] + & setupapache where dir = "/srv/web/" ++ hn postupdatehook = dir ".git/hooks/post-update" @@ -212,7 +210,7 @@ annexWebSite origin hn uuid remotes = propertyList (hn ++" website using git-ann , "git update-server-info" ] addremote (name, url) = "git remote add " ++ shellEscape name ++ " " ++ shellEscape url - setupapache = toProp $ Apache.siteEnabled hn $ apachecfg hn True $ + setupapache = apacheSite hn True [ " ServerAlias www."++hn , "" , " DocumentRoot /srv/web/"++hn @@ -230,6 +228,9 @@ annexWebSite origin hn uuid remotes = propertyList (hn ++" website using git-ann , " " ] +apacheSite :: HostName -> Bool -> Apache.ConfigFile -> RevertableProperty +apacheSite hn withssl middle = Apache.siteEnabled hn $ apachecfg hn withssl middle + apachecfg :: HostName -> Bool -> Apache.ConfigFile -> Apache.ConfigFile apachecfg hn withssl middle | withssl = vhost False ++ vhost True @@ -268,20 +269,19 @@ mainhttpscert True = , " SSLCertificateChainFile /etc/ssl/certs/startssl.pem" ] -gitAnnexDistributor :: Property -gitAnnexDistributor = combineProperties "git-annex distributor, including rsync server and signer" - [ Apt.installed ["rsync"] - , File.hasPrivContent "/etc/rsyncd.conf" (Context "git-annex distributor") +gitAnnexDistributor :: Property HasInfo +gitAnnexDistributor = combineProperties "git-annex distributor, including rsync server and signer" $ props + & Apt.installed ["rsync"] + & File.hasPrivContent "/etc/rsyncd.conf" (Context "git-annex distributor") `onChange` Service.restarted "rsync" - , File.hasPrivContent "/etc/rsyncd.secrets" (Context "git-annex distributor") + & File.hasPrivContent "/etc/rsyncd.secrets" (Context "git-annex distributor") `onChange` Service.restarted "rsync" - , "/etc/default/rsync" `File.containsLine` "RSYNC_ENABLE=true" + & "/etc/default/rsync" `File.containsLine` "RSYNC_ENABLE=true" `onChange` Service.running "rsync" - , endpoint "/srv/web/downloads.kitenet.net/git-annex/autobuild" - , endpoint "/srv/web/downloads.kitenet.net/git-annex/autobuild/x86_64-apple-mavericks" + & endpoint "/srv/web/downloads.kitenet.net/git-annex/autobuild" + & endpoint "/srv/web/downloads.kitenet.net/git-annex/autobuild/x86_64-apple-mavericks" -- git-annex distribution signing key - , Gpg.keyImported (Gpg.GpgKeyId "89C809CB") "joey" - ] + & Gpg.keyImported (Gpg.GpgKeyId "89C809CB") "joey" where endpoint d = combineProperties ("endpoint " ++ d) [ File.dirExists d @@ -289,50 +289,48 @@ gitAnnexDistributor = combineProperties "git-annex distributor, including rsync ] -- Twitter, you kill us. -twitRss :: Property -twitRss = combineProperties "twitter rss" - [ Git.cloned "joey" "git://git.kitenet.net/twitrss.git" dir Nothing - , check (not <$> doesFileExist (dir "twitRss")) $ - userScriptProperty "joey" - [ "cd " ++ dir - , "ghc --make twitRss" - ] - `requires` Apt.installed - [ "libghc-xml-dev" - , "libghc-feed-dev" - , "libghc-tagsoup-dev" - ] - , feed "http://twitter.com/search/realtime?q=git-annex" "git-annex-twitter" - , feed "http://twitter.com/search/realtime?q=olduse+OR+git-annex+OR+debhelper+OR+etckeeper+OR+ikiwiki+-ashley_ikiwiki" "twittergrep" - ] +twitRss :: Property HasInfo +twitRss = combineProperties "twitter rss" $ props + & Git.cloned "joey" "git://git.kitenet.net/twitrss.git" dir Nothing + & check (not <$> doesFileExist (dir "twitRss")) compiled + & feed "http://twitter.com/search/realtime?q=git-annex" "git-annex-twitter" + & feed "http://twitter.com/search/realtime?q=olduse+OR+git-annex+OR+debhelper+OR+etckeeper+OR+ikiwiki+-ashley_ikiwiki" "twittergrep" where dir = "/srv/web/tmp.kitenet.net/twitrss" crontime = "15 * * * *" feed url desc = Cron.job desc crontime "joey" dir $ "./twitRss " ++ shellEscape url ++ " > " ++ shellEscape ("../" ++ desc ++ ".rss") + compiled = userScriptProperty "joey" + [ "cd " ++ dir + , "ghc --make twitRss" + ] + `requires` Apt.installed + [ "libghc-xml-dev" + , "libghc-feed-dev" + , "libghc-tagsoup-dev" + ] -- Work around for expired ssl cert. -- (no longer expired, TODO remove this and change urls) -pumpRss :: Property +pumpRss :: Property NoInfo pumpRss = Cron.job "pump rss" "15 * * * *" "joey" "/srv/web/tmp.kitenet.net/" "wget https://pump2rss.com/feed/joeyh@identi.ca.atom -O pump.atom --no-check-certificate 2>/dev/null" -ircBouncer :: Property -ircBouncer = propertyList "IRC bouncer" - [ Apt.installed ["znc"] - , User.accountFor "znc" - , File.dirExists (takeDirectory conf) - , File.hasPrivContent conf anyContext - , File.ownerGroup conf "znc" "znc" - , Cron.job "znconboot" "@reboot" "znc" "~" "znc" +ircBouncer :: Property HasInfo +ircBouncer = propertyList "IRC bouncer" $ props + & Apt.installed ["znc"] + & User.accountFor "znc" + & File.dirExists (takeDirectory conf) + & File.hasPrivContent conf anyContext + & File.ownerGroup conf "znc" "znc" + & Cron.job "znconboot" "@reboot" "znc" "~" "znc" -- ensure running if it was not already - , trivial $ userScriptProperty "znc" ["znc || true"] + & trivial (userScriptProperty "znc" ["znc || true"]) `describe` "znc running" - ] where conf = "/home/znc/.znc/configs/znc.conf" -kiteShellBox :: Property +kiteShellBox :: Property NoInfo kiteShellBox = propertyList "kitenet.net shellinabox" [ Apt.installed ["shellinabox"] , File.hasContent "/etc/default/shellinabox" @@ -345,28 +343,34 @@ kiteShellBox = propertyList "kitenet.net shellinabox" , Service.running "shellinabox" ] -githubBackup :: Property -githubBackup = propertyList "github-backup box" - [ Apt.installed ["github-backup", "moreutils"] - , let f = "/home/joey/.github-keys" - in File.hasPrivContent f anyContext - `onChange` File.ownerGroup f "joey" "joey" - , Cron.niceJob "github-backup run" "30 4 * * *" "joey" - "/home/joey/lib/backup" $ intercalate "&&" $ - [ "mkdir -p github" - , "cd github" - , ". $HOME/.github-keys" - , "github-backup joeyh" - ] - , Cron.niceJob "gitriddance" "30 4 * * *" "joey" - "/home/joey/lib/backup" $ intercalate "&&" $ - [ "cd github" - , ". $HOME/.github-keys" - ] ++ map gitriddance githubMirrors - ] +githubBackup :: Property HasInfo +githubBackup = propertyList "github-backup box" $ props + & Apt.installed ["github-backup", "moreutils"] + & githubKeys + & Cron.niceJob "github-backup run" "30 4 * * *" "joey" + "/home/joey/lib/backup" backupcmd + & Cron.niceJob "gitriddance" "30 4 * * *" "joey" + "/home/joey/lib/backup" gitriddancecmd where + backupcmd = intercalate "&&" $ + [ "mkdir -p github" + , "cd github" + , ". $HOME/.github-keys" + , "github-backup joeyh" + ] + gitriddancecmd = intercalate "&&" $ + [ "cd github" + , ". $HOME/.github-keys" + ] ++ map gitriddance githubMirrors gitriddance (r, msg) = "(cd " ++ r ++ " && gitriddance " ++ shellEscape msg ++ ")" +githubKeys :: Property HasInfo +githubKeys = + let f = "/home/joey/.github-keys" + in File.hasPrivContent f anyContext + `onChange` File.ownerGroup f "joey" "joey" + + -- these repos are only mirrored on github, I don't want -- all the proprietary features githubMirrors :: [(String, String)] @@ -380,12 +384,12 @@ githubMirrors = where plzuseurl u = "please submit changes to " ++ u ++ " instead of using github pull requests" -rsyncNetBackup :: [Host] -> Property +rsyncNetBackup :: [Host] -> Property NoInfo rsyncNetBackup hosts = Cron.niceJob "rsync.net copied in daily" "30 5 * * *" "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" "joey" -backupsBackedupTo :: [Host] -> HostName -> FilePath -> Property +backupsBackedupTo :: [Host] -> HostName -> FilePath -> Property NoInfo backupsBackedupTo hosts desthost destdir = Cron.niceJob desc "1 1 * * 3" "joey" "/" cmd `requires` Ssh.knownHost hosts desthost "joey" @@ -393,7 +397,7 @@ backupsBackedupTo hosts desthost destdir = Cron.niceJob desc desc = "backups copied to " ++ desthost ++ " weekly" cmd = "rsync -az --delete /home/joey/lib/backup " ++ desthost ++ ":" ++ destdir -obnamRepos :: [String] -> Property +obnamRepos :: [String] -> Property NoInfo obnamRepos rs = propertyList ("obnam repos for " ++ unwords rs) (mkbase : map mkrepo rs) where @@ -403,20 +407,20 @@ obnamRepos rs = propertyList ("obnam repos for " ++ unwords rs) mkdir d = File.dirExists d `before` File.ownerGroup d "joey" "joey" -podcatcher :: Property +podcatcher :: Property NoInfo podcatcher = Cron.niceJob "podcatcher run hourly" "55 * * * *" "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 -kiteMailServer = propertyList "kitenet.net mail server" - [ Postfix.installed - , Apt.installed ["postfix-pcre"] - , Apt.serviceInstalledRunning "postgrey" +kiteMailServer :: Property HasInfo +kiteMailServer = propertyList "kitenet.net mail server" $ props + & Postfix.installed + & Apt.installed ["postfix-pcre"] + & Apt.serviceInstalledRunning "postgrey" - , Apt.serviceInstalledRunning "spamassassin" - , "/etc/default/spamassassin" `File.containsLines` + & Apt.serviceInstalledRunning "spamassassin" + & "/etc/default/spamassassin" `File.containsLines` [ "# Propellor deployed" , "ENABLED=1" , "OPTIONS=\"--create-prefs --max-children 5 --helper-home-dir\"" @@ -426,15 +430,15 @@ kiteMailServer = propertyList "kitenet.net mail server" `describe` "spamd enabled" `requires` Apt.serviceInstalledRunning "cron" - , Apt.serviceInstalledRunning "spamass-milter" + & Apt.serviceInstalledRunning "spamass-milter" -- Add -m to prevent modifying messages Subject or body. - , "/etc/default/spamass-milter" `File.containsLine` + & "/etc/default/spamass-milter" `File.containsLine` "OPTIONS=\"-m -u spamass-milter -i 127.0.0.1\"" `onChange` Service.restarted "spamass-milter" `describe` "spamass-milter configured" - , Apt.serviceInstalledRunning "amavisd-milter" - , "/etc/default/amavisd-milter" `File.containsLines` + & Apt.serviceInstalledRunning "amavisd-milter" + & "/etc/default/amavisd-milter" `File.containsLines` [ "# Propellor deployed" , "MILTERSOCKET=/var/spool/postfix/amavis/amavis.sock" , "MILTERSOCKETOWNER=\"postfix:postfix\"" @@ -442,12 +446,12 @@ kiteMailServer = propertyList "kitenet.net mail server" ] `onChange` Service.restarted "amavisd-milter" `describe` "amavisd-milter configured for postfix" - , Apt.serviceInstalledRunning "clamav-freshclam" + & Apt.serviceInstalledRunning "clamav-freshclam" - , dkimInstalled + & dkimInstalled - , Apt.installed ["maildrop"] - , "/etc/maildroprc" `File.hasContent` + & Apt.installed ["maildrop"] + & "/etc/maildroprc" `File.hasContent` [ "# Global maildrop filter file (deployed with propellor)" , "DEFAULT=\"$HOME/Maildir\"" , "MAILBOX=\"$DEFAULT/.\"" @@ -461,19 +465,19 @@ kiteMailServer = propertyList "kitenet.net mail server" ] `describe` "maildrop configured" - , "/etc/aliases" `File.hasPrivContentExposed` ctx + & "/etc/aliases" `File.hasPrivContentExposed` ctx `onChange` Postfix.newaliases - , hasJoeyCAChain - , hasPostfixCert ctx + & hasJoeyCAChain + & hasPostfixCert ctx - , "/etc/postfix/mydomain" `File.containsLines` + & "/etc/postfix/mydomain" `File.containsLines` [ "/.*\\.kitenet\\.net/\tOK" , "/ikiwiki\\.info/\tOK" , "/joeyh\\.name/\tOK" ] `onChange` Postfix.reloaded `describe` "postfix mydomain file configured" - , "/etc/postfix/obscure_client_relay.pcre" `File.hasContent` + & "/etc/postfix/obscure_client_relay.pcre" `File.hasContent` -- Remove received lines for mails relayed from trusted -- clients. These can be a privacy violation, or trigger -- spam filters. @@ -485,16 +489,16 @@ kiteMailServer = propertyList "kitenet.net mail server" ] `onChange` Postfix.reloaded `describe` "postfix obscure_client_relay file configured" - , Postfix.mappedFile "/etc/postfix/virtual" + & Postfix.mappedFile "/etc/postfix/virtual" (flip File.containsLines [ "# *@joeyh.name to joey" , "@joeyh.name\tjoey" ] ) `describe` "postfix virtual file configured" `onChange` Postfix.reloaded - , Postfix.mappedFile "/etc/postfix/relay_clientcerts" $ - flip File.hasPrivContentExposed ctx - , Postfix.mainCfFile `File.containsLines` + & Postfix.mappedFile "/etc/postfix/relay_clientcerts" + (flip File.hasPrivContentExposed ctx) + & Postfix.mainCfFile `File.containsLines` [ "myhostname = kitenet.net" , "mydomain = $myhostname" , "append_dot_mydomain = no" @@ -543,24 +547,24 @@ kiteMailServer = propertyList "kitenet.net mail server" `onChange` Postfix.reloaded `describe` "postfix configured" - , Apt.serviceInstalledRunning "dovecot-imapd" - , Apt.serviceInstalledRunning "dovecot-pop3d" - , "/etc/dovecot/conf.d/10-mail.conf" `File.containsLine` + & Apt.serviceInstalledRunning "dovecot-imapd" + & Apt.serviceInstalledRunning "dovecot-pop3d" + & "/etc/dovecot/conf.d/10-mail.conf" `File.containsLine` "mail_location = maildir:~/Maildir" `onChange` Service.reloaded "dovecot" `describe` "dovecot mail.conf" - , "/etc/dovecot/conf.d/10-auth.conf" `File.containsLine` + & "/etc/dovecot/conf.d/10-auth.conf" `File.containsLine` "!include auth-passwdfile.conf.ext" `onChange` Service.restarted "dovecot" `describe` "dovecot auth.conf" - , File.hasPrivContent dovecotusers ctx + & File.hasPrivContent dovecotusers ctx `onChange` (dovecotusers `File.mode` combineModes [ownerReadMode, groupReadMode]) - , File.ownerGroup dovecotusers "root" "dovecot" + & File.ownerGroup dovecotusers "root" "dovecot" - , Apt.installed ["mutt", "bsd-mailx", "alpine"] + & Apt.installed ["mutt", "bsd-mailx", "alpine"] - , pinescript `File.hasContent` + & pinescript `File.hasContent` [ "#!/bin/sh" , "# deployed with propellor" , "set -e" @@ -574,14 +578,13 @@ kiteMailServer = propertyList "kitenet.net mail server" `onChange` (pinescript `File.mode` combineModes (readModes ++ executeModes)) `describe` "pine wrapper script" - , "/etc/pine.conf" `File.hasContent` + & "/etc/pine.conf" `File.hasContent` [ "# deployed with propellor" , "inbox-path={localhost/novalidate-cert/NoRsh}inbox" ] `describe` "pine configured to use local imap server" - , Apt.serviceInstalledRunning "mailman" - ] + & Apt.serviceInstalledRunning "mailman" where ctx = Context "kitenet.net" pinescript = "/usr/local/bin/pine" @@ -589,7 +592,7 @@ kiteMailServer = propertyList "kitenet.net mail server" -- Configures postfix to relay outgoing mail to kitenet.net, with -- verification via tls cert. -postfixClientRelay :: Context -> Property +postfixClientRelay :: Context -> Property HasInfo postfixClientRelay ctx = Postfix.mainCfFile `File.containsLines` [ "relayhost = kitenet.net" , "smtp_tls_CAfile = /etc/ssl/certs/joeyca.pem" @@ -605,7 +608,7 @@ postfixClientRelay ctx = Postfix.mainCfFile `File.containsLines` `requires` hasPostfixCert ctx -- Configures postfix to have the dkim milter, and no other milters. -dkimMilter :: Property +dkimMilter :: Property HasInfo dkimMilter = Postfix.mainCfFile `File.containsLines` [ "smtpd_milters = inet:localhost:8891" , "non_smtpd_milters = inet:localhost:8891" @@ -618,22 +621,22 @@ dkimMilter = Postfix.mainCfFile `File.containsLines` -- This does not configure postfix to use the dkim milter, -- nor does it set up domainkey DNS. -dkimInstalled :: Property -dkimInstalled = propertyList "opendkim installed" - [ Apt.serviceInstalledRunning "opendkim" - , File.dirExists "/etc/mail" - , File.hasPrivContent "/etc/mail/dkim.key" (Context "kitenet.net") - , File.ownerGroup "/etc/mail/dkim.key" "opendkim" "opendkim" - , "/etc/default/opendkim" `File.containsLine` - "SOCKET=\"inet:8891@localhost\"" - , "/etc/opendkim.conf" `File.containsLines` - [ "KeyFile /etc/mail/dkim.key" - , "SubDomains yes" - , "Domain *" - , "Selector mail" - ] - ] - `onChange` Service.restarted "opendkim" +dkimInstalled :: Property HasInfo +dkimInstalled = go `onChange` Service.restarted "opendkim" + where + go = propertyList "opendkim installed" $ props + & Apt.serviceInstalledRunning "opendkim" + & File.dirExists "/etc/mail" + & File.hasPrivContent "/etc/mail/dkim.key" (Context "kitenet.net") + & File.ownerGroup "/etc/mail/dkim.key" "opendkim" "opendkim" + & "/etc/default/opendkim" `File.containsLine` + "SOCKET=\"inet:8891@localhost\"" + & "/etc/opendkim.conf" `File.containsLines` + [ "KeyFile /etc/mail/dkim.key" + , "SubDomains yes" + , "Domain *" + , "Selector mail" + ] -- This is the dkim public key, corresponding with /etc/mail/dkim.key -- This value can be included in a domain's additional records to make @@ -641,37 +644,36 @@ dkimInstalled = propertyList "opendkim installed" domainKey :: (BindDomain, Record) domainKey = (RelDomain "mail._domainkey", TXT "v=DKIM1; k=rsa; t=y; p=MIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQCc+/rfzNdt5DseBBmfB3C6sVM7FgVvf4h1FeCfyfwPpVcmPdW6M2I+NtJsbRkNbEICxiP6QY2UM0uoo9TmPqLgiCCG2vtuiG6XMsS0Y/gGwqKM7ntg/7vT1Go9vcquOFFuLa5PnzpVf8hB9+PMFdS4NPTvWL2c5xxshl/RJzICnQIDAQAB") -hasJoeyCAChain :: Property +hasJoeyCAChain :: Property HasInfo hasJoeyCAChain = "/etc/ssl/certs/joeyca.pem" `File.hasPrivContentExposed` Context "joeyca.pem" -hasPostfixCert :: Context -> Property +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 ] -kitenetHttps :: Property -kitenetHttps = propertyList "kitenet.net https certs" - [ File.hasPrivContent "/etc/ssl/certs/web.pem" ctx - , File.hasPrivContent "/etc/ssl/private/web.pem" ctx - , File.hasPrivContent "/etc/ssl/certs/startssl.pem" ctx - , toProp $ Apache.modEnabled "ssl" - ] +kitenetHttps :: Property HasInfo +kitenetHttps = propertyList "kitenet.net https certs" $ props + & File.hasPrivContent "/etc/ssl/certs/web.pem" ctx + & File.hasPrivContent "/etc/ssl/private/web.pem" ctx + & File.hasPrivContent "/etc/ssl/certs/startssl.pem" ctx + & Apache.modEnabled "ssl" where ctx = Context "kitenet.net" -- Legacy static web sites and redirections from kitenet.net to newer -- sites. -legacyWebSites :: Property -legacyWebSites = propertyList "legacy web sites" - [ Apt.serviceInstalledRunning "apache2" - , toProp $ Apache.modEnabled "rewrite" - , toProp $ Apache.modEnabled "cgi" - , toProp $ Apache.modEnabled "speling" - , userDirHtml - , kitenetHttps - , toProp $ Apache.siteEnabled "kitenet.net" $ apachecfg "kitenet.net" True +legacyWebSites :: Property HasInfo +legacyWebSites = propertyList "legacy web sites" $ props + & Apt.serviceInstalledRunning "apache2" + & Apache.modEnabled "rewrite" + & Apache.modEnabled "cgi" + & Apache.modEnabled "speling" + & userDirHtml + & kitenetHttps + & apacheSite "kitenet.net" True -- /var/www is empty [ "DocumentRoot /var/www" , "" @@ -758,8 +760,8 @@ legacyWebSites = propertyList "legacy web sites" , "rewriterule /~kyle/family/wiki/(.*).rss http://macleawiki.branchable.com/$1/index.rss [L]" , "rewriterule /~kyle/family/wiki(.*) http://macleawiki.branchable.com$1 [L]" ] - , alias "anna.kitenet.net" - , toProp $ Apache.siteEnabled "anna.kitenet.net" $ apachecfg "anna.kitenet.net" False + & alias "anna.kitenet.net" + & apacheSite "anna.kitenet.net" False [ "DocumentRoot /home/anna/html" , "" , " Options Indexes ExecCGI" @@ -767,9 +769,9 @@ legacyWebSites = propertyList "legacy web sites" , Apache.allowAll , "" ] - , alias "sows-ear.kitenet.net" - , alias "www.sows-ear.kitenet.net" - , toProp $ Apache.siteEnabled "sows-ear.kitenet.net" $ apachecfg "sows-ear.kitenet.net" False + & alias "sows-ear.kitenet.net" + & alias "www.sows-ear.kitenet.net" + & apacheSite "sows-ear.kitenet.net" False [ "ServerAlias www.sows-ear.kitenet.net" , "DocumentRoot /srv/web/sows-ear.kitenet.net" , "" @@ -778,9 +780,9 @@ legacyWebSites = propertyList "legacy web sites" , Apache.allowAll , "" ] - , alias "wortroot.kitenet.net" - , alias "www.wortroot.kitenet.net" - , toProp $ Apache.siteEnabled "wortroot.kitenet.net" $ apachecfg "wortroot.kitenet.net" False + & alias "wortroot.kitenet.net" + & alias "www.wortroot.kitenet.net" + & apacheSite "wortroot.kitenet.net" False [ "ServerAlias www.wortroot.kitenet.net" , "DocumentRoot /srv/web/wortroot.kitenet.net" , "" @@ -789,8 +791,8 @@ legacyWebSites = propertyList "legacy web sites" , Apache.allowAll , "" ] - , alias "creeksidepress.com" - , toProp $ Apache.siteEnabled "creeksidepress.com" $ apachecfg "creeksidepress.com" False + & alias "creeksidepress.com" + & apacheSite "creeksidepress.com" False [ "ServerAlias www.creeksidepress.com" , "DocumentRoot /srv/web/www.creeksidepress.com" , "" @@ -799,8 +801,8 @@ legacyWebSites = propertyList "legacy web sites" , Apache.allowAll , "" ] - , alias "joey.kitenet.net" - , toProp $ Apache.siteEnabled "joey.kitenet.net" $ apachecfg "joey.kitenet.net" False + & alias "joey.kitenet.net" + & apacheSite "joey.kitenet.net" False [ "DocumentRoot /var/www" , "" , " Options Indexes ExecCGI" @@ -820,12 +822,12 @@ legacyWebSites = propertyList "legacy web sites" , "# Redirect all to joeyh.name." , "rewriterule (.*) http://joeyh.name$1 [r]" ] - ] -userDirHtml :: Property +userDirHtml :: Property HasInfo userDirHtml = File.fileProperty "apache userdir is html" (map munge) conf `onChange` Apache.reloaded `requires` (toProp $ Apache.modEnabled "userdir") where munge = replace "public_html" "html" conf = "/etc/apache2/mods-available/userdir.conf" + diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs index 791b363b..9290ea1e 100644 --- a/src/Propellor/Property/Ssh.hs +++ b/src/Propellor/Property/Ssh.hs @@ -36,7 +36,7 @@ sshBool False = "no" sshdConfig :: FilePath sshdConfig = "/etc/ssh/sshd_config" -setSshdConfig :: String -> Bool -> Property +setSshdConfig :: String -> Bool -> Property NoInfo setSshdConfig setting allowed = combineProperties "sshd config" [ sshdConfig `File.lacksLine` (sshline $ not allowed) , sshdConfig `File.containsLine` (sshline allowed) @@ -46,10 +46,10 @@ setSshdConfig setting allowed = combineProperties "sshd config" where sshline v = setting ++ " " ++ sshBool v -permitRootLogin :: Bool -> Property +permitRootLogin :: Bool -> Property NoInfo permitRootLogin = setSshdConfig "PermitRootLogin" -passwordAuthentication :: Bool -> Property +passwordAuthentication :: Bool -> Property NoInfo passwordAuthentication = setSshdConfig "PasswordAuthentication" dotDir :: UserName -> IO FilePath @@ -67,13 +67,13 @@ hasAuthorizedKeys = go <=< dotFile "authorized_keys" where go f = not . null <$> catchDefaultIO "" (readFile f) -restarted :: Property +restarted :: Property NoInfo restarted = Service.restarted "ssh" -- | 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 +randomHostKeys :: Property NoInfo randomHostKeys = flagFile prop "/etc/ssh/.unique_host_keys" `onChange` restarted where @@ -90,7 +90,7 @@ randomHostKeys = flagFile prop "/etc/ssh/.unique_host_keys" -- The corresponding private keys come from the privdata. -- -- Any host keysthat are not in the list are removed from the host. -hostKeys :: IsContext c => c -> [(SshKeyType, PubKeyText)] -> Property +hostKeys :: IsContext c => c -> [(SshKeyType, PubKeyText)] -> Property HasInfo hostKeys ctx l = propertyList desc $ catMaybes $ map (\(t, pub) -> Just $ hostKey ctx t pub) l ++ [cleanup] where @@ -101,19 +101,20 @@ hostKeys ctx l = propertyList desc $ catMaybes $ removestale b = map (File.notPresent . flip keyFile b) staletypes cleanup | null staletypes || null l = Nothing - | otherwise = Just $ property ("any other ssh host keys removed " ++ typelist staletypes) $ - ensureProperty $ - combineProperties desc (removestale True ++ removestale False) - `onChange` restarted + | otherwise = Just $ toProp $ + property ("any other ssh host keys removed " ++ typelist staletypes) $ + ensureProperty $ + combineProperties desc (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 +hostKey :: IsContext c => c -> SshKeyType -> PubKeyText -> Property HasInfo hostKey context keytype pub = combineProperties desc [ pubKey keytype pub - , property desc $ install writeFile True pub + , toProp $ property desc $ install writeFile True pub , withPrivData (keysrc "" (SshPrivKey keytype "")) context $ \getkey -> property desc $ getkey $ install writeFileProtected False ] @@ -137,7 +138,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. -pubKey :: SshKeyType -> PubKeyText -> Property +pubKey :: SshKeyType -> PubKeyText -> Property HasInfo pubKey t k = pureInfoProperty ("ssh pubkey known") $ mempty { _sshPubKey = M.singleton t k } @@ -146,7 +147,7 @@ getPubKey = asks (_sshPubKey . hostInfo) -- | Sets up a user with a ssh private key and public key pair from the -- PrivData. -keyImported :: IsContext c => SshKeyType -> UserName -> c -> Property +keyImported :: IsContext c => SshKeyType -> UserName -> c -> Property HasInfo keyImported keytype user context = combineProperties desc [ installkey (SshPubKey keytype user) (install writeFile ".pub") , installkey (SshPrivKey keytype user) (install writeFileProtected "") @@ -179,7 +180,7 @@ fromKeyType SshEd25519 = "ed25519" -- | Puts some host's ssh public key(s), as set using 'pubKey', -- into the known_hosts file for a user. -knownHost :: [Host] -> HostName -> UserName -> Property +knownHost :: [Host] -> HostName -> UserName -> Property NoInfo knownHost hosts hn user = property desc $ go =<< fromHost hosts hn getPubKey where @@ -199,7 +200,7 @@ knownHost hosts hn user = property desc $ -- | Makes a user have authorized_keys from the PrivData -- -- This removes any other lines from the file. -authorizedKeys :: IsContext c => UserName -> c -> Property +authorizedKeys :: IsContext c => UserName -> c -> Property HasInfo authorizedKeys user context = withPrivData (SshAuthorizedKeys user) context $ \get -> property (user ++ " has authorized_keys") $ get $ \v -> do f <- liftIO $ dotFile "authorized_keys" user @@ -213,7 +214,7 @@ authorizedKeys user context = withPrivData (SshAuthorizedKeys user) context $ \g -- | Ensures that a user's authorized_keys contains a line. -- Any other lines in the file are preserved as-is. -authorizedKey :: UserName -> String -> Property +authorizedKey :: UserName -> String -> Property NoInfo authorizedKey user l = property (user ++ " has autorized_keys line " ++ l) $ do f <- liftIO $ dotFile "authorized_keys" user ensureProperty $ @@ -226,7 +227,7 @@ authorizedKey user l = property (user ++ " has autorized_keys line " ++ l) $ do -- -- Revert to prevent it listening on a particular port. listenPort :: Int -> RevertableProperty -listenPort port = RevertableProperty enable disable +listenPort port = enable disable where portline = "Port " ++ show port enable = sshdConfig `File.containsLine` portline diff --git a/src/Propellor/Property/Sudo.hs b/src/Propellor/Property/Sudo.hs index 3651891d..c183a8a3 100644 --- a/src/Propellor/Property/Sudo.hs +++ b/src/Propellor/Property/Sudo.hs @@ -9,7 +9,7 @@ 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 :: UserName -> Property +enabledFor :: UserName -> Property NoInfo enabledFor user = property desc go `requires` Apt.installed ["sudo"] where go = do diff --git a/src/Propellor/Property/Systemd.hs b/src/Propellor/Property/Systemd.hs index 259bb222..07cf81ee 100644 --- a/src/Propellor/Property/Systemd.hs +++ b/src/Propellor/Property/Systemd.hs @@ -45,32 +45,32 @@ instance PropAccum Container where getProperties (Container _ _ h) = hostProperties h -- | Starts a systemd service. -started :: ServiceName -> Property +started :: ServiceName -> Property NoInfo started n = trivial $ cmdProperty "systemctl" ["start", n] `describe` ("service " ++ n ++ " started") -- | Stops a systemd service. -stopped :: ServiceName -> Property +stopped :: ServiceName -> Property NoInfo stopped n = trivial $ cmdProperty "systemctl" ["stop", n] `describe` ("service " ++ n ++ " stopped") -- | Enables a systemd service. -enabled :: ServiceName -> Property +enabled :: ServiceName -> Property NoInfo enabled n = trivial $ cmdProperty "systemctl" ["enable", n] `describe` ("service " ++ n ++ " enabled") -- | Disables a systemd service. -disabled :: ServiceName -> Property +disabled :: ServiceName -> Property NoInfo disabled n = trivial $ cmdProperty "systemctl" ["disable", n] `describe` ("service " ++ n ++ " disabled") -- | Restarts a systemd service. -restarted :: ServiceName -> Property +restarted :: ServiceName -> Property NoInfo restarted n = trivial $ cmdProperty "systemctl" ["restart", n] `describe` ("service " ++ n ++ " restarted") -- | Enables persistent storage of the journal. -persistentJournal :: Property +persistentJournal :: Property NoInfo persistentJournal = check (not <$> doesDirectoryExist dir) $ combineProperties "persistent systemd journal" [ cmdProperty "install" ["-d", "-g", "systemd-journal", dir] @@ -89,7 +89,7 @@ type Option = String -- This assumes that there is only one [Header] per file, which is -- currently the case. 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 +configured :: FilePath -> Option -> String -> Property NoInfo configured cfgfile option value = combineProperties desc [ File.fileProperty desc (mapMaybe removeother) cfgfile , File.containsLine cfgfile line @@ -103,13 +103,13 @@ configured cfgfile option value = combineProperties desc | otherwise = Just l -- | Configures journald, restarting it so the changes take effect. -journaldConfigured :: Option -> String -> Property +journaldConfigured :: Option -> String -> Property NoInfo journaldConfigured option value = configured "/etc/systemd/journald.conf" option value `onChange` restarted "systemd-journald" -- | Causes systemd to reload its configuration files. -daemonReloaded :: Property +daemonReloaded :: Property NoInfo daemonReloaded = trivial $ cmdProperty "systemctl" ["daemon-reload"] -- | Defines a container with a given machine name. @@ -143,17 +143,12 @@ container name mkchroot = Container name c h -- and deletes the chroot and all its contents. nspawned :: Container -> RevertableProperty nspawned c@(Container name (Chroot.Chroot loc system builderconf _) h) = - RevertableProperty setup teardown + p `describe` ("nspawned " ++ name) where - setup = combineProperties ("nspawned " ++ name) $ - map toProp steps ++ [containerprovisioned] - teardown = combineProperties ("not nspawned " ++ name) $ - map (toProp . revert) (reverse steps) - steps = - [ enterScript c - , chrootprovisioned - , nspawnService c (_chrootCfg $ _chrootinfo $ hostInfo h) - ] + p = enterScript c + `before` chrootprovisioned + `before` nspawnService c (_chrootCfg $ _chrootinfo $ hostInfo h) + `before` containerprovisioned -- Chroot provisioning is run in systemd-only mode, -- which sets up the chroot and ensures systemd and dbus are @@ -163,15 +158,17 @@ nspawned c@(Container name (Chroot.Chroot loc system builderconf _) h) = -- Use nsenter to enter container and and run propellor to -- finish provisioning. - containerprovisioned = Chroot.propellChroot chroot - (enterContainerProcess c) False + containerprovisioned = + Chroot.propellChroot chroot (enterContainerProcess c) False + + doNothing chroot = Chroot.Chroot loc system builderconf h -- | Sets up the service file for the container, and then starts -- it running. nspawnService :: Container -> ChrootCfg -> RevertableProperty -nspawnService (Container name _ _) cfg = RevertableProperty setup teardown +nspawnService (Container name _ _) cfg = setup teardown where service = nspawnServiceName name servicefile = "/etc/systemd/system/multi-user.target.wants" service @@ -215,7 +212,7 @@ 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 -enterScript c@(Container name _ _) = RevertableProperty setup teardown +enterScript c@(Container name _ _) = setup teardown where setup = combineProperties ("generated " ++ enterScriptFile c) [ scriptfile `File.hasContent` diff --git a/src/Propellor/Property/Systemd/Core.hs b/src/Propellor/Property/Systemd/Core.hs index 441717e1..b27a8e38 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 +installed :: Property NoInfo installed = Apt.installed ["systemd", "dbus"] diff --git a/src/Propellor/Property/Tor.hs b/src/Propellor/Property/Tor.hs index 9c63980c..9a0fe477 100644 --- a/src/Propellor/Property/Tor.hs +++ b/src/Propellor/Property/Tor.hs @@ -10,7 +10,7 @@ import System.Posix.Files type HiddenServiceName = String -isBridge :: Property +isBridge :: Property NoInfo isBridge = setup `requires` Apt.installed ["tor"] `describe` "tor bridge" where @@ -21,7 +21,7 @@ isBridge = setup `requires` Apt.installed ["tor"] , "Exitpolicy reject *:*" ] `onChange` restarted -hiddenServiceAvailable :: HiddenServiceName -> Int -> Property +hiddenServiceAvailable :: HiddenServiceName -> Int -> Property NoInfo hiddenServiceAvailable hn port = hiddenServiceHostName prop where prop = mainConfig `File.containsLines` @@ -30,13 +30,13 @@ hiddenServiceAvailable hn port = hiddenServiceHostName prop ] `describe` "hidden service available" `onChange` Service.reloaded "tor" - hiddenServiceHostName p = adjustProperty p $ \satisfy -> do + hiddenServiceHostName p = adjustPropertySatisfy p $ \satisfy -> do r <- satisfy h <- liftIO $ readFile (varLib hn "hostname") warningMessage $ unwords ["hidden service hostname:", h] return r -hiddenService :: HiddenServiceName -> Int -> Property +hiddenService :: HiddenServiceName -> Int -> Property NoInfo hiddenService hn port = mainConfig `File.containsLines` [ unwords ["HiddenServiceDir", varLib hn] , unwords ["HiddenServicePort", show port, "127.0.0.1:" ++ show port] @@ -44,7 +44,7 @@ hiddenService hn port = mainConfig `File.containsLines` `describe` unwords ["hidden service available:", hn, show port] `onChange` restarted -hiddenServiceData :: IsContext c => HiddenServiceName -> c -> Property +hiddenServiceData :: IsContext c => HiddenServiceName -> c -> Property HasInfo hiddenServiceData hn context = combineProperties desc [ installonion "hostname" , installonion "private_key" @@ -66,7 +66,7 @@ hiddenServiceData hn context = combineProperties desc ] ) -restarted :: Property +restarted :: Property NoInfo restarted = Service.restarted "tor" mainConfig :: FilePath diff --git a/src/Propellor/Property/User.hs b/src/Propellor/Property/User.hs index f79ede63..9e115290 100644 --- a/src/Propellor/Property/User.hs +++ b/src/Propellor/Property/User.hs @@ -6,7 +6,7 @@ import Propellor data Eep = YesReallyDeleteHome -accountFor :: UserName -> Property +accountFor :: UserName -> Property NoInfo accountFor user = check (isNothing <$> catchMaybeIO (homedir user)) $ cmdProperty "adduser" [ "--disabled-password" , "--gecos", "" @@ -15,7 +15,7 @@ accountFor user = check (isNothing <$> catchMaybeIO (homedir user)) $ cmdPropert `describe` ("account for " ++ user) -- | Removes user home directory!! Use with caution. -nuked :: UserName -> Eep -> Property +nuked :: UserName -> Eep -> Property NoInfo nuked user _ = check (isJust <$> catchMaybeIO (homedir user)) $ cmdProperty "userdel" [ "-r" , user @@ -24,13 +24,13 @@ nuked user _ = check (isJust <$> catchMaybeIO (homedir user)) $ cmdProperty "use -- | Only ensures that the user has some password set. It may or may -- not be a password from the PrivData. -hasSomePassword :: UserName -> Property +hasSomePassword :: UserName -> Property HasInfo 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 => UserName -> c -> Property +hasSomePassword' :: IsContext c => UserName -> c -> Property HasInfo hasSomePassword' user context = check ((/= HasPassword) <$> getPasswordStatus user) $ hasPassword' user context @@ -40,10 +40,10 @@ 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 :: UserName -> Property +hasPassword :: UserName -> Property HasInfo hasPassword user = hasPassword' user hostContext -hasPassword' :: IsContext c => UserName -> c -> Property +hasPassword' :: IsContext c => UserName -> c -> Property HasInfo hasPassword' user context = go `requires` shadowConfig True where go = withSomePrivData srcs context $ @@ -66,7 +66,7 @@ setPassword getpassword = getpassword $ go hPutStrLn h $ user ++ ":" ++ v hClose h -lockedPassword :: UserName -> Property +lockedPassword :: UserName -> Property NoInfo lockedPassword user = check (not <$> isLockedPassword user) $ cmdProperty "passwd" [ "--lock" , user @@ -90,7 +90,7 @@ isLockedPassword user = (== LockedPassword) <$> getPasswordStatus user homedir :: UserName -> IO FilePath homedir user = homeDirectory <$> getUserEntryForName user -hasGroup :: UserName -> GroupName -> Property +hasGroup :: UserName -> GroupName -> Property NoInfo hasGroup user group' = check test $ cmdProperty "adduser" [ user , group' @@ -100,7 +100,7 @@ hasGroup user group' = check test $ cmdProperty "adduser" test = not . elem group' . words <$> readProcess "groups" [user] -- | Controls whether shadow passwords are enabled or not. -shadowConfig :: Bool -> Property +shadowConfig :: Bool -> Property NoInfo shadowConfig True = check (not <$> shadowExists) $ cmdProperty "shadowconfig" ["on"] `describe` "shadow passwords enabled" diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs index 85ed93aa..7149f538 100644 --- a/src/Propellor/Types.hs +++ b/src/Propellor/Types.hs @@ -10,29 +10,29 @@ module Propellor.Types ( Host(..) , Desc - , Property(..) + , Property , HasInfo , NoInfo - , hasInfo , CInfo , infoProperty , simpleProperty - , propertySatisfy , adjustPropertySatisfy , propertyInfo , propertyChildren , RevertableProperty(..) , () + , IsProp(..) , Combines(..) + , CombinedType , before , combineWith - , IsProp(..) , Info(..) , Propellor(..) , EndAction(..) , module Propellor.Types.OS , module Propellor.Types.Dns , module Propellor.Types.Result + , propertySatisfy , ignoreInfo ) where @@ -75,6 +75,17 @@ newtype Propellor p = Propellor { runWithHost :: RWST Host [EndAction] () IO p } , MonadCatchIO ) +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) @@ -88,14 +99,12 @@ 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 -hasInfo :: Property i -> Bool -hasInfo (IProperty {}) = True -hasInfo _ = False - --- | Type level calculation of the combintion of HasInfo and/or 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 @@ -128,15 +137,18 @@ toSProperty p@(SProperty {}) = p 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 + instance Show (Property NoInfo) where show p = "property " ++ show (propertyDesc p) instance Show (Property HasInfo) where show p = "property " ++ show (propertyDesc p) -propertySatisfy :: Property i -> Propellor Result -propertySatisfy (IProperty _ a _ _) = a -propertySatisfy (SProperty _ a _) = a - -- | Changes the action that is performed to satisfy a property. adjustPropertySatisfy :: Property i -> (Propellor Result -> Propellor Result) -> Property i adjustPropertySatisfy (IProperty d s i cs) f = IProperty d (f s) i cs @@ -165,6 +177,7 @@ class IsProp p where describe :: p -> Desc -> p propertyDesc :: p -> Desc toProp :: p -> Property HasInfo + toSimpleProp :: p -> Maybe (Property NoInfo) -- | Gets the info of the property, combined with all info -- of all children properties. getInfoRecursive :: p -> Info @@ -173,12 +186,14 @@ instance IsProp (Property HasInfo) where describe (IProperty _ a i cs) d = IProperty d a i cs propertyDesc (IProperty d _ _ _) = d toProp = id + toSimpleProp _ = Nothing getInfoRecursive (IProperty _ _ i cs) = i <> mconcat (map getInfoRecursive cs) instance IsProp (Property NoInfo) where describe (SProperty _ a cs) d = SProperty d a cs propertyDesc (SProperty d _ _) = d toProp = toIProperty + toSimpleProp = Just getInfoRecursive _ = mempty instance IsProp RevertableProperty where @@ -187,10 +202,11 @@ instance IsProp RevertableProperty where RevertableProperty (describe p1 d) (describe p2 ("not " ++ d)) propertyDesc (RevertableProperty p1 _) = propertyDesc p1 toProp (RevertableProperty p1 _) = p1 + toSimpleProp = toSimpleProp . toProp -- | Return the Info of the currently active side. getInfoRecursive (RevertableProperty p1 _p2) = getInfoRecursive p1 --- Type level calculation of the type that results from combining two types +-- | Type level calculation of the type that results from combining two types -- with `requires`. type family CombinedType x y type instance CombinedType (Property x) (Property y) = Property (CInfo x y) @@ -224,18 +240,18 @@ combineWith f x y = adjustPropertySatisfy (x `requires` y) $ \_ -> instance Combines (Property HasInfo) (Property HasInfo) where requires (IProperty d1 a1 i1 cs1) y@(IProperty _d2 a2 _i2 _cs2) = - IProperty d1 (a2 `andThen` a1) i1 (y : cs1) + IProperty d1 (a2 <> a1) i1 (y : cs1) instance Combines (Property HasInfo) (Property NoInfo) where requires (IProperty d1 a1 i1 cs1) y@(SProperty _d2 a2 _cs2) = - IProperty d1 (a2 `andThen` a1) i1 (toIProperty y : cs1) + IProperty d1 (a2 <> a1) i1 (toIProperty y : cs1) instance Combines (Property NoInfo) (Property HasInfo) where requires x y = requires y x instance Combines (Property NoInfo) (Property NoInfo) where requires (SProperty d1 a1 cs1) y@(SProperty _d2 a2 _cs2) = - SProperty d1 (a2 `andThen` a1) (y : cs1) + SProperty d1 (a2 <> a1) (y : cs1) instance Combines RevertableProperty (Property HasInfo) where requires (RevertableProperty p1 p2) y = @@ -252,13 +268,6 @@ instance Combines RevertableProperty RevertableProperty where -- when reverting, run actions in reverse order (y2 `requires` x2) -andThen :: Propellor Result -> Propellor Result -> Propellor Result -x `andThen` y = do - r <- x - case r of - FailedChange -> return FailedChange - _ -> y - -- | Information about a host. data Info = Info { _os :: Val System -- cgit v1.2.3