summaryrefslogtreecommitdiff
path: root/src/Propellor/Property
diff options
context:
space:
mode:
Diffstat (limited to 'src/Propellor/Property')
-rw-r--r--src/Propellor/Property/Apache.hs14
-rw-r--r--src/Propellor/Property/Apt.hs52
-rw-r--r--src/Propellor/Property/Chroot.hs18
-rw-r--r--src/Propellor/Property/Cmd.hs8
-rw-r--r--src/Propellor/Property/Cron.hs6
-rw-r--r--src/Propellor/Property/Debootstrap.hs15
-rw-r--r--src/Propellor/Property/Dns.hs29
-rw-r--r--src/Propellor/Property/DnsSec.hs14
-rw-r--r--src/Propellor/Property/Docker.hs64
-rw-r--r--src/Propellor/Property/File.hs30
-rw-r--r--src/Propellor/Property/Firewall.hs4
-rw-r--r--src/Propellor/Property/Git.hs8
-rw-r--r--src/Propellor/Property/Gpg.hs4
-rw-r--r--src/Propellor/Property/Group.hs2
-rw-r--r--src/Propellor/Property/Grub.hs6
-rw-r--r--src/Propellor/Property/HostingProvider/CloudAtCost.hs2
-rw-r--r--src/Propellor/Property/HostingProvider/DigitalOcean.hs2
-rw-r--r--src/Propellor/Property/HostingProvider/Linode.hs2
-rw-r--r--src/Propellor/Property/Hostname.hs6
-rw-r--r--src/Propellor/Property/Journald.hs16
-rw-r--r--src/Propellor/Property/List.hs63
-rw-r--r--src/Propellor/Property/Network.hs10
-rw-r--r--src/Propellor/Property/Nginx.hs10
-rw-r--r--src/Propellor/Property/OS.hs16
-rw-r--r--src/Propellor/Property/Obnam.hs14
-rw-r--r--src/Propellor/Property/OpenId.hs4
-rw-r--r--src/Propellor/Property/Postfix.hs22
-rw-r--r--src/Propellor/Property/Prosody.hs10
-rw-r--r--src/Propellor/Property/Reboot.hs4
-rw-r--r--src/Propellor/Property/Scheduled.hs8
-rw-r--r--src/Propellor/Property/Service.hs8
-rw-r--r--src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs66
-rw-r--r--src/Propellor/Property/SiteSpecific/GitHome.hs2
-rw-r--r--src/Propellor/Property/SiteSpecific/JoeySites.hs450
-rw-r--r--src/Propellor/Property/Ssh.hs37
-rw-r--r--src/Propellor/Property/Sudo.hs2
-rw-r--r--src/Propellor/Property/Systemd.hs43
-rw-r--r--src/Propellor/Property/Systemd/Core.hs2
-rw-r--r--src/Propellor/Property/Tor.hs12
-rw-r--r--src/Propellor/Property/User.hs18
40 files changed, 596 insertions, 507 deletions
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 </etc/apt/sources.list.d/>
-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 <https://github.com/docker/docker/issues/5663>
-- 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 </etc/hosts> 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 </etc/resolv.conf> 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
-- | </etc/network/interfaces> 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
-- | </etc/resolv.conf> 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) $
-- | </root/.ssh/authorized_keys> 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 </old-os>
-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
-- </etc/aliases>.
-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 ++ "/"
, " <Directory " ++ datadir ++ "/>"
, " Options Indexes FollowSymlinks"
@@ -63,23 +64,25 @@ oldUseNetServer hosts = propertyList ("olduse.net server")
, Apache.allowAll
, " </Directory>"
]
- ]
- 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/"
, " <Directory /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
, " </Directory>"
]
+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"
, "<Directory /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"
, "<Directory /home/anna/html/>"
, " Options Indexes ExecCGI"
@@ -767,9 +769,9 @@ legacyWebSites = propertyList "legacy web sites"
, Apache.allowAll
, "</Directory>"
]
- , 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"
, "<Directory /srv/web/sows-ear.kitenet.net>"
@@ -778,9 +780,9 @@ legacyWebSites = propertyList "legacy web sites"
, Apache.allowAll
, "</Directory>"
]
- , 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"
, "<Directory /srv/web/wortroot.kitenet.net>"
@@ -789,8 +791,8 @@ legacyWebSites = propertyList "legacy web sites"
, Apache.allowAll
, "</Directory>"
]
- , 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"
, "<Directory /srv/web/www.creeksidepress.com>"
@@ -799,8 +801,8 @@ legacyWebSites = propertyList "legacy web sites"
, Apache.allowAll
, "</Directory>"
]
- , 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"
, "<Directory /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 <Password> or a <CryptPassword> 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"