summaryrefslogtreecommitdiff
path: root/src/Propellor/Property
diff options
context:
space:
mode:
Diffstat (limited to 'src/Propellor/Property')
-rw-r--r--src/Propellor/Property/Aiccu.hs16
-rw-r--r--src/Propellor/Property/Apache.hs54
-rw-r--r--src/Propellor/Property/Apt.hs126
-rw-r--r--src/Propellor/Property/Chroot.hs99
-rw-r--r--src/Propellor/Property/Cmd.hs10
-rw-r--r--src/Propellor/Property/Concurrent.hs14
-rw-r--r--src/Propellor/Property/Conductor.hs57
-rw-r--r--src/Propellor/Property/ConfFile.hs8
-rw-r--r--src/Propellor/Property/Cron.hs25
-rw-r--r--src/Propellor/Property/DebianMirror.hs20
-rw-r--r--src/Propellor/Property/Debootstrap.hs42
-rw-r--r--src/Propellor/Property/DiskImage.hs92
-rw-r--r--src/Propellor/Property/Dns.hs45
-rw-r--r--src/Propellor/Property/DnsSec.hs12
-rw-r--r--src/Propellor/Property/Docker.hs161
-rw-r--r--src/Propellor/Property/Fail2Ban.hs8
-rw-r--r--src/Propellor/Property/File.hs49
-rw-r--r--src/Propellor/Property/Firewall.hs4
-rw-r--r--src/Propellor/Property/FreeBSD/Pkg.hs17
-rw-r--r--src/Propellor/Property/FreeBSD/Poudriere.hs21
-rw-r--r--src/Propellor/Property/Git.hs23
-rw-r--r--src/Propellor/Property/Gpg.hs5
-rw-r--r--src/Propellor/Property/Group.hs2
-rw-r--r--src/Propellor/Property/Grub.hs39
-rw-r--r--src/Propellor/Property/HostingProvider/CloudAtCost.hs33
-rw-r--r--src/Propellor/Property/HostingProvider/DigitalOcean.hs11
-rw-r--r--src/Propellor/Property/HostingProvider/Linode.hs9
-rw-r--r--src/Propellor/Property/Hostname.hs21
-rw-r--r--src/Propellor/Property/Journald.hs16
-rw-r--r--src/Propellor/Property/Kerberos.hs29
-rw-r--r--src/Propellor/Property/LetsEncrypt.hs7
-rw-r--r--src/Propellor/Property/LightDM.hs6
-rw-r--r--src/Propellor/Property/List.hs111
-rw-r--r--src/Propellor/Property/Locale.hs38
-rw-r--r--src/Propellor/Property/Logcheck.hs4
-rw-r--r--src/Propellor/Property/Mount.hs17
-rw-r--r--src/Propellor/Property/Munin.hs8
-rw-r--r--src/Propellor/Property/Network.hs38
-rw-r--r--src/Propellor/Property/Nginx.hs14
-rw-r--r--src/Propellor/Property/OS.hs51
-rw-r--r--src/Propellor/Property/Obnam.hs17
-rw-r--r--src/Propellor/Property/OpenId.hs6
-rw-r--r--src/Propellor/Property/Parted.hs17
-rw-r--r--src/Propellor/Property/Partition.hs12
-rw-r--r--src/Propellor/Property/Postfix.hs37
-rw-r--r--src/Propellor/Property/PropellorRepo.hs2
-rw-r--r--src/Propellor/Property/Prosody.hs12
-rw-r--r--src/Propellor/Property/Reboot.hs6
-rw-r--r--src/Propellor/Property/Rsync.hs6
-rw-r--r--src/Propellor/Property/Scheduled.hs13
-rw-r--r--src/Propellor/Property/Service.hs10
-rw-r--r--src/Propellor/Property/SiteSpecific/Branchable.hs2
-rw-r--r--src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs103
-rw-r--r--src/Propellor/Property/SiteSpecific/GitHome.hs11
-rw-r--r--src/Propellor/Property/SiteSpecific/IABak.hs13
-rw-r--r--src/Propellor/Property/SiteSpecific/JoeySites.hs133
-rw-r--r--src/Propellor/Property/Ssh.hs193
-rw-r--r--src/Propellor/Property/Sudo.hs9
-rw-r--r--src/Propellor/Property/Systemd.hs163
-rw-r--r--src/Propellor/Property/Systemd/Core.hs2
-rw-r--r--src/Propellor/Property/Tor.hs44
-rw-r--r--src/Propellor/Property/Unbound.hs8
-rw-r--r--src/Propellor/Property/User.hs63
-rw-r--r--src/Propellor/Property/Uwsgi.hs12
-rw-r--r--src/Propellor/Property/ZFS/Properties.hs12
65 files changed, 1186 insertions, 1082 deletions
diff --git a/src/Propellor/Property/Aiccu.hs b/src/Propellor/Property/Aiccu.hs
index 47841a7b..1b28759c 100644
--- a/src/Propellor/Property/Aiccu.hs
+++ b/src/Propellor/Property/Aiccu.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE TypeFamilies #-}
+
-- | Maintainer: Jelmer Vernooij <jelmer@samba.org>
module Propellor.Property.Aiccu (
@@ -14,10 +16,10 @@ import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.Service as Service
import qualified Propellor.Property.File as File
-installed :: Property NoInfo
+installed :: Property DebianLike
installed = Apt.installed ["aiccu"]
-restarted :: Property NoInfo
+restarted :: Property DebianLike
restarted = Service.restarted "aiccu"
confPath :: FilePath
@@ -41,12 +43,12 @@ config u t p =
-- | Configures an ipv6 tunnel using sixxs.net, with the given TunneId
-- and sixx.net UserName.
-hasConfig :: TunnelId -> UserName -> Property HasInfo
-hasConfig t u = prop `onChange` restarted
+hasConfig :: TunnelId -> UserName -> Property (HasInfo + DebianLike)
+hasConfig t u = prop `onChange` restarted
where
+ prop :: Property (HasInfo + UnixLike)
prop = withSomePrivData [(Password (u++"/"++t)), (Password u)] (Context "aiccu") $
- property "aiccu configured" . writeConfig
- writeConfig :: (((PrivDataField, PrivData) -> Propellor Result) -> Propellor Result) -> Propellor Result
- writeConfig getpassword = getpassword $ ensureProperty . go
+ property' "aiccu configured" . writeConfig
+ writeConfig getpassword w = getpassword $ ensureProperty w . go
go (Password u', p) = confPath `File.hasContentProtected` config u' t p
go (f, _) = error $ "Unexpected type of privdata: " ++ show f
diff --git a/src/Propellor/Property/Apache.hs b/src/Propellor/Property/Apache.hs
index e107cb9f..f321143f 100644
--- a/src/Propellor/Property/Apache.hs
+++ b/src/Propellor/Property/Apache.hs
@@ -6,50 +6,50 @@ import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.Service as Service
import qualified Propellor.Property.LetsEncrypt as LetsEncrypt
-installed :: Property NoInfo
+installed :: Property DebianLike
installed = Apt.installed ["apache2"]
-restarted :: Property NoInfo
+restarted :: Property DebianLike
restarted = Service.restarted "apache2"
-reloaded :: Property NoInfo
+reloaded :: Property DebianLike
reloaded = Service.reloaded "apache2"
type ConfigLine = String
type ConfigFile = [ConfigLine]
-siteEnabled :: Domain -> ConfigFile -> RevertableProperty NoInfo
+siteEnabled :: Domain -> ConfigFile -> RevertableProperty DebianLike DebianLike
siteEnabled domain cf = siteEnabled' domain cf <!> siteDisabled domain
-siteEnabled' :: Domain -> ConfigFile -> Property NoInfo
-siteEnabled' domain cf = combineProperties ("apache site enabled " ++ domain)
- [ siteAvailable domain cf
+siteEnabled' :: Domain -> ConfigFile -> Property DebianLike
+siteEnabled' domain cf = combineProperties ("apache site enabled " ++ domain) $ props
+ & siteAvailable domain cf
`requires` installed
`onChange` reloaded
- , check (not <$> isenabled)
+ & check (not <$> isenabled)
(cmdProperty "a2ensite" ["--quiet", domain])
`requires` installed
`onChange` reloaded
- ]
where
isenabled = boolSystem "a2query" [Param "-q", Param "-s", Param domain]
-siteDisabled :: Domain -> Property NoInfo
+siteDisabled :: Domain -> Property DebianLike
siteDisabled domain = combineProperties
("apache site disabled " ++ domain)
- (map File.notPresent (siteCfg domain))
+ (toProps $ map File.notPresent (siteCfg domain))
`onChange` (cmdProperty "a2dissite" ["--quiet", domain] `assume` MadeChange)
`requires` installed
`onChange` reloaded
-siteAvailable :: Domain -> ConfigFile -> Property NoInfo
+siteAvailable :: Domain -> ConfigFile -> Property DebianLike
siteAvailable domain cf = combineProperties ("apache site available " ++ domain) $
- map (`File.hasContent` (comment:cf)) (siteCfg domain)
+ toProps $ map tightenTargets $
+ map (`File.hasContent` (comment:cf)) (siteCfg domain)
where
comment = "# deployed with propellor, do not modify"
-modEnabled :: String -> RevertableProperty NoInfo
+modEnabled :: String -> RevertableProperty DebianLike DebianLike
modEnabled modname = enable <!> disable
where
enable = check (not <$> isenabled)
@@ -68,7 +68,7 @@ modEnabled modname = enable <!> disable
--
-- Note that ports are also specified inside a site's config file,
-- so that also needs to be changed.
-listenPorts :: [Port] -> Property NoInfo
+listenPorts :: [Port] -> Property DebianLike
listenPorts ps = "/etc/apache2/ports.conf" `File.hasContent` map portline ps
`onChange` restarted
where
@@ -89,7 +89,7 @@ siteCfg domain =
--
-- This was off by default in apache 2.2.22. Newver versions enable
-- it by default. This property uses the filename used by the old version.
-multiSSL :: Property NoInfo
+multiSSL :: Property DebianLike
multiSSL = check (doesDirectoryExist "/etc/apache2/conf.d") $
"/etc/apache2/conf.d/ssl" `File.hasContent`
[ "NameVirtualHost *:443"
@@ -129,11 +129,11 @@ type WebRoot = FilePath
-- | A basic virtual host, publishing a directory, and logging to
-- the combined apache log file. Not https capable.
-virtualHost :: Domain -> Port -> WebRoot -> RevertableProperty NoInfo
+virtualHost :: Domain -> Port -> WebRoot -> RevertableProperty DebianLike DebianLike
virtualHost domain port docroot = virtualHost' domain port docroot []
-- | Like `virtualHost` but with additional config lines added.
-virtualHost' :: Domain -> Port -> WebRoot -> [ConfigLine] -> RevertableProperty NoInfo
+virtualHost' :: Domain -> Port -> WebRoot -> [ConfigLine] -> RevertableProperty DebianLike DebianLike
virtualHost' domain port docroot addedcfg = siteEnabled domain $
[ "<VirtualHost *:" ++ fromPort port ++ ">"
, "ServerName " ++ domain ++ ":" ++ fromPort port
@@ -159,11 +159,11 @@ virtualHost' domain port docroot addedcfg = siteEnabled domain $
--
-- Note that reverting this property does not remove the certificate from
-- letsencrypt's cert store.
-httpsVirtualHost :: Domain -> WebRoot -> LetsEncrypt.AgreeTOS -> RevertableProperty NoInfo
+httpsVirtualHost :: Domain -> WebRoot -> LetsEncrypt.AgreeTOS -> RevertableProperty DebianLike DebianLike
httpsVirtualHost domain docroot letos = httpsVirtualHost' domain docroot letos []
-- | Like `httpsVirtualHost` but with additional config lines added.
-httpsVirtualHost' :: Domain -> WebRoot -> LetsEncrypt.AgreeTOS -> [ConfigLine] -> RevertableProperty NoInfo
+httpsVirtualHost' :: Domain -> WebRoot -> LetsEncrypt.AgreeTOS -> [ConfigLine] -> RevertableProperty DebianLike DebianLike
httpsVirtualHost' domain docroot letos addedcfg = setup <!> teardown
where
setup = setuphttp
@@ -185,13 +185,13 @@ httpsVirtualHost' domain docroot letos addedcfg = setup <!> teardown
, "RewriteRule ^/(.*) https://" ++ domain ++ "/$1 [L,R,NE]"
]
setuphttps = LetsEncrypt.letsEncrypt letos domain docroot
- `onChange` combineProperties (domain ++ " ssl cert installed")
- [ File.dirExists (takeDirectory cf)
- , File.hasContent cf sslvhost
- `onChange` reloaded
- -- always reload since the cert has changed
- , reloaded
- ]
+ `onChange` postsetuphttps
+ postsetuphttps = combineProperties (domain ++ " ssl cert installed") $ props
+ & File.dirExists (takeDirectory cf)
+ & File.hasContent cf sslvhost
+ `onChange` reloaded
+ -- always reload since the cert has changed
+ & reloaded
where
cf = sslconffile "letsencrypt"
sslvhost = vhost (Port 443)
diff --git a/src/Propellor/Property/Apt.hs b/src/Propellor/Property/Apt.hs
index b9182baf..5771750d 100644
--- a/src/Propellor/Property/Apt.hs
+++ b/src/Propellor/Property/Apt.hs
@@ -75,42 +75,41 @@ securityUpdates suite
in [l, srcLine l]
| otherwise = []
--- | Makes sources.list have a standard content using the mirror CDN,
+-- | Makes sources.list have a standard content using the Debian mirror CDN,
-- with the Debian suite configured by the os.
--
-- Since the CDN is sometimes unreliable, also adds backup lines using
-- kernel.org.
-stdSourcesList :: Property NoInfo
-stdSourcesList = withOS "standard sources.list" $ \o ->
- case o of
- (Just (System (Debian suite) _)) ->
- ensureProperty $ stdSourcesListFor suite
- _ -> error "os is not declared to be Debian"
-
-stdSourcesListFor :: DebianSuite -> Property NoInfo
+stdSourcesList :: Property Debian
+stdSourcesList = withOS "standard sources.list" $ \w o -> case o of
+ (Just (System (Debian suite) _)) ->
+ ensureProperty w $ stdSourcesListFor suite
+ _ -> unsupportedOS'
+
+stdSourcesListFor :: DebianSuite -> Property Debian
stdSourcesListFor suite = stdSourcesList' suite []
-- | Adds additional sources.list generators.
--
-- Note that if a Property needs to enable an apt source, it's better
-- to do so via a separate file in </etc/apt/sources.list.d/>
-stdSourcesList' :: DebianSuite -> [SourcesGenerator] -> Property NoInfo
-stdSourcesList' suite more = setSourcesList
+stdSourcesList' :: DebianSuite -> [SourcesGenerator] -> Property Debian
+stdSourcesList' suite more = tightenTargets $ setSourcesList
(concatMap (\gen -> gen suite) generators)
`describe` ("standard sources.list for " ++ show suite)
where
generators = [debCdn, kernelOrg, securityUpdates] ++ more
-setSourcesList :: [Line] -> Property NoInfo
+setSourcesList :: [Line] -> Property DebianLike
setSourcesList ls = sourcesList `File.hasContent` ls `onChange` update
-setSourcesListD :: [Line] -> FilePath -> Property NoInfo
+setSourcesListD :: [Line] -> FilePath -> Property DebianLike
setSourcesListD ls basename = f `File.hasContent` ls `onChange` update
where
f = "/etc/apt/sources.list.d/" ++ basename ++ ".list"
-runApt :: [String] -> UncheckedProperty NoInfo
-runApt ps = cmdPropertyEnv "apt-get" ps noninteractiveEnv
+runApt :: [String] -> UncheckedProperty DebianLike
+runApt ps = tightenTargets $ cmdPropertyEnv "apt-get" ps noninteractiveEnv
noninteractiveEnv :: [(String, String)]
noninteractiveEnv =
@@ -118,68 +117,67 @@ noninteractiveEnv =
, ("APT_LISTCHANGES_FRONTEND", "none")
]
-update :: Property NoInfo
-update = combineProperties ("apt update")
- [ pendingConfigured
- , runApt ["update"]
+update :: Property DebianLike
+update = combineProperties ("apt update") $ props
+ & pendingConfigured
+ & runApt ["update"]
`assume` MadeChange
- ]
-- | Have apt upgrade packages, adding new packages and removing old as
-- necessary.
-upgrade :: Property NoInfo
+upgrade :: Property DebianLike
upgrade = upgrade' "dist-upgrade"
-upgrade' :: String -> Property NoInfo
-upgrade' p = combineProperties ("apt " ++ p)
- [ pendingConfigured
- , runApt ["-y", p]
+upgrade' :: String -> Property DebianLike
+upgrade' p = combineProperties ("apt " ++ p) $ props
+ & pendingConfigured
+ & runApt ["-y", p]
`assume` MadeChange
- ]
-- | Have apt upgrade packages, but never add new packages or remove
-- old packages. Not suitable for upgrading acrocess major versions
-- of the distribution.
-safeUpgrade :: Property NoInfo
+safeUpgrade :: Property DebianLike
safeUpgrade = upgrade' "upgrade"
-- | Have dpkg try to configure any packages that are not fully configured.
-pendingConfigured :: Property NoInfo
-pendingConfigured = cmdPropertyEnv "dpkg" ["--configure", "--pending"] noninteractiveEnv
- `assume` MadeChange
- `describe` "dpkg configured pending"
+pendingConfigured :: Property DebianLike
+pendingConfigured = tightenTargets $
+ cmdPropertyEnv "dpkg" ["--configure", "--pending"] noninteractiveEnv
+ `assume` MadeChange
+ `describe` "dpkg configured pending"
type Package = String
-installed :: [Package] -> Property NoInfo
+installed :: [Package] -> Property DebianLike
installed = installed' ["-y"]
-installed' :: [String] -> [Package] -> Property NoInfo
+installed' :: [String] -> [Package] -> Property DebianLike
installed' params ps = robustly $ check (isInstallable ps) go
`describe` unwords ("apt installed":ps)
where
go = runApt (params ++ ["install"] ++ ps)
-installedBackport :: [Package] -> Property NoInfo
-installedBackport ps = withOS desc $ \o -> case o of
+installedBackport :: [Package] -> Property Debian
+installedBackport ps = withOS desc $ \w o -> case o of
(Just (System (Debian suite) _)) -> case backportSuite suite of
- Nothing -> unsupportedOS
- Just bs -> ensureProperty $
+ Nothing -> unsupportedOS'
+ Just bs -> ensureProperty w $
runApt (["install", "-t", bs, "-y"] ++ ps)
`changesFile` dpkgStatus
- _ -> unsupportedOS
+ _ -> unsupportedOS'
where
desc = unwords ("apt installed backport":ps)
-- | Minimal install of package, without recommends.
-installedMin :: [Package] -> Property NoInfo
+installedMin :: [Package] -> Property DebianLike
installedMin = installed' ["--no-install-recommends", "-y"]
-removed :: [Package] -> Property NoInfo
+removed :: [Package] -> Property DebianLike
removed ps = check (or <$> isInstalled' ps) (runApt (["-y", "remove"] ++ ps))
`describe` unwords ("apt removed":ps)
-buildDep :: [Package] -> Property NoInfo
+buildDep :: [Package] -> Property DebianLike
buildDep ps = robustly $ go
`changesFile` dpkgStatus
`describe` unwords ("apt build-dep":ps)
@@ -189,7 +187,7 @@ buildDep ps = robustly $ go
-- | Installs the build deps for the source package unpacked
-- in the specifed directory, with a dummy package also
-- installed so that autoRemove won't remove them.
-buildDepIn :: FilePath -> Property NoInfo
+buildDepIn :: FilePath -> Property DebianLike
buildDepIn dir = cmdPropertyEnv "sh" ["-c", cmd] noninteractiveEnv
`changesFile` dpkgStatus
`requires` installedMin ["devscripts", "equivs"]
@@ -198,14 +196,8 @@ buildDepIn dir = cmdPropertyEnv "sh" ["-c", cmd] noninteractiveEnv
-- | Package installation may fail becuse the archive has changed.
-- Run an update in that case and retry.
-robustly :: (Combines (Property i) (Property NoInfo)) => Property i -> Property i
-robustly p = adjustPropertySatisfy p $ \satisfy -> do
- r <- satisfy
- if r == FailedChange
- -- Safe to use ignoreInfo because we're re-running
- -- the same property.
- then ensureProperty $ ignoreInfo $ p `requires` update
- else return r
+robustly :: Property DebianLike -> Property DebianLike
+robustly p = p `fallback` (update `before` p)
isInstallable :: [Package] -> IO Bool
isInstallable ps = do
@@ -230,13 +222,13 @@ isInstalled' ps = (mapMaybe parse . lines) <$> policy
environ <- addEntry "LANG" "C" <$> getEnvironment
readProcessEnv "apt-cache" ("policy":ps) (Just environ)
-autoRemove :: Property NoInfo
+autoRemove :: Property DebianLike
autoRemove = runApt ["-y", "autoremove"]
`changesFile` dpkgStatus
`describe` "apt autoremove"
-- | Enables unattended upgrades. Revert to disable.
-unattendedUpgrades :: RevertableProperty NoInfo
+unattendedUpgrades :: RevertableProperty DebianLike DebianLike
unattendedUpgrades = enable <!> disable
where
enable = setup True
@@ -255,11 +247,12 @@ unattendedUpgrades = enable <!> disable
| enabled = "true"
| otherwise = "false"
- configure = withOS "unattended upgrades configured" $ \o ->
+ configure :: Property DebianLike
+ configure = withOS "unattended upgrades configured" $ \w o ->
case o of
-- the package defaults to only upgrading stable
(Just (System (Debian suite) _))
- | not (isStable suite) -> ensureProperty $
+ | not (isStable suite) -> ensureProperty w $
"/etc/apt/apt.conf.d/50unattended-upgrades"
`File.containsLine`
("Unattended-Upgrade::Origins-Pattern { \"o=Debian,a="++showSuite suite++"\"; };")
@@ -271,10 +264,13 @@ type DebconfTemplateValue = String
-- | Preseeds debconf values and reconfigures the package so it takes
-- effect.
-reConfigure :: Package -> [(DebconfTemplate, DebconfTemplateType, DebconfTemplateValue)] -> Property NoInfo
-reConfigure package vals = reconfigure `requires` setselections
- `describe` ("reconfigure " ++ package)
+reConfigure :: Package -> [(DebconfTemplate, DebconfTemplateType, DebconfTemplateValue)] -> Property DebianLike
+reConfigure package vals = tightenTargets $
+ reconfigure
+ `requires` setselections
+ `describe` ("reconfigure " ++ package)
where
+ setselections :: Property DebianLike
setselections = property "preseed" $
if null vals
then noChange
@@ -291,7 +287,7 @@ reConfigure package vals = reconfigure `requires` setselections
--
-- Assumes that there is a 1:1 mapping between service names and apt
-- package names.
-serviceInstalledRunning :: Package -> Property NoInfo
+serviceInstalledRunning :: Package -> Property DebianLike
serviceInstalledRunning svc = Service.running svc `requires` installed [svc]
data AptKey = AptKey
@@ -299,10 +295,10 @@ data AptKey = AptKey
, pubkey :: String
}
-trustsKey :: AptKey -> RevertableProperty NoInfo
+trustsKey :: AptKey -> RevertableProperty DebianLike DebianLike
trustsKey k = trustsKey' k <!> untrustKey k
-trustsKey' :: AptKey -> Property NoInfo
+trustsKey' :: AptKey -> Property DebianLike
trustsKey' k = check (not <$> doesFileExist f) $ property desc $ makeChange $ do
withHandle StdinHandle createProcessSuccess
(proc "gpg" ["--no-default-keyring", "--keyring", f, "--import", "-"]) $ \h -> do
@@ -313,21 +309,21 @@ trustsKey' k = check (not <$> doesFileExist f) $ property desc $ makeChange $ do
desc = "apt trusts key " ++ keyname k
f = aptKeyFile k
-untrustKey :: AptKey -> Property NoInfo
-untrustKey = File.notPresent . aptKeyFile
+untrustKey :: AptKey -> Property DebianLike
+untrustKey = tightenTargets . File.notPresent . aptKeyFile
aptKeyFile :: AptKey -> FilePath
aptKeyFile k = "/etc/apt/trusted.gpg.d" </> keyname k ++ ".gpg"
-- | Cleans apt's cache of downloaded packages to avoid using up disk
-- space.
-cacheCleaned :: Property NoInfo
-cacheCleaned = cmdProperty "apt-get" ["clean"]
+cacheCleaned :: Property DebianLike
+cacheCleaned = tightenTargets $ cmdProperty "apt-get" ["clean"]
`assume` NoChange
`describe` "apt cache cleaned"
-- | Add a foreign architecture to dpkg and apt.
-hasForeignArch :: String -> Property NoInfo
+hasForeignArch :: String -> Property DebianLike
hasForeignArch arch = check notAdded (add `before` update)
`describe` ("dpkg has foreign architecture " ++ arch)
where
diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index 378836e8..09047ce5 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/src/Propellor/Property/Chroot.hs
@@ -19,9 +19,11 @@ module Propellor.Property.Chroot (
) where
import Propellor.Base
+import Propellor.Container
import Propellor.Types.CmdLine
import Propellor.Types.Chroot
import Propellor.Types.Info
+import Propellor.Types.Core
import Propellor.Property.Chroot.Util
import qualified Propellor.Property.Debootstrap as Debootstrap
import qualified Propellor.Property.Systemd.Core as Systemd
@@ -40,24 +42,24 @@ import System.Console.Concurrent
data Chroot where
Chroot :: ChrootBootstrapper b => FilePath -> b -> Host -> Chroot
+instance IsContainer Chroot where
+ containerProperties (Chroot _ _ h) = containerProperties h
+ containerInfo (Chroot _ _ h) = containerInfo h
+ setContainerProperties (Chroot loc b h) ps = Chroot loc b (setContainerProperties h ps)
+
chrootSystem :: Chroot -> Maybe System
-chrootSystem (Chroot _ _ h) = fromInfoVal (getInfo (hostInfo h))
+chrootSystem = fromInfoVal . fromInfo . containerInfo
instance Show Chroot where
show c@(Chroot loc _ _) = "Chroot " ++ loc ++ " " ++ show (chrootSystem c)
-instance PropAccum Chroot where
- (Chroot l c h) `addProp` p = Chroot l c (h & p)
- (Chroot l c h) `addPropFront` p = Chroot l c (h `addPropFront` p)
- getProperties (Chroot _ _ h) = hostProperties h
-
-- | Class of things that can do initial bootstrapping of an operating
-- System in a chroot.
class ChrootBootstrapper b where
-- | Do initial bootstrapping of an operating system in a chroot.
-- If the operating System is not supported, return
-- Left error message.
- buildchroot :: b -> Maybe System -> FilePath -> Either String (Property HasInfo)
+ buildchroot :: b -> Maybe System -> FilePath -> Either String (Property Linux)
-- | Use this to bootstrap a chroot by extracting a tarball.
--
@@ -68,14 +70,14 @@ class ChrootBootstrapper b where
data ChrootTarball = ChrootTarball FilePath
instance ChrootBootstrapper ChrootTarball where
- buildchroot (ChrootTarball tb) _ loc = Right $ extractTarball loc tb
-
-extractTarball :: FilePath -> FilePath -> Property HasInfo
-extractTarball target src = toProp .
- check (unpopulated target) $
- cmdProperty "tar" params
- `assume` MadeChange
- `requires` File.dirExists target
+ buildchroot (ChrootTarball tb) _ loc = Right $
+ tightenTargets $ extractTarball loc tb
+
+extractTarball :: FilePath -> FilePath -> Property UnixLike
+extractTarball target src = check (unpopulated target) $
+ cmdProperty "tar" params
+ `assume` MadeChange
+ `requires` File.dirExists target
where
params =
[ "-C"
@@ -92,28 +94,27 @@ instance ChrootBootstrapper Debootstrapped where
(Just s@(System (Debian _) _)) -> Right $ debootstrap s
(Just s@(System (Buntish _) _)) -> Right $ debootstrap s
(Just (System (FreeBSD _) _)) -> Left "FreeBSD not supported by debootstrap."
- Nothing -> Left "Cannot debootstrap; `os` property not specified"
+ Nothing -> Left "Cannot debootstrap; OS not specified"
where
debootstrap s = Debootstrap.built loc s cf
-- | Defines a Chroot at the given location, built with debootstrap.
--
-- Properties can be added to configure the Chroot. At a minimum,
--- add the `os` property to specify the operating system to bootstrap.
+-- add a property such as `osDebian` to specify the operating system
+-- to bootstrap.
--
--- > debootstrapped Debootstrap.BuildD "/srv/chroot/ghc-dev"
--- > & os (System (Debian Unstable) "amd64")
+-- > debootstrapped Debootstrap.BuildD "/srv/chroot/ghc-dev" $ props
+-- > & osDebian Unstable "amd64"
-- > & Apt.installed ["ghc", "haskell-platform"]
-- > & ...
-debootstrapped :: Debootstrap.DebootstrapConfig -> FilePath -> Chroot
+debootstrapped :: Debootstrap.DebootstrapConfig -> FilePath -> Props metatypes -> Chroot
debootstrapped conf = bootstrapped (Debootstrapped conf)
-- | Defines a Chroot at the given location, bootstrapped with the
-- specified ChrootBootstrapper.
-bootstrapped :: ChrootBootstrapper b => b -> FilePath -> Chroot
-bootstrapped bootstrapper location = Chroot location bootstrapper h
- where
- h = Host location [] mempty
+bootstrapped :: ChrootBootstrapper b => b -> FilePath -> Props metatypes -> Chroot
+bootstrapped bootstrapper location ps = Chroot location bootstrapper (host location ps)
-- | Ensures that the chroot exists and is provisioned according to its
-- properties.
@@ -121,43 +122,44 @@ bootstrapped bootstrapper location = Chroot location bootstrapper h
-- Reverting this property removes the chroot. Anything mounted inside it
-- is first unmounted. Note that it does not ensure that any processes
-- that might be running inside the chroot are stopped.
-provisioned :: Chroot -> RevertableProperty HasInfo
+provisioned :: Chroot -> RevertableProperty (HasInfo + Linux) Linux
provisioned c = provisioned' (propagateChrootInfo c) c False
-provisioned' :: (Property HasInfo -> Property HasInfo) -> Chroot -> Bool -> RevertableProperty HasInfo
+provisioned'
+ :: (Property Linux -> Property (HasInfo + Linux))
+ -> Chroot
+ -> Bool
+ -> RevertableProperty (HasInfo + Linux) Linux
provisioned' propigator c@(Chroot loc bootstrapper _) systemdonly =
- (propigator $ propertyList (chrootDesc c "exists") [setup])
+ (propigator $ setup `describe` chrootDesc c "exists")
<!>
- (propertyList (chrootDesc c "removed") [teardown])
+ (teardown `describe` chrootDesc c "removed")
where
+ setup :: Property Linux
setup = propellChroot c (inChrootProcess (not systemdonly) c) systemdonly
- `requires` toProp built
+ `requires` built
built = case buildchroot bootstrapper (chrootSystem c) loc of
Right p -> p
Left e -> cantbuild e
- cantbuild e = infoProperty (chrootDesc c "built") (error e) mempty []
+ cantbuild e = property (chrootDesc c "built") (error e)
+ teardown :: Property Linux
teardown = check (not <$> unpopulated loc) $
property ("removed " ++ loc) $
makeChange (removeChroot loc)
-propagateChrootInfo :: (IsProp (Property i)) => Chroot -> Property i -> Property HasInfo
-propagateChrootInfo c@(Chroot location _ _) p = propagateContainer location c p'
- where
- p' = infoProperty
- (propertyDesc p)
- (propertySatisfy p)
- (propertyInfo p <> chrootInfo c)
- (propertyChildren p)
+propagateChrootInfo :: Chroot -> Property Linux -> Property (HasInfo + Linux)
+propagateChrootInfo c@(Chroot location _ _) p = propagateContainer location c $
+ p `setInfoProperty` chrootInfo c
chrootInfo :: Chroot -> Info
chrootInfo (Chroot loc _ h) = mempty `addInfo`
mempty { _chroots = M.singleton loc h }
-- | Propellor is run inside the chroot to provision it.
-propellChroot :: Chroot -> ([String] -> IO (CreateProcess, IO ())) -> Bool -> Property NoInfo
+propellChroot :: Chroot -> ([String] -> IO (CreateProcess, IO ())) -> Bool -> Property UnixLike
propellChroot c@(Chroot loc _ _) mkproc systemdonly = property (chrootDesc c "provisioned") $ do
let d = localdir </> shimdir c
let me = localdir </> "propellor"
@@ -205,7 +207,7 @@ chain :: [Host] -> CmdLine -> IO ()
chain hostlist (ChrootChain hn loc systemdonly onconsole) =
case findHostNoAlias hostlist hn of
Nothing -> errorMessage ("cannot find host " ++ hn)
- Just parenthost -> case M.lookup loc (_chroots $ getInfo $ hostInfo parenthost) of
+ Just parenthost -> case M.lookup loc (_chroots $ fromInfo $ hostInfo parenthost) of
Nothing -> errorMessage ("cannot find chroot " ++ loc ++ " on host " ++ hn)
Just h -> go h
where
@@ -213,11 +215,10 @@ chain hostlist (ChrootChain hn loc systemdonly onconsole) =
changeWorkingDirectory localdir
when onconsole forceConsole
onlyProcess (provisioningLock loc) $ do
- r <- runPropellor (setInChroot h) $ ensureProperties $
+ r <- runPropellor (setInChroot h) $ ensureChildProperties $
if systemdonly
- then [Systemd.installed]
- else map ignoreInfo $
- hostProperties h
+ then [toChildProperty Systemd.installed]
+ else hostProperties h
flushConcurrentOutput
putStrLn $ "\n" ++ show r
chain _ _ = errorMessage "bad chain command"
@@ -255,15 +256,17 @@ chrootDesc (Chroot loc _ _) desc = "chroot " ++ loc ++ " " ++ desc
-- from being started, which is often something you want to prevent when
-- building a chroot.
--
--- This is accomplished by installing a </usr/sbin/policy-rc.d> script
--- that does not let any daemons be started by packages that use
+-- On Debian, this is accomplished by installing a </usr/sbin/policy-rc.d>
+-- script that does not let any daemons be started by packages that use
-- invoke-rc.d. Reverting the property removes the script.
-noServices :: RevertableProperty NoInfo
+--
+-- This property has no effect on non-Debian systems.
+noServices :: RevertableProperty UnixLike UnixLike
noServices = setup <!> teardown
where
f = "/usr/sbin/policy-rc.d"
script = [ "#!/bin/sh", "exit 101" ]
- setup = combineProperties "no services started"
+ setup = combineProperties "no services started" $ toProps
[ File.hasContent f script
, File.mode f (combineModes (readModes ++ executeModes))
]
diff --git a/src/Propellor/Property/Cmd.hs b/src/Propellor/Property/Cmd.hs
index 6da2e643..6b84acb5 100644
--- a/src/Propellor/Property/Cmd.hs
+++ b/src/Propellor/Property/Cmd.hs
@@ -58,10 +58,10 @@ import Utility.Process (createProcess, CreateProcess, waitForProcess)
-- | A property that can be satisfied by running a command.
--
-- The command must exit 0 on success.
-cmdProperty :: String -> [String] -> UncheckedProperty NoInfo
+cmdProperty :: String -> [String] -> UncheckedProperty UnixLike
cmdProperty cmd params = cmdProperty' cmd params id
-cmdProperty' :: String -> [String] -> (CreateProcess -> CreateProcess) -> UncheckedProperty NoInfo
+cmdProperty' :: String -> [String] -> (CreateProcess -> CreateProcess) -> UncheckedProperty UnixLike
cmdProperty' cmd params mkprocess = unchecked $ property desc $ liftIO $
cmdResult <$> boolSystem' cmd (map Param params) mkprocess
where
@@ -74,7 +74,7 @@ cmdResult True = NoChange
-- | A property that can be satisfied by running a command,
-- with added environment variables in addition to the standard
-- environment.
-cmdPropertyEnv :: String -> [String] -> [(String, String)] -> UncheckedProperty NoInfo
+cmdPropertyEnv :: String -> [String] -> [(String, String)] -> UncheckedProperty UnixLike
cmdPropertyEnv cmd params env = unchecked $ property desc $ liftIO $ do
env' <- addEntries env <$> getEnvironment
cmdResult <$> boolSystemEnv cmd (map Param params) (Just env')
@@ -85,14 +85,14 @@ cmdPropertyEnv cmd params env = unchecked $ property desc $ liftIO $ do
type Script = [String]
-- | A property that can be satisfied by running a script.
-scriptProperty :: Script -> UncheckedProperty NoInfo
+scriptProperty :: Script -> UncheckedProperty UnixLike
scriptProperty script = cmdProperty "sh" ["-c", shellcmd]
where
shellcmd = intercalate " ; " ("set -e" : script)
-- | A property that can satisfied by running a script
-- as user (cd'd to their home directory).
-userScriptProperty :: User -> Script -> UncheckedProperty NoInfo
+userScriptProperty :: User -> Script -> UncheckedProperty UnixLike
userScriptProperty (User user) script = cmdProperty "su" ["--shell", "/bin/sh", "-c", shellcmd, user]
where
shellcmd = intercalate " ; " ("set -e" : "cd" : script)
diff --git a/src/Propellor/Property/Concurrent.hs b/src/Propellor/Property/Concurrent.hs
index 74afecc4..e69dc17d 100644
--- a/src/Propellor/Property/Concurrent.hs
+++ b/src/Propellor/Property/Concurrent.hs
@@ -37,6 +37,8 @@ module Propellor.Property.Concurrent (
) where
import Propellor.Base
+import Propellor.Types.Core
+import Propellor.Types.MetaTypes
import Control.Concurrent
import qualified Control.Concurrent.Async as A
@@ -77,8 +79,8 @@ concurrently p1 p2 = (combineWith go go p1 p2)
--
-- The above example will run foo and bar concurrently, and once either of
-- those 2 properties finishes, will start running baz.
-concurrentList :: IO Int -> Desc -> PropList -> Property HasInfo
-concurrentList getn d (PropList ps) = infoProperty d go mempty ps
+concurrentList :: SingI metatypes => IO Int -> Desc -> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes)
+concurrentList getn d (Props ps) = property d go `addChildren` ps
where
go = do
n <- liftIO getn
@@ -97,15 +99,11 @@ concurrentList getn d (PropList ps) = infoProperty d go mempty ps
(p:rest) -> return (rest, Just p)
case v of
Nothing -> return r
- -- This use of propertySatisfy does not lose any
- -- Info asociated with the property, because
- -- concurrentList sets all the properties as
- -- children, and so propigates their info.
Just p -> do
hn <- asks hostName
r' <- actionMessageOn hn
- (propertyDesc p)
- (propertySatisfy p)
+ (getDesc p)
+ (getSatisfy p)
worker q (r <> r')
-- | Run an action with the number of capabiities increased as necessary to
diff --git a/src/Propellor/Property/Conductor.hs b/src/Propellor/Property/Conductor.hs
index 0d275b91..8aa18d20 100644
--- a/src/Propellor/Property/Conductor.hs
+++ b/src/Propellor/Property/Conductor.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE FlexibleInstances, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE FlexibleInstances, DeriveDataTypeable, GeneralizedNewtypeDeriving, TypeFamilies #-}
-- | This module adds conductors to propellor. A conductor is a Host that
-- is responsible for running propellor on other hosts
@@ -73,7 +73,8 @@ module Propellor.Property.Conductor (
Conductable(..),
) where
-import Propellor.Base hiding (os)
+import Propellor.Base
+import Propellor.Container
import Propellor.Spin (spin')
import Propellor.PrivData.Paths
import Propellor.Types.Info
@@ -82,21 +83,22 @@ import qualified Propellor.Property.Ssh as Ssh
import qualified Data.Set as S
-- | Class of things that can be conducted.
+--
+-- There are instances for single hosts, and for lists of hosts.
+-- With a list, each listed host will be conducted in turn. Failure to conduct
+-- one host does not prevent conducting subsequent hosts in the list, but
+-- will be propagated as an overall failure of the property.
class Conductable c where
- conducts :: c -> RevertableProperty HasInfo
+ conducts :: c -> RevertableProperty (HasInfo + UnixLike) (HasInfo + UnixLike)
instance Conductable Host where
- -- | Conduct the specified host.
conducts h = conductorFor h <!> notConductorFor h
--- | Each host in the list will be conducted in turn. Failure to conduct
--- one host does not prevent conducting subsequent hosts in the list, but
--- will be propagated as an overall failure of the property.
instance Conductable [Host] where
conducts hs =
- propertyList desc (map (toProp . conducts) hs)
+ propertyList desc (toProps $ map (setupRevertableProperty . conducts) hs)
<!>
- propertyList desc (map (toProp . revert . conducts) hs)
+ propertyList desc (toProps $ map (undoRevertableProperty . conducts) hs)
where
desc = cdesc $ unwords $ map hostName hs
@@ -126,7 +128,7 @@ mkOrchestra = fromJust . go S.empty
where
go seen h
| S.member (hostName h) seen = Nothing -- break loop
- | otherwise = Just $ case getInfo (hostInfo h) of
+ | otherwise = Just $ case fromInfo (hostInfo h) of
ConductorFor [] -> Conducted h
ConductorFor l ->
let seen' = S.insert (hostName h) seen
@@ -214,14 +216,15 @@ orchestrate :: [Host] -> [Host]
orchestrate hs = map go hs
where
go h
- | isOrchestrated (getInfo (hostInfo h)) = h
+ | isOrchestrated (fromInfo (hostInfo h)) = h
| otherwise = foldl orchestrate' (removeold h) (map (deloop h) os)
os = extractOrchestras hs
removeold h = foldl removeold' h (oldconductorsof h)
- removeold' h oldconductor = h & revert (conductedBy oldconductor)
+ removeold' h oldconductor = setContainerProps h $ containerProps h
+ ! conductedBy oldconductor
- oldconductors = zip hs (map (getInfo . hostInfo) hs)
+ oldconductors = zip hs (map (fromInfo . hostInfo) hs)
oldconductorsof h = flip mapMaybe oldconductors $
\(oldconductor, NotConductorFor l) ->
if any (sameHost h) l
@@ -232,7 +235,9 @@ orchestrate' :: Host -> Orchestra -> Host
orchestrate' h (Conducted _) = h
orchestrate' h (Conductor c l)
| sameHost h c = cont $ addConductorPrivData h (concatMap allHosts l)
- | any (sameHost h) (map topHost l) = cont $ h & conductedBy c
+ | any (sameHost h) (map topHost l) = cont $
+ setContainerProps h $ containerProps h
+ & conductedBy c
| otherwise = cont h
where
cont h' = foldl orchestrate' h' l
@@ -240,14 +245,16 @@ orchestrate' h (Conductor c l)
-- The host this property is added to becomes the conductor for the
-- specified Host. Note that `orchestrate` must be used for this property
-- to have any effect.
-conductorFor :: Host -> Property HasInfo
-conductorFor h = infoProperty desc go (addInfo mempty (ConductorFor [h])) []
- `requires` toProp (conductorKnownHost h)
+conductorFor :: Host -> Property (HasInfo + UnixLike)
+conductorFor h = go
+ `setInfoProperty` (toInfo (ConductorFor [h]))
+ `requires` setupRevertableProperty (conductorKnownHost h)
`requires` Ssh.installed
where
desc = cdesc (hostName h)
- go = ifM (isOrchestrated <$> askInfo)
+ go :: Property UnixLike
+ go = property desc $ ifM (isOrchestrated <$> askInfo)
( do
pm <- liftIO $ filterPrivData h
<$> readPrivDataFile privDataLocal
@@ -262,13 +269,15 @@ conductorFor h = infoProperty desc go (addInfo mempty (ConductorFor [h])) []
)
-- Reverts conductorFor.
-notConductorFor :: Host -> Property HasInfo
-notConductorFor h = infoProperty desc (return NoChange) (addInfo mempty (NotConductorFor [h])) []
- `requires` toProp (revert (conductorKnownHost h))
+notConductorFor :: Host -> Property (HasInfo + UnixLike)
+notConductorFor h = (doNothing :: Property UnixLike)
+ `setInfoProperty` (toInfo (NotConductorFor [h]))
+ `describe` desc
+ `requires` undoRevertableProperty (conductorKnownHost h)
where
desc = "not " ++ cdesc (hostName h)
-conductorKnownHost :: Host -> RevertableProperty NoInfo
+conductorKnownHost :: Host -> RevertableProperty UnixLike UnixLike
conductorKnownHost h =
mk Ssh.knownHost
<!>
@@ -287,10 +296,10 @@ addConductorPrivData h hs = h { hostInfo = hostInfo h <> i }
i = mempty
`addInfo` mconcat (map privinfo hs)
`addInfo` Orchestrated (Any True)
- privinfo h' = forceHostContext (hostName h') $ getInfo (hostInfo h')
+ privinfo h' = forceHostContext (hostName h') $ fromInfo (hostInfo h')
-- Use this property to let the specified conductor ssh in and run propellor.
-conductedBy :: Host -> RevertableProperty NoInfo
+conductedBy :: Host -> RevertableProperty UnixLike UnixLike
conductedBy h = (setup <!> teardown)
`describe` ("conducted by " ++ hostName h)
where
diff --git a/src/Propellor/Property/ConfFile.hs b/src/Propellor/Property/ConfFile.hs
index dac4e564..270e04f1 100644
--- a/src/Propellor/Property/ConfFile.hs
+++ b/src/Propellor/Property/ConfFile.hs
@@ -37,7 +37,7 @@ adjustSection
-> AdjustSection
-> InsertSection
-> FilePath
- -> Property NoInfo
+ -> Property UnixLike
adjustSection desc start past adjust insert = fileProperty desc go
where
go ls = let (pre, wanted, post) = foldl' find ([], [], []) ls
@@ -68,7 +68,7 @@ adjustIniSection
-> AdjustSection
-> InsertSection
-> FilePath
- -> Property NoInfo
+ -> Property UnixLike
adjustIniSection desc header =
adjustSection
desc
@@ -77,7 +77,7 @@ adjustIniSection desc header =
-- | Ensures that a .ini file exists and contains a section
-- with a key=value setting.
-containsIniSetting :: FilePath -> (IniSection, IniKey, String) -> Property NoInfo
+containsIniSetting :: FilePath -> (IniSection, IniKey, String) -> Property UnixLike
containsIniSetting f (header, key, value) =
adjustIniSection
(f ++ " section [" ++ header ++ "] contains " ++ key ++ "=" ++ value)
@@ -93,7 +93,7 @@ containsIniSetting f (header, key, value) =
isKeyVal x = (filter (/= ' ') . takeWhile (/= '=')) x `elem` [key, '#':key]
-- | Ensures that a .ini file does not contain the specified section.
-lacksIniSection :: FilePath -> IniSection -> Property NoInfo
+lacksIniSection :: FilePath -> IniSection -> Property UnixLike
lacksIniSection f header =
adjustIniSection
(f ++ " lacks section [" ++ header ++ "]")
diff --git a/src/Propellor/Property/Cron.hs b/src/Propellor/Property/Cron.hs
index 365e2903..0966a7e5 100644
--- a/src/Propellor/Property/Cron.hs
+++ b/src/Propellor/Property/Cron.hs
@@ -27,9 +27,11 @@ data Times
-- job file.
--
-- The cron job's output will only be emailed if it exits nonzero.
-job :: Desc -> Times -> User -> FilePath -> String -> Property NoInfo
-job desc times (User u) cddir command = combineProperties ("cronned " ++ desc)
- [ cronjobfile `File.hasContent`
+job :: Desc -> Times -> User -> FilePath -> String -> Property DebianLike
+job desc times (User u) cddir command = combineProperties ("cronned " ++ desc) $ props
+ & Apt.serviceInstalledRunning "cron"
+ & Apt.installed ["util-linux", "moreutils"]
+ & cronjobfile `File.hasContent`
[ case times of
Times _ -> ""
_ -> "#!/bin/sh\nset -e"
@@ -44,22 +46,19 @@ job desc times (User u) cddir command = combineProperties ("cronned " ++ desc)
"root" -> "chronic " ++ shellEscape scriptfile
_ -> "chronic su " ++ u ++ " -c " ++ shellEscape scriptfile
]
- , case times of
+ & case times of
Times _ -> doNothing
_ -> cronjobfile `File.mode` combineModes (readModes ++ executeModes)
-- Use a separate script because it makes the cron job name
-- prettier in emails, and also allows running the job manually.
- , scriptfile `File.hasContent`
+ & scriptfile `File.hasContent`
[ "#!/bin/sh"
, "# Generated by propellor"
, "set -e"
, "flock -n " ++ shellEscape cronjobfile
++ " sh -c " ++ shellEscape cmdline
]
- , scriptfile `File.mode` combineModes (readModes ++ executeModes)
- ]
- `requires` Apt.serviceInstalledRunning "cron"
- `requires` Apt.installed ["util-linux", "moreutils"]
+ & scriptfile `File.mode` combineModes (readModes ++ executeModes)
where
cmdline = "cd " ++ cddir ++ " && ( " ++ command ++ " )"
cronjobfile = "/etc" </> cronjobdir </> name
@@ -75,13 +74,13 @@ job desc times (User u) cddir command = combineProperties ("cronned " ++ desc)
| otherwise = '_'
-- | Installs a cron job, and runs it niced and ioniced.
-niceJob :: Desc -> Times -> User -> FilePath -> String -> Property NoInfo
+niceJob :: Desc -> Times -> User -> FilePath -> String -> Property DebianLike
niceJob desc times user cddir command = job desc times user cddir
("nice ionice -c 3 sh -c " ++ shellEscape command)
-- | Installs a cron job to run propellor.
-runPropellor :: Times -> Property NoInfo
-runPropellor times = withOS "propellor cron job" $ \o ->
- ensureProperty $
+runPropellor :: Times -> Property UnixLike
+runPropellor times = withOS "propellor cron job" $ \w o ->
+ ensureProperty w $
niceJob "propellor" times (User "root") localdir
(bootstrapPropellorCommand o ++ "; ./propellor")
diff --git a/src/Propellor/Property/DebianMirror.hs b/src/Propellor/Property/DebianMirror.hs
index eea7b96f..b86d8e0b 100644
--- a/src/Propellor/Property/DebianMirror.hs
+++ b/src/Propellor/Property/DebianMirror.hs
@@ -119,19 +119,17 @@ debianMirrorKeyring k m = m { _debianMirrorKeyring = k }
debianMirrorRsyncExtra :: [RsyncExtra] -> DebianMirror -> DebianMirror
debianMirrorRsyncExtra r m = m { _debianMirrorRsyncExtra = r }
-mirror :: DebianMirror -> Property NoInfo
-mirror mirror' = propertyList
- ("Debian mirror " ++ dir)
- [ Apt.installed ["debmirror"]
- , User.accountFor (User "debmirror")
- , File.dirExists dir
- , File.ownerGroup dir (User "debmirror") (Group "debmirror")
- , check (not . and <$> mapM suitemirrored suites)
+mirror :: DebianMirror -> Property DebianLike
+mirror mirror' = propertyList ("Debian mirror " ++ dir) $ props
+ & Apt.installed ["debmirror"]
+ & User.accountFor (User "debmirror")
+ & File.dirExists dir
+ & File.ownerGroup dir (User "debmirror") (Group "debmirror")
+ & check (not . and <$> mapM suitemirrored suites)
(cmdProperty "debmirror" args)
`describe` "debmirror setup"
- , Cron.niceJob ("debmirror_" ++ dir) (_debianMirrorCronTimes mirror') (User "debmirror") "/" $
- unwords ("/usr/bin/debmirror" : args)
- ]
+ & Cron.niceJob ("debmirror_" ++ dir) (_debianMirrorCronTimes mirror') (User "debmirror") "/"
+ (unwords ("/usr/bin/debmirror" : args))
where
dir = _debianMirrorDir mirror'
suites = _debianMirrorSuites mirror'
diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs
index 5716be38..e0c56966 100644
--- a/src/Propellor/Property/Debootstrap.hs
+++ b/src/Propellor/Property/Debootstrap.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE FlexibleContexts #-}
-
module Propellor.Property.Debootstrap (
Url,
DebootstrapConfig(..),
@@ -48,14 +46,15 @@ toParams (c1 :+ c2) = toParams c1 <> toParams c2
--
-- The System can be any OS and architecture that debootstrap
-- and the kernel support.
-built :: FilePath -> System -> DebootstrapConfig -> Property HasInfo
-built target system config = built' (toProp installed) target system config
+built :: FilePath -> System -> DebootstrapConfig -> Property Linux
+built target system config = built' (setupRevertableProperty installed) target system config
-built' :: (Combines (Property NoInfo) (Property i)) => Property i -> FilePath -> System -> DebootstrapConfig -> Property (CInfo NoInfo i)
+built' :: Property Linux -> FilePath -> System -> DebootstrapConfig -> Property Linux
built' installprop target system@(System _ arch) config =
check (unpopulated target <||> ispartial) setupprop
`requires` installprop
where
+ setupprop :: Property Linux
setupprop = property ("debootstrapped " ++ target) $ liftIO $ do
createDirectoryIfMissing True target
-- Don't allow non-root users to see inside the chroot,
@@ -99,39 +98,34 @@ extractSuite (System (FreeBSD _) _) = Nothing
-- When necessary, falls back to installing debootstrap from source.
-- Note that installation from source is done by downloading the tarball
-- from a Debian mirror, with no cryptographic verification.
-installed :: RevertableProperty NoInfo
+installed :: RevertableProperty Linux Linux
installed = install <!> remove
where
- install = withOS "debootstrap installed" $ \o ->
- ifM (liftIO $ isJust <$> programPath)
- ( return NoChange
- , ensureProperty (installon o)
- )
+ install = check (isJust <$> programPath) $
+ (aptinstall `pickOS` sourceInstall)
+ `describe` "debootstrap installed"
- installon (Just (System (Debian _) _)) = aptinstall
- installon (Just (System (Buntish _) _)) = aptinstall
- installon _ = sourceInstall
-
- remove = withOS "debootstrap removed" $ ensureProperty . removefrom
- removefrom (Just (System (Debian _) _)) = aptremove
- removefrom (Just (System (Buntish _) _)) = aptremove
- removefrom _ = sourceRemove
+ remove = (aptremove `pickOS` sourceRemove)
+ `describe` "debootstrap removed"
aptinstall = Apt.installed ["debootstrap"]
aptremove = Apt.removed ["debootstrap"]
-sourceInstall :: Property NoInfo
-sourceInstall = property "debootstrap installed from source" (liftIO sourceInstall')
+sourceInstall :: Property Linux
+sourceInstall = go
`requires` perlInstalled
`requires` arInstalled
+ where
+ go :: Property Linux
+ go = property "debootstrap installed from source" (liftIO sourceInstall')
-perlInstalled :: Property NoInfo
+perlInstalled :: Property Linux
perlInstalled = check (not <$> inPath "perl") $ property "perl installed" $
liftIO $ toResult . isJust <$> firstM id
[ yumInstall "perl"
]
-arInstalled :: Property NoInfo
+arInstalled :: Property Linux
arInstalled = check (not <$> inPath "ar") $ property "ar installed" $
liftIO $ toResult . isJust <$> firstM id
[ yumInstall "binutils"
@@ -175,7 +169,7 @@ sourceInstall' = withTmpDir "debootstrap" $ \tmpd -> do
return MadeChange
_ -> errorMessage "debootstrap tar file did not contain exactly one dirctory"
-sourceRemove :: Property NoInfo
+sourceRemove :: Property Linux
sourceRemove = property "debootstrap not installed from source" $ liftIO $
ifM (doesDirectoryExist sourceInstallDir)
( do
diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs
index 6200f856..718768c2 100644
--- a/src/Propellor/Property/DiskImage.hs
+++ b/src/Propellor/Property/DiskImage.hs
@@ -2,6 +2,8 @@
--
-- This module is designed to be imported unqualified.
+{-# LANGUAGE TypeFamilies #-}
+
module Propellor.Property.DiskImage (
-- * Partition specification
module Propellor.Property.DiskImage.PartSpec,
@@ -30,6 +32,7 @@ import Propellor.Property.Parted
import Propellor.Property.Mount
import Propellor.Property.Partition
import Propellor.Property.Rsync
+import Propellor.Container
import Utility.Path
import Data.List (isPrefixOf, isInfixOf, sortBy)
@@ -51,7 +54,8 @@ type DiskImage = FilePath
--
-- > import Propellor.Property.DiskImage
--
--- > let chroot d = Chroot.debootstrapped (System (Debian Unstable) "amd64") mempty d
+-- > let chroot d = Chroot.debootstrapped mempty d
+-- > & osDebian Unstable "amd64"
-- > & Apt.installed ["linux-image-amd64"]
-- > & User.hasPassword (User "root")
-- > & User.accountFor (User "demo")
@@ -76,44 +80,54 @@ type DiskImage = FilePath
-- chroot while the disk image is being built, which should prevent any
-- daemons that are included from being started on the system that is
-- building the disk image.
-imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty HasInfo
+imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) Linux
imageBuilt = imageBuilt' False
-- | Like 'built', but the chroot is deleted and rebuilt from scratch each
-- time. This is more expensive, but useful to ensure reproducible results
-- when the properties of the chroot have been changed.
-imageRebuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty HasInfo
+imageRebuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) Linux
imageRebuilt = imageBuilt' True
-imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty HasInfo
+imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) Linux
imageBuilt' rebuild img mkchroot tabletype final partspec =
imageBuiltFrom img chrootdir tabletype final partspec
`requires` Chroot.provisioned chroot
- `requires` (cleanrebuild <!> doNothing)
+ `requires` (cleanrebuild <!> (doNothing :: Property UnixLike))
`describe` desc
where
desc = "built disk image " ++ img
+ cleanrebuild :: Property Linux
cleanrebuild
| rebuild = property desc $ do
liftIO $ removeChroot chrootdir
return MadeChange
| otherwise = doNothing
chrootdir = img ++ ".chroot"
- chroot = mkchroot chrootdir
- -- Before ensuring any other properties of the chroot, avoid
- -- starting services. Reverted by imageFinalized.
- &^ Chroot.noServices
- -- First stage finalization.
- & fst final
- -- Avoid wasting disk image space on the apt cache
- & Apt.cacheCleaned
+ chroot =
+ let c = mkchroot chrootdir
+ in setContainerProps c $ containerProps c
+ -- Before ensuring any other properties of the chroot,
+ -- avoid starting services. Reverted by imageFinalized.
+ &^ Chroot.noServices
+ -- First stage finalization.
+ & fst final
+ & cachesCleaned
+
+-- | This property is automatically added to the chroot when building a
+-- disk image. It cleans any caches of information that can be omitted;
+-- eg the apt cache on Debian.
+cachesCleaned :: Property UnixLike
+cachesCleaned = "cache cleaned" ==> (Apt.cacheCleaned `pickOS` skipit)
+ where
+ skipit = doNothing :: Property UnixLike
-- | Builds a disk image from the contents of a chroot.
-imageBuiltFrom :: DiskImage -> FilePath -> TableType -> Finalization -> [PartSpec] -> RevertableProperty NoInfo
+imageBuiltFrom :: DiskImage -> FilePath -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) UnixLike
imageBuiltFrom img chrootdir tabletype final partspec = mkimg <!> rmimg
where
desc = img ++ " built from " ++ chrootdir
- mkimg = property desc $ do
+ mkimg = property' desc $ \w -> do
-- unmount helper filesystems such as proc from the chroot
-- before getting sizes
liftIO $ unmountBelow chrootdir
@@ -123,7 +137,7 @@ imageBuiltFrom img chrootdir tabletype final partspec = mkimg <!> rmimg
-- tie the knot!
let (mnts, mntopts, parttable) = fitChrootSize tabletype partspec $
map (calcsz mnts) mnts
- ensureProperty $
+ ensureProperty w $
imageExists img (partTableSize parttable)
`before`
partitioned YesReallyDeleteDiskContents img parttable
@@ -135,17 +149,18 @@ imageBuiltFrom img chrootdir tabletype final partspec = mkimg <!> rmimg
imageFinalized final mnts mntopts devs parttable
rmimg = File.notPresent img
-partitionsPopulated :: FilePath -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> Property NoInfo
-partitionsPopulated chrootdir mnts mntopts devs = property desc $ mconcat $ zipWith3 go mnts mntopts devs
+partitionsPopulated :: FilePath -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> Property Linux
+partitionsPopulated chrootdir mnts mntopts devs = property' desc $ \w ->
+ mconcat $ zipWith3 (go w) mnts mntopts devs
where
desc = "partitions populated from " ++ chrootdir
- go Nothing _ _ = noChange
- go (Just mnt) mntopt loopdev = withTmpDir "mnt" $ \tmpdir -> bracket
+ go _ Nothing _ _ = noChange
+ go w (Just mnt) mntopt loopdev = withTmpDir "mnt" $ \tmpdir -> bracket
(liftIO $ mount "auto" (partitionLoopDev loopdev) tmpdir mntopt)
(const $ liftIO $ umountLazy tmpdir)
$ \ismounted -> if ismounted
- then ensureProperty $
+ then ensureProperty w $
syncDirFiltered (filtersfor mnt) (chrootdir ++ mnt) tmpdir
else return FailedChange
@@ -203,7 +218,7 @@ getMountSz szm l (Just mntpt) =
-- If the file doesn't exist, or is too small, creates a new one, full of 0's.
--
-- If the file is too large, truncates it down to the specified size.
-imageExists :: FilePath -> ByteSize -> Property NoInfo
+imageExists :: FilePath -> ByteSize -> Property Linux
imageExists img sz = property ("disk image exists" ++ img) $ liftIO $ do
ms <- catchMaybeIO $ getFileStatus img
case ms of
@@ -226,19 +241,19 @@ imageExists img sz = property ("disk image exists" ++ img) $ liftIO $ do
--
-- It's ok if the second property leaves additional things mounted
-- in the partition tree.
-type Finalization = (Property NoInfo, (FilePath -> [LoopDev] -> Property NoInfo))
+type Finalization = (Property Linux, (FilePath -> [LoopDev] -> Property Linux))
-imageFinalized :: Finalization -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> PartTable -> Property NoInfo
+imageFinalized :: Finalization -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> PartTable -> Property Linux
imageFinalized (_, final) mnts mntopts devs (PartTable _ parts) =
- property "disk image finalized" $
+ property' "disk image finalized" $ \w ->
withTmpDir "mnt" $ \top ->
- go top `finally` liftIO (unmountall top)
+ go w top `finally` liftIO (unmountall top)
where
- go top = do
+ go w top = do
liftIO $ mountall top
liftIO $ writefstab top
liftIO $ allowservices top
- ensureProperty $ final top devs
+ ensureProperty w $ final top devs
-- Ordered lexographically by mount point, so / comes before /usr
-- comes before /usr/local
@@ -280,27 +295,26 @@ noFinalization = (doNothing, \_ _ -> doNothing)
grubBooted :: Grub.BIOS -> Finalization
grubBooted bios = (Grub.installed' bios, boots)
where
- boots mnt loopdevs = combineProperties "disk image boots using grub"
+ boots mnt loopdevs = combineProperties "disk image boots using grub" $ props
-- bind mount host /dev so grub can access the loop devices
- [ bindMount "/dev" (inmnt "/dev")
- , mounted "proc" "proc" (inmnt "/proc") mempty
- , mounted "sysfs" "sys" (inmnt "/sys") mempty
+ & bindMount "/dev" (inmnt "/dev")
+ & mounted "proc" "proc" (inmnt "/proc") mempty
+ & mounted "sysfs" "sys" (inmnt "/sys") mempty
-- update the initramfs so it gets the uuid of the root partition
- , inchroot "update-initramfs" ["-u"]
+ & inchroot "update-initramfs" ["-u"]
`assume` MadeChange
-- work around for http://bugs.debian.org/802717
- , check haveosprober $ inchroot "chmod" ["-x", osprober]
- , inchroot "update-grub" []
+ & check haveosprober (inchroot "chmod" ["-x", osprober])
+ & inchroot "update-grub" []
`assume` MadeChange
- , check haveosprober $ inchroot "chmod" ["+x", osprober]
- , inchroot "grub-install" [wholediskloopdev]
+ & check haveosprober (inchroot "chmod" ["+x", osprober])
+ & inchroot "grub-install" [wholediskloopdev]
`assume` MadeChange
-- sync all buffered changes out to the disk image
-- may not be necessary, but seemed needed sometimes
-- when using the disk image right away.
- , cmdProperty "sync" []
+ & cmdProperty "sync" []
`assume` NoChange
- ]
where
-- cannot use </> since the filepath is absolute
inmnt f = mnt ++ f
diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs
index adc12930..2e2710a6 100644
--- a/src/Propellor/Property/Dns.hs
+++ b/src/Propellor/Property/Dns.hs
@@ -60,7 +60,7 @@ import Data.List
--
-- In either case, the secondary dns server Host should have an ipv4 and/or
-- ipv6 property defined.
-primary :: [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty HasInfo
+primary :: [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty (HasInfo + DebianLike) DebianLike
primary hosts domain soa rs = setup <!> cleanup
where
setup = setupPrimary zonefile id hosts domain soa rs
@@ -70,7 +70,7 @@ primary hosts domain soa rs = setup <!> cleanup
zonefile = "/etc/bind/propellor/db." ++ domain
-setupPrimary :: FilePath -> (FilePath -> FilePath) -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> Property HasInfo
+setupPrimary :: FilePath -> (FilePath -> FilePath) -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> Property (HasInfo + DebianLike)
setupPrimary zonefile mknamedconffile hosts domain soa rs =
withwarnings baseprop
`requires` servingZones
@@ -80,9 +80,10 @@ setupPrimary zonefile mknamedconffile hosts domain soa rs =
indomain = M.elems $ M.filterWithKey (\hn _ -> inDomain domain $ AbsDomain $ hn) hostmap
(partialzone, zonewarnings) = genZone indomain hostmap domain soa
- baseprop = infoProperty ("dns primary for " ++ domain) satisfy
- (mempty `addInfo` addNamedConf conf) []
- satisfy = do
+ baseprop = primaryprop
+ `setInfoProperty` (toInfo (addNamedConf conf))
+ primaryprop :: Property DebianLike
+ primaryprop = property ("dns primary for " ++ domain) $ do
sshfps <- concat <$> mapM (genSSHFP domain) (M.elems hostmap)
let zone = partialzone
{ zHosts = zHosts partialzone ++ rs ++ sshfps }
@@ -120,11 +121,13 @@ setupPrimary zonefile mknamedconffile hosts domain soa rs =
in z /= oldzone || oldserial < sSerial (zSOA zone)
-cleanupPrimary :: FilePath -> Domain -> Property NoInfo
+cleanupPrimary :: FilePath -> Domain -> Property DebianLike
cleanupPrimary zonefile domain = check (doesFileExist zonefile) $
- property ("removed dns primary for " ++ domain)
- (makeChange $ removeZoneFile zonefile)
- `requires` namedConfWritten
+ go `requires` namedConfWritten
+ where
+ desc = "removed dns primary for " ++ domain
+ go :: Property DebianLike
+ go = property desc (makeChange $ removeZoneFile zonefile)
-- | Primary dns server for a domain, secured with DNSSEC.
--
@@ -152,7 +155,7 @@ cleanupPrimary zonefile domain = check (doesFileExist zonefile) $
-- This is different from the serial number used by 'primary', so if you
-- want to later disable DNSSEC you will need to adjust the serial number
-- passed to mkSOA to ensure it is larger.
-signedPrimary :: Recurrance -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty HasInfo
+signedPrimary :: Recurrance -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty (HasInfo + DebianLike) DebianLike
signedPrimary recurrance hosts domain soa rs = setup <!> cleanup
where
setup = combineProperties ("dns primary for " ++ domain ++ " (signed)")
@@ -184,12 +187,12 @@ signedPrimary recurrance hosts domain soa rs = setup <!> cleanup
--
-- Note that if a host is declared to be a primary and a secondary dns
-- server for the same domain, the primary server config always wins.
-secondary :: [Host] -> Domain -> RevertableProperty HasInfo
+secondary :: [Host] -> Domain -> RevertableProperty (HasInfo + DebianLike) DebianLike
secondary hosts domain = secondaryFor (otherServers Master hosts domain) hosts domain
-- | This variant is useful if the primary server does not have its DNS
-- configured via propellor.
-secondaryFor :: [HostName] -> [Host] -> Domain -> RevertableProperty HasInfo
+secondaryFor :: [HostName] -> [Host] -> Domain -> RevertableProperty (HasInfo + DebianLike) DebianLike
secondaryFor masters hosts domain = setup <!> cleanup
where
setup = pureInfoProperty desc (addNamedConf conf)
@@ -210,7 +213,7 @@ otherServers :: DnsServerType -> [Host] -> Domain -> [HostName]
otherServers wantedtype hosts domain =
M.keys $ M.filter wanted $ hostMap hosts
where
- wanted h = case M.lookup domain (fromNamedConfMap $ getInfo $ hostInfo h) of
+ wanted h = case M.lookup domain (fromNamedConfMap $ fromInfo $ hostInfo h) of
Nothing -> False
Just conf -> confDnsServerType conf == wantedtype
&& confDomain conf == domain
@@ -218,15 +221,15 @@ otherServers wantedtype hosts domain =
-- | Rewrites the whole named.conf.local file to serve the zones
-- configured by `primary` and `secondary`, and ensures that bind9 is
-- running.
-servingZones :: Property NoInfo
+servingZones :: Property DebianLike
servingZones = namedConfWritten
`onChange` Service.reloaded "bind9"
`requires` Apt.serviceInstalledRunning "bind9"
-namedConfWritten :: Property NoInfo
-namedConfWritten = property "named.conf configured" $ do
+namedConfWritten :: Property DebianLike
+namedConfWritten = property' "named.conf configured" $ \w -> do
zs <- getNamedConf
- ensureProperty $
+ ensureProperty w $
hasContent namedConfFile $
concatMap confStanza $ M.elems zs
@@ -465,7 +468,7 @@ genZone inzdomain hostmap zdomain soa =
-- So we can just use the IPAddrs.
addcnames :: Host -> [Either WarningMessage (BindDomain, Record)]
addcnames h = concatMap gen $ filter (inDomain zdomain) $
- mapMaybe getCNAME $ S.toList $ fromDnsInfo $ getInfo info
+ mapMaybe getCNAME $ S.toList $ fromDnsInfo $ fromInfo info
where
info = hostInfo h
gen c = case getAddresses info of
@@ -480,7 +483,7 @@ genZone inzdomain hostmap zdomain soa =
where
info = hostInfo h
l = zip (repeat $ AbsDomain $ hostName h)
- (S.toList $ S.filter (\r -> isNothing (getIPAddr r) && isNothing (getCNAME r)) (fromDnsInfo $ getInfo info))
+ (S.toList $ S.filter (\r -> isNothing (getIPAddr r) && isNothing (getCNAME r)) (fromDnsInfo $ fromInfo info))
-- Simplifies the list of hosts. Remove duplicate entries.
-- Also, filter out any CHAMES where the same domain has an
@@ -515,7 +518,7 @@ addNamedConf conf = NamedConfMap (M.singleton domain conf)
domain = confDomain conf
getNamedConf :: Propellor (M.Map Domain NamedConf)
-getNamedConf = asks $ fromNamedConfMap . getInfo . hostInfo
+getNamedConf = asks $ fromNamedConfMap . fromInfo . hostInfo
-- | Generates SSHFP records for hosts in the domain (or with CNAMES
-- in the domain) that have configured ssh public keys.
@@ -528,7 +531,7 @@ genSSHFP domain h = concatMap mk . concat <$> (gen =<< get)
gen = liftIO . mapM genSSHFP' . M.elems . fromMaybe M.empty
mk r = mapMaybe (\d -> if inDomain domain d then Just (d, r) else Nothing)
(AbsDomain hostname : cnames)
- cnames = mapMaybe getCNAME $ S.toList $ fromDnsInfo $ getInfo info
+ cnames = mapMaybe getCNAME $ S.toList $ fromDnsInfo $ fromInfo info
hostname = hostName h
info = hostInfo h
diff --git a/src/Propellor/Property/DnsSec.hs b/src/Propellor/Property/DnsSec.hs
index 1ba459e6..aa58dc60 100644
--- a/src/Propellor/Property/DnsSec.hs
+++ b/src/Propellor/Property/DnsSec.hs
@@ -7,13 +7,13 @@ import qualified Propellor.Property.File as File
--
-- signedPrimary uses this, so this property does not normally need to be
-- used directly.
-keysInstalled :: Domain -> RevertableProperty HasInfo
+keysInstalled :: Domain -> RevertableProperty (HasInfo + UnixLike) UnixLike
keysInstalled domain = setup <!> cleanup
where
- setup = propertyList "DNSSEC keys installed" $
+ setup = propertyList "DNSSEC keys installed" $ toProps $
map installkey keys
- cleanup = propertyList "DNSSEC keys removed" $
+ cleanup = propertyList "DNSSEC keys removed" $ toProps $
map (File.notPresent . keyFn domain) keys
installkey k = writer (keysrc k) (keyFn domain k) (Context domain)
@@ -37,12 +37,14 @@ keysInstalled domain = setup <!> cleanup
--
-- signedPrimary uses this, so this property does not normally need to be
-- used directly.
-zoneSigned :: Domain -> FilePath -> RevertableProperty HasInfo
+zoneSigned :: Domain -> FilePath -> RevertableProperty (HasInfo + UnixLike) UnixLike
zoneSigned domain zonefile = setup <!> cleanup
where
+ setup :: Property (HasInfo + UnixLike)
setup = check needupdate (forceZoneSigned domain zonefile)
`requires` keysInstalled domain
+ cleanup :: Property UnixLike
cleanup = File.notPresent (signedZoneFile zonefile)
`before` File.notPresent dssetfile
`before` revert (keysInstalled domain)
@@ -63,7 +65,7 @@ zoneSigned domain zonefile = setup <!> cleanup
t2 <- getModificationTime f
return (t2 >= t1)
-forceZoneSigned :: Domain -> FilePath -> Property NoInfo
+forceZoneSigned :: Domain -> FilePath -> Property UnixLike
forceZoneSigned domain zonefile = property ("zone signed for " ++ domain) $ liftIO $ do
salt <- take 16 <$> saltSha1
let p = proc "dnssec-signzone"
diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs
index ebc0b301..2ef97438 100644
--- a/src/Propellor/Property/Docker.hs
+++ b/src/Propellor/Property/Docker.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE FlexibleContexts, TypeSynonymInstances, FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts, TypeSynonymInstances, FlexibleInstances, TypeFamilies #-}
-- | Docker support for propellor
--
@@ -48,8 +48,10 @@ module Propellor.Property.Docker (
import Propellor.Base hiding (init)
import Propellor.Types.Docker
import Propellor.Types.Container
+import Propellor.Types.Core
import Propellor.Types.CmdLine
import Propellor.Types.Info
+import Propellor.Container
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.Cmd as Cmd
@@ -66,16 +68,17 @@ import Data.List.Utils
import qualified Data.Map as M
import System.Console.Concurrent
-installed :: Property NoInfo
+installed :: Property DebianLike
installed = Apt.installed ["docker.io"]
-- | Configures docker with an authentication file, so that images can be
-- pushed to index.docker.io. Optional.
-configured :: Property HasInfo
+configured :: Property (HasInfo + DebianLike)
configured = prop `requires` installed
where
+ prop :: Property (HasInfo + DebianLike)
prop = withPrivData src anyContext $ \getcfg ->
- property "docker configured" $ getcfg $ \cfg -> ensureProperty $
+ property' "docker configured" $ \w -> getcfg $ \cfg -> ensureProperty w $
"/root/.dockercfg" `File.hasContent` privDataLines cfg
src = PrivDataSourceFileFromCommand DockerAuthentication
"/root/.dockercfg" "docker login"
@@ -88,6 +91,11 @@ type ContainerName = String
-- | A docker container.
data Container = Container Image Host
+instance IsContainer Container where
+ containerProperties (Container _ h) = containerProperties h
+ containerInfo (Container _ h) = containerInfo h
+ setContainerProperties (Container i h) ps = Container i (setContainerProperties h ps)
+
class HasImage a where
getImageName :: a -> Image
@@ -97,22 +105,17 @@ instance HasImage Image where
instance HasImage Container where
getImageName (Container i _) = i
-instance PropAccum Container where
- (Container i h) `addProp` p = Container i (h `addProp` p)
- (Container i h) `addPropFront` p = Container i (h `addPropFront` p)
- getProperties (Container _ h) = hostProperties h
-
-- | Defines a Container with a given name, image, and properties.
--- Properties can be added to configure the Container.
+-- Add properties to configure the Container.
--
--- > container "web-server" "debian"
+-- > container "web-server" (latestImage "debian") $ props
-- > & publish "80:80"
-- > & Apt.installed {"apache2"]
-- > & ...
-container :: ContainerName -> Image -> Container
-container cn image = Container image (Host cn [] info)
+container :: ContainerName -> Image -> Props metatypes -> Container
+container cn image (Props ps) = Container image (Host cn ps info)
where
- info = dockerInfo mempty
+ info = dockerInfo mempty <> mconcat (map getInfoRecursive ps)
-- | Ensures that a docker container is set up and running.
--
@@ -124,7 +127,7 @@ container cn image = Container image (Host cn [] info)
--
-- Reverting this property ensures that the container is stopped and
-- removed.
-docked :: Container -> RevertableProperty HasInfo
+docked :: Container -> RevertableProperty (HasInfo + Linux) (HasInfo + Linux)
docked ctr@(Container _ h) =
(propagateContainerInfo ctr (go "docked" setup))
<!>
@@ -132,11 +135,12 @@ docked ctr@(Container _ h) =
where
cn = hostName h
- go desc a = property (desc ++ " " ++ cn) $ do
+ go desc a = property' (desc ++ " " ++ cn) $ \w -> do
hn <- asks hostName
let cid = ContainerId hn cn
- ensureProperties [a cid (mkContainerInfo cid ctr)]
+ ensureProperty w $ a cid (mkContainerInfo cid ctr)
+ setup :: ContainerId -> ContainerInfo -> Property Linux
setup cid (ContainerInfo image runparams) =
provisionContainer cid
`requires`
@@ -144,8 +148,9 @@ docked ctr@(Container _ h) =
`requires`
installed
+ teardown :: ContainerId -> ContainerInfo -> Property Linux
teardown cid (ContainerInfo image _runparams) =
- combineProperties ("undocked " ++ fromContainerId cid)
+ combineProperties ("undocked " ++ fromContainerId cid) $ toProps
[ stoppedContainer cid
, property ("cleaned up " ++ fromContainerId cid) $
liftIO $ report <$> mapM id
@@ -155,32 +160,32 @@ docked ctr@(Container _ h) =
]
-- | Build the image from a directory containing a Dockerfile.
-imageBuilt :: HasImage c => FilePath -> c -> Property NoInfo
-imageBuilt directory ctr = describe built msg
+imageBuilt :: HasImage c => FilePath -> c -> Property Linux
+imageBuilt directory ctr = built `describe` msg
where
msg = "docker image " ++ (imageIdentifier image) ++ " built from " ++ directory
- built = Cmd.cmdProperty' dockercmd ["build", "--tag", imageIdentifier image, "./"] workDir
- `assume` MadeChange
+ built :: Property Linux
+ built = tightenTargets $
+ Cmd.cmdProperty' dockercmd ["build", "--tag", imageIdentifier image, "./"] workDir
+ `assume` MadeChange
workDir p = p { cwd = Just directory }
image = getImageName ctr
-- | Pull the image from the standard Docker Hub registry.
-imagePulled :: HasImage c => c -> Property NoInfo
-imagePulled ctr = describe pulled msg
+imagePulled :: HasImage c => c -> Property Linux
+imagePulled ctr = pulled `describe` msg
where
msg = "docker image " ++ (imageIdentifier image) ++ " pulled"
- pulled = Cmd.cmdProperty dockercmd ["pull", imageIdentifier image]
- `assume` MadeChange
+ pulled :: Property Linux
+ pulled = tightenTargets $
+ Cmd.cmdProperty dockercmd ["pull", imageIdentifier image]
+ `assume` MadeChange
image = getImageName ctr
-propagateContainerInfo :: (IsProp (Property i)) => Container -> Property i -> Property HasInfo
-propagateContainerInfo ctr@(Container _ h) p = propagateContainer cn ctr p'
+propagateContainerInfo :: Container -> Property (HasInfo + Linux) -> Property (HasInfo + Linux)
+propagateContainerInfo ctr@(Container _ h) p = propagateContainer cn ctr $
+ p `addInfoProperty` dockerinfo
where
- p' = infoProperty
- (propertyDesc p)
- (propertySatisfy p)
- (propertyInfo p <> dockerinfo)
- (propertyChildren p)
dockerinfo = dockerInfo $
mempty { _dockerContainers = M.singleton cn h }
cn = hostName h
@@ -191,8 +196,8 @@ mkContainerInfo cid@(ContainerId hn _cn) (Container img h) =
where
runparams = map (\(DockerRunParam mkparam) -> mkparam hn)
(_dockerRunParams info)
- info = getInfo $ hostInfo h'
- h' = h
+ info = fromInfo $ hostInfo h'
+ h' = setContainerProps h $ containerProps h
-- Restart by default so container comes up on
-- boot or when docker is upgraded.
&^ restartAlways
@@ -209,14 +214,15 @@ mkContainerInfo cid@(ContainerId hn _cn) (Container img h) =
-- that were not set up using propellor.
--
-- Generally, should come after the properties for the desired containers.
-garbageCollected :: Property NoInfo
-garbageCollected = propertyList "docker garbage collected"
- [ gccontainers
- , gcimages
- ]
+garbageCollected :: Property Linux
+garbageCollected = propertyList "docker garbage collected" $ props
+ & gccontainers
+ & gcimages
where
+ gccontainers :: Property Linux
gccontainers = property "docker containers garbage collected" $
liftIO $ report <$> (mapM removeContainer =<< listContainers AllContainers)
+ gcimages :: Property Linux
gcimages = property "docker images garbage collected" $
liftIO $ report <$> (mapM removeImage =<< listImages)
@@ -225,8 +231,8 @@ garbageCollected = propertyList "docker garbage collected"
-- Currently, this consists of making pam_loginuid lines optional in
-- the pam config, to work around <https://github.com/docker/docker/issues/5663>
-- which affects docker 1.2.0.
-tweaked :: Property NoInfo
-tweaked = cmdProperty "sh"
+tweaked :: Property Linux
+tweaked = tightenTargets $ cmdProperty "sh"
[ "-c"
, "sed -ri 's/^session\\s+required\\s+pam_loginuid.so$/session optional pam_loginuid.so/' /etc/pam.d/*"
]
@@ -239,10 +245,11 @@ tweaked = cmdProperty "sh"
-- other GRUB_CMDLINE_LINUX_DEFAULT settings.
--
-- Only takes effect after reboot. (Not automated.)
-memoryLimited :: Property NoInfo
-memoryLimited = "/etc/default/grub" `File.containsLine` cfg
- `describe` "docker memory limited"
- `onChange` (cmdProperty "update-grub" [] `assume` MadeChange)
+memoryLimited :: Property DebianLike
+memoryLimited = tightenTargets $
+ "/etc/default/grub" `File.containsLine` cfg
+ `describe` "docker memory limited"
+ `onChange` (cmdProperty "update-grub" [] `assume` MadeChange)
where
cmdline = "cgroup_enable=memory swapaccount=1"
cfg = "GRUB_CMDLINE_LINUX_DEFAULT=\""++cmdline++"\""
@@ -300,15 +307,15 @@ instance ImageIdentifier ImageUID where
imageIdentifier (ImageUID uid) = uid
-- | Set custom dns server for container.
-dns :: String -> Property HasInfo
+dns :: String -> Property (HasInfo + Linux)
dns = runProp "dns"
-- | Set container host name.
-hostname :: String -> Property HasInfo
+hostname :: String -> Property (HasInfo + Linux)
hostname = runProp "hostname"
-- | Set name of container.
-name :: String -> Property HasInfo
+name :: String -> Property (HasInfo + Linux)
name = runProp "name"
class Publishable p where
@@ -322,15 +329,15 @@ instance Publishable String where
toPublish = id
-- | Publish a container's port to the host
-publish :: Publishable p => p -> Property HasInfo
+publish :: Publishable p => p -> Property (HasInfo + Linux)
publish = runProp "publish" . toPublish
-- | Expose a container's port without publishing it.
-expose :: String -> Property HasInfo
+expose :: String -> Property (HasInfo + Linux)
expose = runProp "expose"
-- | Username or UID for container.
-user :: String -> Property HasInfo
+user :: String -> Property (HasInfo + Linux)
user = runProp "user"
class Mountable p where
@@ -346,17 +353,17 @@ instance Mountable String where
toMount = id
-- | Mount a volume
-volume :: Mountable v => v -> Property HasInfo
+volume :: Mountable v => v -> Property (HasInfo + Linux)
volume = runProp "volume" . toMount
-- | Mount a volume from the specified container into the current
-- container.
-volumes_from :: ContainerName -> Property HasInfo
+volumes_from :: ContainerName -> Property (HasInfo + Linux)
volumes_from cn = genProp "volumes-from" $ \hn ->
fromContainerId (ContainerId hn cn)
-- | Work dir inside the container.
-workdir :: String -> Property HasInfo
+workdir :: String -> Property (HasInfo + Linux)
workdir = runProp "workdir"
-- | Memory limit for container.
@@ -364,18 +371,18 @@ workdir = runProp "workdir"
--
-- Note: Only takes effect when the host has the memoryLimited property
-- enabled.
-memory :: String -> Property HasInfo
+memory :: String -> Property (HasInfo + Linux)
memory = runProp "memory"
-- | CPU shares (relative weight).
--
-- By default, all containers run at the same priority, but you can tell
-- the kernel to give more CPU time to a container using this property.
-cpuShares :: Int -> Property HasInfo
+cpuShares :: Int -> Property (HasInfo + Linux)
cpuShares = runProp "cpu-shares" . show
-- | Link with another container on the same host.
-link :: ContainerName -> ContainerAlias -> Property HasInfo
+link :: ContainerName -> ContainerAlias -> Property (HasInfo + Linux)
link linkwith calias = genProp "link" $ \hn ->
fromContainerId (ContainerId hn linkwith) ++ ":" ++ calias
@@ -387,24 +394,24 @@ type ContainerAlias = String
-- propellor; as well as keeping badly behaved containers running,
-- it ensures that containers get started back up after reboot or
-- after docker is upgraded.
-restartAlways :: Property HasInfo
+restartAlways :: Property (HasInfo + Linux)
restartAlways = runProp "restart" "always"
-- | Docker will restart the container if it exits nonzero.
-- If a number is provided, it will be restarted only up to that many
-- times.
-restartOnFailure :: Maybe Int -> Property HasInfo
+restartOnFailure :: Maybe Int -> Property (HasInfo + Linux)
restartOnFailure Nothing = runProp "restart" "on-failure"
restartOnFailure (Just n) = runProp "restart" ("on-failure:" ++ show n)
-- | Makes docker not restart a container when it exits
-- Note that this includes not restarting it on boot!
-restartNever :: Property HasInfo
+restartNever :: Property (HasInfo + Linux)
restartNever = runProp "restart" "no"
-- | Set environment variable with a tuple composed by the environment
-- variable name and its value.
-environment :: (String, String) -> Property HasInfo
+environment :: (String, String) -> Property (HasInfo + Linux)
environment (k, v) = runProp "env" $ k ++ "=" ++ v
-- | A container is identified by its name, and the host
@@ -441,9 +448,9 @@ myContainerSuffix = ".propellor"
containerDesc :: (IsProp (Property i)) => ContainerId -> Property i -> Property i
containerDesc cid p = p `describe` desc
where
- desc = "container " ++ fromContainerId cid ++ " " ++ propertyDesc p
+ desc = "container " ++ fromContainerId cid ++ " " ++ getDesc p
-runningContainer :: ContainerId -> Image -> [RunParam] -> Property NoInfo
+runningContainer :: ContainerId -> Image -> [RunParam] -> Property Linux
runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ property "running" $ do
l <- liftIO $ listContainers RunningContainers
if cid `elem` l
@@ -507,6 +514,7 @@ runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ prope
retry (n-1) a
_ -> return v
+ go :: ImageIdentifier i => i -> Propellor Result
go img = liftIO $ do
clearProvisionedFlag cid
createDirectoryIfMissing True (takeDirectory $ identFile cid)
@@ -558,7 +566,7 @@ init s = case toContainerId s of
-- | Once a container is running, propellor can be run inside
-- it to provision it.
-provisionContainer :: ContainerId -> Property NoInfo
+provisionContainer :: ContainerId -> Property Linux
provisionContainer cid = containerDesc cid $ property "provisioned" $ liftIO $ do
let shim = Shim.file (localdir </> "propellor") (localdir </> shimdir cid)
let params = ["--continue", show $ toChain cid]
@@ -580,16 +588,14 @@ chain hostlist hn s = case toContainerId s of
Nothing -> errorMessage "bad container id"
Just cid -> case findHostNoAlias hostlist hn of
Nothing -> errorMessage ("cannot find host " ++ hn)
- Just parenthost -> case M.lookup (containerName cid) (_dockerContainers $ getInfo $ hostInfo parenthost) of
+ Just parenthost -> case M.lookup (containerName cid) (_dockerContainers $ fromInfo $ hostInfo parenthost) of
Nothing -> errorMessage ("cannot find container " ++ containerName cid ++ " docked on host " ++ hn)
Just h -> go cid h
where
go cid h = do
changeWorkingDirectory localdir
onlyProcess (provisioningLock cid) $ do
- r <- runPropellor h $ ensureProperties $
- map ignoreInfo $
- hostProperties h
+ r <- runPropellor h $ ensureChildProperties $ hostProperties h
flushConcurrentOutput
putStrLn $ "\n" ++ show r
@@ -599,15 +605,16 @@ stopContainer cid = boolSystem dockercmd [Param "stop", Param $ fromContainerId
startContainer :: ContainerId -> IO Bool
startContainer cid = boolSystem dockercmd [Param "start", Param $ fromContainerId cid ]
-stoppedContainer :: ContainerId -> Property NoInfo
-stoppedContainer cid = containerDesc cid $ property desc $
+stoppedContainer :: ContainerId -> Property Linux
+stoppedContainer cid = containerDesc cid $ property' desc $ \w ->
ifM (liftIO $ elem cid <$> listContainers RunningContainers)
- ( liftIO cleanup `after` ensureProperty
- (property desc $ liftIO $ toResult <$> stopContainer cid)
+ ( liftIO cleanup `after` ensureProperty w stop
, return NoChange
)
where
desc = "stopped"
+ stop :: Property Linux
+ stop = property desc $ liftIO $ toResult <$> stopContainer cid
cleanup = do
nukeFile $ identFile cid
removeDirectoryRecursive $ shimdir cid
@@ -651,14 +658,14 @@ listContainers status =
listImages :: IO [ImageUID]
listImages = map ImageUID . lines <$> readProcess dockercmd ["images", "--all", "--quiet"]
-runProp :: String -> RunParam -> Property HasInfo
-runProp field val = pureInfoProperty (param) $
+runProp :: String -> RunParam -> Property (HasInfo + Linux)
+runProp field val = tightenTargets $ pureInfoProperty (param) $
mempty { _dockerRunParams = [DockerRunParam (\_ -> "--"++param)] }
where
param = field++"="++val
-genProp :: String -> (HostName -> RunParam) -> Property HasInfo
-genProp field mkval = pureInfoProperty field $
+genProp :: String -> (HostName -> RunParam) -> Property (HasInfo + Linux)
+genProp field mkval = tightenTargets $ pureInfoProperty field $
mempty { _dockerRunParams = [DockerRunParam (\hn -> "--"++field++"=" ++ mkval hn)] }
dockerInfo :: DockerInfo -> Info
diff --git a/src/Propellor/Property/Fail2Ban.hs b/src/Propellor/Property/Fail2Ban.hs
index 716d376f..9f147943 100644
--- a/src/Propellor/Property/Fail2Ban.hs
+++ b/src/Propellor/Property/Fail2Ban.hs
@@ -5,24 +5,24 @@ import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.Service as Service
import Propellor.Property.ConfFile
-installed :: Property NoInfo
+installed :: Property DebianLike
installed = Apt.serviceInstalledRunning "fail2ban"
-reloaded :: Property NoInfo
+reloaded :: Property DebianLike
reloaded = Service.reloaded "fail2ban"
type Jail = String
-- | By default, fail2ban only enables the ssh jail, but many others
-- are available to be enabled, for example "postfix-sasl"
-jailEnabled :: Jail -> Property NoInfo
+jailEnabled :: Jail -> Property DebianLike
jailEnabled name = jailConfigured name "enabled" "true"
`onChange` reloaded
-- | Configures a jail. For example:
--
-- > jailConfigured "sshd" "port" "2222"
-jailConfigured :: Jail -> IniKey -> String -> Property NoInfo
+jailConfigured :: Jail -> IniKey -> String -> Property UnixLike
jailConfigured name key value =
jailConfFile name `containsIniSetting` (name, key, value)
diff --git a/src/Propellor/Property/File.hs b/src/Propellor/Property/File.hs
index 3021617c..e072fcaa 100644
--- a/src/Propellor/Property/File.hs
+++ b/src/Propellor/Property/File.hs
@@ -9,14 +9,14 @@ import System.Exit
type Line = String
-- | Replaces all the content of a file.
-hasContent :: FilePath -> [Line] -> Property NoInfo
+hasContent :: FilePath -> [Line] -> Property UnixLike
f `hasContent` newcontent = fileProperty
("replace " ++ f)
(\_oldcontent -> newcontent) f
-- | Replaces all the content of a file, ensuring that its modes do not
-- allow it to be read or written by anyone other than the current user
-hasContentProtected :: FilePath -> [Line] -> Property NoInfo
+hasContentProtected :: FilePath -> [Line] -> Property UnixLike
f `hasContentProtected` newcontent = fileProperty' writeFileProtected
("replace " ++ f)
(\_oldcontent -> newcontent) f
@@ -25,38 +25,38 @@ f `hasContentProtected` newcontent = fileProperty' writeFileProtected
--
-- The file's permissions are preserved if the file already existed.
-- Otherwise, they're set to 600.
-hasPrivContent :: IsContext c => FilePath -> c -> Property HasInfo
+hasPrivContent :: IsContext c => FilePath -> c -> Property (HasInfo + UnixLike)
hasPrivContent f = hasPrivContentFrom (PrivDataSourceFile (PrivFile f) f) f
-- | Like hasPrivContent, but allows specifying a source
-- for PrivData, rather than using PrivDataSourceFile .
-hasPrivContentFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property HasInfo
+hasPrivContentFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property (HasInfo + UnixLike)
hasPrivContentFrom = hasPrivContent' writeFileProtected
-- | Leaves the file at its default or current mode,
-- allowing "private" data to be read.
--
-- Use with caution!
-hasPrivContentExposed :: IsContext c => FilePath -> c -> Property HasInfo
+hasPrivContentExposed :: IsContext c => FilePath -> c -> Property (HasInfo + UnixLike)
hasPrivContentExposed f = hasPrivContentExposedFrom (PrivDataSourceFile (PrivFile f) f) f
-hasPrivContentExposedFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property HasInfo
+hasPrivContentExposedFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property (HasInfo + UnixLike)
hasPrivContentExposedFrom = hasPrivContent' writeFile
-hasPrivContent' :: (IsContext c, IsPrivDataSource s) => (FilePath -> String -> IO ()) -> s -> FilePath -> c -> Property HasInfo
+hasPrivContent' :: (IsContext c, IsPrivDataSource s) => (FilePath -> String -> IO ()) -> s -> FilePath -> c -> Property (HasInfo + UnixLike)
hasPrivContent' writer source f context =
withPrivData source context $ \getcontent ->
- property desc $ getcontent $ \privcontent ->
- ensureProperty $ fileProperty' writer desc
+ property' desc $ \o -> getcontent $ \privcontent ->
+ ensureProperty o $ fileProperty' writer desc
(\_oldcontent -> privDataLines privcontent) f
where
desc = "privcontent " ++ f
-- | Ensures that a line is present in a file, adding it to the end if not.
-containsLine :: FilePath -> Line -> Property NoInfo
+containsLine :: FilePath -> Line -> Property UnixLike
f `containsLine` l = f `containsLines` [l]
-containsLines :: FilePath -> [Line] -> Property NoInfo
+containsLines :: FilePath -> [Line] -> Property UnixLike
f `containsLines` ls = fileProperty (f ++ " contains:" ++ show ls) go f
where
go content = content ++ filter (`notElem` content) ls
@@ -64,27 +64,28 @@ f `containsLines` ls = fileProperty (f ++ " contains:" ++ show ls) go f
-- | Ensures that a line is not present in a file.
-- Note that the file is ensured to exist, so if it doesn't, an empty
-- file will be written.
-lacksLine :: FilePath -> Line -> Property NoInfo
+lacksLine :: FilePath -> Line -> Property UnixLike
f `lacksLine` l = fileProperty (f ++ " remove: " ++ l) (filter (/= l)) f
-lacksLines :: FilePath -> [Line] -> Property NoInfo
+lacksLines :: FilePath -> [Line] -> Property UnixLike
f `lacksLines` ls = fileProperty (f ++ " remove: " ++ show [ls]) (filter (`notElem` ls)) f
-- | Replaces the content of a file with the transformed content of another file
-basedOn :: FilePath -> (FilePath, [Line] -> [Line]) -> Property NoInfo
-f `basedOn` (f', a) = property desc $ go =<< (liftIO $ readFile f')
+basedOn :: FilePath -> (FilePath, [Line] -> [Line]) -> Property UnixLike
+f `basedOn` (f', a) = property' desc $ \o -> do
+ tmpl <- liftIO $ readFile f'
+ ensureProperty o $ fileProperty desc (\_ -> a $ lines $ tmpl) f
where
desc = "replace " ++ f
- go tmpl = ensureProperty $ fileProperty desc (\_ -> a $ lines $ tmpl) f
-- | Removes a file. Does not remove symlinks or non-plain-files.
-notPresent :: FilePath -> Property NoInfo
+notPresent :: FilePath -> Property UnixLike
notPresent f = check (doesFileExist f) $ property (f ++ " not present") $
makeChange $ nukeFile f
-fileProperty :: Desc -> ([Line] -> [Line]) -> FilePath -> Property NoInfo
+fileProperty :: Desc -> ([Line] -> [Line]) -> FilePath -> Property UnixLike
fileProperty = fileProperty' writeFile
-fileProperty' :: (FilePath -> String -> IO ()) -> Desc -> ([Line] -> [Line]) -> FilePath -> Property NoInfo
+fileProperty' :: (FilePath -> String -> IO ()) -> Desc -> ([Line] -> [Line]) -> FilePath -> Property UnixLike
fileProperty' writer desc a f = property desc $ go =<< liftIO (doesFileExist f)
where
go True = do
@@ -103,7 +104,7 @@ fileProperty' writer desc a f = property desc $ go =<< liftIO (doesFileExist f)
setOwnerAndGroup f' (fileOwner s) (fileGroup s)
-- | Ensures a directory exists.
-dirExists :: FilePath -> Property NoInfo
+dirExists :: FilePath -> Property UnixLike
dirExists d = check (not <$> doesDirectoryExist d) $ property (d ++ " exists") $
makeChange $ createDirectoryIfMissing True d
@@ -113,7 +114,7 @@ newtype LinkTarget = LinkTarget FilePath
-- | Creates or atomically updates a symbolic link.
--
-- Does not overwrite regular files or directories.
-isSymlinkedTo :: FilePath -> LinkTarget -> Property NoInfo
+isSymlinkedTo :: FilePath -> LinkTarget -> Property UnixLike
link `isSymlinkedTo` (LinkTarget target) = property desc $
go =<< (liftIO $ tryIO $ getSymbolicLinkStatus link)
where
@@ -135,7 +136,7 @@ link `isSymlinkedTo` (LinkTarget target) = property desc $
updateLink = createSymbolicLink target `viaStableTmp` link
-- | Ensures that a file is a copy of another (regular) file.
-isCopyOf :: FilePath -> FilePath -> Property NoInfo
+isCopyOf :: FilePath -> FilePath -> Property UnixLike
f `isCopyOf` f' = property desc $ go =<< (liftIO $ tryIO $ getFileStatus f')
where
desc = f ++ " is copy of " ++ f'
@@ -156,7 +157,7 @@ f `isCopyOf` f' = property desc $ go =<< (liftIO $ tryIO $ getFileStatus f')
[Param "--preserve=all", Param "--", File src, File dest]
-- | Ensures that a file/dir has the specified owner and group.
-ownerGroup :: FilePath -> User -> Group -> Property NoInfo
+ownerGroup :: FilePath -> User -> Group -> Property UnixLike
ownerGroup f (User owner) (Group group) = p `describe` (f ++ " owner " ++ og)
where
p = cmdProperty "chown" [og, f]
@@ -164,7 +165,7 @@ ownerGroup f (User owner) (Group group) = p `describe` (f ++ " owner " ++ og)
og = owner ++ ":" ++ group
-- | Ensures that a file/dir has the specfied mode.
-mode :: FilePath -> FileMode -> Property NoInfo
+mode :: FilePath -> FileMode -> Property UnixLike
mode f v = p `changesFile` f
where
p = property (f ++ " mode " ++ show v) $ do
diff --git a/src/Propellor/Property/Firewall.hs b/src/Propellor/Property/Firewall.hs
index fa1f95d4..ce0befcd 100644
--- a/src/Propellor/Property/Firewall.hs
+++ b/src/Propellor/Property/Firewall.hs
@@ -26,10 +26,10 @@ import Propellor.Base
import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.Network as Network
-installed :: Property NoInfo
+installed :: Property DebianLike
installed = Apt.installed ["iptables"]
-rule :: Chain -> Table -> Target -> Rules -> Property NoInfo
+rule :: Chain -> Table -> Target -> Rules -> Property Linux
rule c tb tg rs = property ("firewall rule: " <> show r) addIpTable
where
r = Rule c tb tg rs
diff --git a/src/Propellor/Property/FreeBSD/Pkg.hs b/src/Propellor/Property/FreeBSD/Pkg.hs
index 6bbd2570..704c1db9 100644
--- a/src/Propellor/Property/FreeBSD/Pkg.hs
+++ b/src/Propellor/Property/FreeBSD/Pkg.hs
@@ -22,8 +22,8 @@ runPkg cmd args =
in
lines <$> readProcess p a
-pkgCmdProperty :: String -> [String] -> UncheckedProperty NoInfo
-pkgCmdProperty cmd args =
+pkgCmdProperty :: String -> [String] -> UncheckedProperty FreeBSD
+pkgCmdProperty cmd args = tightenTargets $
let
(p, a) = pkgCommand cmd args
in
@@ -44,13 +44,14 @@ instance IsInfo PkgUpdate where
pkgUpdated :: PkgUpdate -> Bool
pkgUpdated (PkgUpdate _) = True
-update :: Property HasInfo
+update :: Property (HasInfo + FreeBSD)
update =
let
upd = pkgCmd "update" []
go = ifM (pkgUpdated <$> askInfo) ((noChange), (liftIO upd >> return MadeChange))
in
- infoProperty "pkg update has run" go (addInfo mempty (PkgUpdate "")) []
+ (property "pkg update has run" go :: Property FreeBSD)
+ `setInfoProperty` (toInfo (PkgUpdate ""))
newtype PkgUpgrade = PkgUpgrade String
deriving (Typeable, Monoid, Show)
@@ -60,17 +61,19 @@ instance IsInfo PkgUpgrade where
pkgUpgraded :: PkgUpgrade -> Bool
pkgUpgraded (PkgUpgrade _) = True
-upgrade :: Property HasInfo
+upgrade :: Property (HasInfo + FreeBSD)
upgrade =
let
upd = pkgCmd "upgrade" []
go = ifM (pkgUpgraded <$> askInfo) ((noChange), (liftIO upd >> return MadeChange))
in
- infoProperty "pkg upgrade has run" go (addInfo mempty (PkgUpgrade "")) [] `requires` update
+ (property "pkg upgrade has run" go :: Property FreeBSD)
+ `setInfoProperty` (toInfo (PkgUpdate ""))
+ `requires` update
type Package = String
-installed :: Package -> Property NoInfo
+installed :: Package -> Property FreeBSD
installed pkg = check (isInstallable pkg) $ pkgCmdProperty "install" [pkg]
isInstallable :: Package -> IO Bool
diff --git a/src/Propellor/Property/FreeBSD/Poudriere.hs b/src/Propellor/Property/FreeBSD/Poudriere.hs
index 5467c668..fcad9e87 100644
--- a/src/Propellor/Property/FreeBSD/Poudriere.hs
+++ b/src/Propellor/Property/FreeBSD/Poudriere.hs
@@ -26,20 +26,23 @@ instance IsInfo PoudriereConfigured where
poudriereConfigured :: PoudriereConfigured -> Bool
poudriereConfigured (PoudriereConfigured _) = True
-setConfigured :: Property HasInfo
-setConfigured = pureInfoProperty "Poudriere Configured" (PoudriereConfigured "")
+setConfigured :: Property (HasInfo + FreeBSD)
+setConfigured = tightenTargets $
+ pureInfoProperty "Poudriere Configured" (PoudriereConfigured "")
-poudriere :: Poudriere -> Property HasInfo
+poudriere :: Poudriere -> Property (HasInfo + FreeBSD)
poudriere conf@(Poudriere _ _ _ _ _ _ zfs) = prop
`requires` Pkg.installed "poudriere"
`before` setConfigured
where
- confProp = File.containsLines poudriereConfigPath (toLines conf)
+ confProp :: Property FreeBSD
+ confProp = tightenTargets $
+ File.containsLines poudriereConfigPath (toLines conf)
setZfs (PoudriereZFS z p) = ZFS.zfsSetProperties z p `describe` "Configuring Poudriere with ZFS"
- prop :: CombinedType (Property NoInfo) (Property NoInfo)
+ prop :: Property FreeBSD
prop
| isJust zfs = ((setZfs $ fromJust zfs) `before` confProp)
- | otherwise = propertyList "Configuring Poudriere without ZFS" [confProp]
+ | otherwise = confProp `describe` "Configuring Poudriere without ZFS"
poudriereCommand :: String -> [String] -> (String, [String])
poudriereCommand cmd args = ("poudriere", cmd:args)
@@ -58,8 +61,8 @@ listJails = mapMaybe (headMaybe . take 1 . words)
jailExists :: Jail -> IO Bool
jailExists (Jail name _ _) = isInfixOf [name] <$> listJails
-jail :: Jail -> Property NoInfo
-jail j@(Jail name version arch) =
+jail :: Jail -> Property FreeBSD
+jail j@(Jail name version arch) = tightenTargets $
let
chk = do
c <- poudriereConfigured <$> askInfo
@@ -70,7 +73,7 @@ jail j@(Jail name version arch) =
createJail = cmdProperty cmd args
in
check chk createJail
- `describe` unwords ["Create poudriere jail", name]
+ `describe` unwords ["Create poudriere jail", name]
data JailInfo = JailInfo String
diff --git a/src/Propellor/Property/Git.hs b/src/Propellor/Property/Git.hs
index a5ef5ab1..5d7c8b4d 100644
--- a/src/Propellor/Property/Git.hs
+++ b/src/Propellor/Property/Git.hs
@@ -11,7 +11,7 @@ import Data.List
-- using git-daemon, run from inetd.
--
-- Note that reverting this property does not remove or stop inetd.
-daemonRunning :: FilePath -> RevertableProperty NoInfo
+daemonRunning :: FilePath -> RevertableProperty DebianLike DebianLike
daemonRunning exportdir = setup <!> unsetup
where
setup = containsLine conf (mkl "tcp4")
@@ -47,7 +47,7 @@ daemonRunning exportdir = setup <!> unsetup
, exportdir
]
-installed :: Property NoInfo
+installed :: Property DebianLike
installed = Apt.installed ["git"]
type RepoUrl = String
@@ -61,8 +61,8 @@ type Branch = String
-- it will be recursively deleted first.
--
-- A branch can be specified, to check out.
-cloned :: User -> RepoUrl -> FilePath -> Maybe Branch -> Property NoInfo
-cloned owner url dir mbranch = check originurl (property desc checkout)
+cloned :: User -> RepoUrl -> FilePath -> Maybe Branch -> Property DebianLike
+cloned owner url dir mbranch = check originurl go
`requires` installed
where
desc = "git cloned " ++ url ++ " to " ++ dir
@@ -74,12 +74,13 @@ cloned owner url dir mbranch = check originurl (property desc checkout)
return (v /= Just url)
, return True
)
- checkout = do
+ go :: Property DebianLike
+ go = property' desc $ \w -> do
liftIO $ do
whenM (doesDirectoryExist dir) $
removeDirectoryRecursive dir
createDirectoryIfMissing True (takeDirectory dir)
- ensureProperty $ userScriptProperty owner (catMaybes checkoutcmds)
+ ensureProperty w $ userScriptProperty owner (catMaybes checkoutcmds)
`assume` MadeChange
checkoutcmds =
-- The </dev/null fixes an intermittent
@@ -99,8 +100,8 @@ isGitDir dir = isNothing <$> catchMaybeIO (readProcess "git" ["rev-parse", "--re
data GitShared = Shared Group | SharedAll | NotShared
-bareRepo :: FilePath -> User -> GitShared -> Property NoInfo
-bareRepo repo user gitshared = check (isRepo repo) $ propertyList ("git repo: " ++ repo) $
+bareRepo :: FilePath -> User -> GitShared -> Property UnixLike
+bareRepo repo user gitshared = check (isRepo repo) $ propertyList ("git repo: " ++ repo) $ toProps $
dirExists repo : case gitshared of
NotShared ->
[ ownerGroup repo user (userGroup user)
@@ -121,7 +122,7 @@ bareRepo repo user gitshared = check (isRepo repo) $ propertyList ("git repo: "
isRepo repo' = isNothing <$> catchMaybeIO (readProcess "git" ["rev-parse", "--resolve-git-dir", repo'])
-- | Set a key value pair in a git repo's configuration.
-repoConfigured :: FilePath -> (String, String) -> Property NoInfo
+repoConfigured :: FilePath -> (String, String) -> Property UnixLike
repo `repoConfigured` (key, value) = check (not <$> alreadyconfigured) $
userScriptProperty (User "root")
[ "cd " ++ repo
@@ -141,7 +142,7 @@ getRepoConfig repo key = catchDefaultIO [] $
lines <$> readProcess "git" ["-C", repo, "config", key]
-- | Whether a repo accepts non-fast-forward pushes.
-repoAcceptsNonFFs :: FilePath -> RevertableProperty NoInfo
+repoAcceptsNonFFs :: FilePath -> RevertableProperty UnixLike UnixLike
repoAcceptsNonFFs repo = accepts <!> refuses
where
accepts = repoConfigured repo ("receive.denyNonFastForwards", "false")
@@ -152,7 +153,7 @@ repoAcceptsNonFFs repo = accepts <!> refuses
-- | Sets a bare repository's default branch, which will be checked out
-- when cloning it.
-bareRepoDefaultBranch :: FilePath -> String -> Property NoInfo
+bareRepoDefaultBranch :: FilePath -> String -> Property UnixLike
bareRepoDefaultBranch repo branch =
userScriptProperty (User "root")
[ "cd " ++ repo
diff --git a/src/Propellor/Property/Gpg.hs b/src/Propellor/Property/Gpg.hs
index bd710ca7..74e9df5a 100644
--- a/src/Propellor/Property/Gpg.hs
+++ b/src/Propellor/Property/Gpg.hs
@@ -6,7 +6,7 @@ import Utility.FileSystemEncoding
import System.PosixCompat
-installed :: Property NoInfo
+installed :: Property DebianLike
installed = Apt.installed ["gnupg"]
-- A numeric id, or a description of the key, in a form understood by gpg.
@@ -22,11 +22,12 @@ data GpgKeyType = GpgPubKey | GpgPrivKey
--
-- Recommend only using this for low-value dedicated role keys.
-- No attempt has been made to scrub the key out of memory once it's used.
-keyImported :: GpgKeyId -> User -> Property HasInfo
+keyImported :: GpgKeyId -> User -> Property (HasInfo + DebianLike)
keyImported key@(GpgKeyId keyid) user@(User u) = prop
`requires` installed
where
desc = u ++ " has gpg key " ++ show keyid
+ prop :: Property (HasInfo + DebianLike)
prop = withPrivData src (Context keyid) $ \getkey ->
property desc $ getkey $ \key' -> do
let keylines = privDataLines key'
diff --git a/src/Propellor/Property/Group.hs b/src/Propellor/Property/Group.hs
index f91ef1c2..58e49a86 100644
--- a/src/Propellor/Property/Group.hs
+++ b/src/Propellor/Property/Group.hs
@@ -4,7 +4,7 @@ import Propellor.Base
type GID = Int
-exists :: Group -> Maybe GID -> Property NoInfo
+exists :: Group -> Maybe GID -> Property UnixLike
exists (Group group') mgid = check test (cmdProperty "addgroup" (args mgid))
`describe` unwords ["group", group']
where
diff --git a/src/Propellor/Property/Grub.hs b/src/Propellor/Property/Grub.hs
index 1b7f2a0a..a03fc5a0 100644
--- a/src/Propellor/Property/Grub.hs
+++ b/src/Propellor/Property/Grub.hs
@@ -19,20 +19,23 @@ data BIOS = PC | EFI64 | EFI32 | Coreboot | Xen
-- bootloader.
--
-- This includes running update-grub.
-installed :: BIOS -> Property NoInfo
+installed :: BIOS -> Property DebianLike
installed bios = installed' bios `onChange` mkConfig
-- Run update-grub, to generate the grub boot menu. It will be
-- automatically updated when kernel packages are installed.
-mkConfig :: Property NoInfo
-mkConfig = cmdProperty "update-grub" []
+mkConfig :: Property DebianLike
+mkConfig = tightenTargets $ cmdProperty "update-grub" []
`assume` MadeChange
-- | Installs grub; does not run update-grub.
-installed' :: BIOS -> Property NoInfo
-installed' bios = Apt.installed [pkg] `describe` "grub package installed"
+installed' :: BIOS -> Property Linux
+installed' bios = (aptinstall `pickOS` unsupportedOS)
+ `describe` "grub package installed"
where
- pkg = case bios of
+ aptinstall :: Property DebianLike
+ aptinstall = Apt.installed [debpkg]
+ debpkg = case bios of
PC -> "grub-pc"
EFI64 -> "grub-efi-amd64"
EFI32 -> "grub-efi-ia32"
@@ -48,8 +51,8 @@ installed' bios = Apt.installed [pkg] `describe` "grub package installed"
-- on the device; it always does the work to reinstall it. It's a good idea
-- to arrange for this property to only run once, by eg making it be run
-- onChange after OS.cleanInstallOnce.
-boots :: OSDevice -> Property NoInfo
-boots dev = cmdProperty "grub-install" [dev]
+boots :: OSDevice -> Property Linux
+boots dev = tightenTargets $ cmdProperty "grub-install" [dev]
`assume` MadeChange
`describe` ("grub boots " ++ dev)
@@ -61,10 +64,10 @@ boots dev = cmdProperty "grub-install" [dev]
--
-- The rootdev should be in the form "hd0", while the bootdev is in the form
-- "xen/xvda".
-chainPVGrub :: GrubDevice -> GrubDevice -> TimeoutSecs -> Property NoInfo
-chainPVGrub rootdev bootdev timeout = combineProperties desc
- [ File.dirExists "/boot/grub"
- , "/boot/grub/menu.lst" `File.hasContent`
+chainPVGrub :: GrubDevice -> GrubDevice -> TimeoutSecs -> Property DebianLike
+chainPVGrub rootdev bootdev timeout = combineProperties desc $ props
+ & File.dirExists "/boot/grub"
+ & "/boot/grub/menu.lst" `File.hasContent`
[ "default 1"
, "timeout " ++ show timeout
, ""
@@ -73,12 +76,12 @@ chainPVGrub rootdev bootdev timeout = combineProperties desc
, "kernel /boot/xen-shim"
, "boot"
]
- , "/boot/load.cf" `File.hasContent`
+ & "/boot/load.cf" `File.hasContent`
[ "configfile (" ++ bootdev ++ ")/boot/grub/grub.cfg" ]
- , installed Xen
- , flip flagFile "/boot/xen-shim" $ scriptProperty ["grub-mkimage --prefix '(" ++ bootdev ++ ")/boot/grub' -c /boot/load.cf -O x86_64-xen /usr/lib/grub/x86_64-xen/*.mod > /boot/xen-shim"]
- `assume` MadeChange
- `describe` "/boot-xen-shim"
- ]
+ & installed Xen
+ & flip flagFile "/boot/xen-shim" xenshim
where
desc = "chain PV-grub"
+ xenshim = scriptProperty ["grub-mkimage --prefix '(" ++ bootdev ++ ")/boot/grub' -c /boot/load.cf -O x86_64-xen /usr/lib/grub/x86_64-xen/*.mod > /boot/xen-shim"]
+ `assume` MadeChange
+ `describe` "/boot-xen-shim"
diff --git a/src/Propellor/Property/HostingProvider/CloudAtCost.hs b/src/Propellor/Property/HostingProvider/CloudAtCost.hs
index bfe3ae17..5c4788e2 100644
--- a/src/Propellor/Property/HostingProvider/CloudAtCost.hs
+++ b/src/Propellor/Property/HostingProvider/CloudAtCost.hs
@@ -6,19 +6,24 @@ import qualified Propellor.Property.File as File
import qualified Propellor.Property.User as User
-- Clean up a system as installed by cloudatcost.com
-decruft :: Property NoInfo
-decruft = propertyList "cloudatcost cleanup"
- [ Hostname.sane
- , "worked around grub/lvm boot bug #743126" ==>
+decruft :: Property DebianLike
+decruft = propertyList "cloudatcost cleanup" $ props
+ & Hostname.sane
+ & grubbugfix
+ & nukecruft
+ where
+ grubbugfix :: Property DebianLike
+ grubbugfix = tightenTargets $
"/etc/default/grub" `File.containsLine` "GRUB_DISABLE_LINUX_UUID=true"
- `onChange` (cmdProperty "update-grub" [] `assume` MadeChange)
- `onChange` (cmdProperty "update-initramfs" ["-u"] `assume` MadeChange)
- , combineProperties "nuked cloudatcost cruft"
- [ File.notPresent "/etc/rc.local"
- , File.notPresent "/etc/init.d/S97-setup.sh"
- , File.notPresent "/zang-debian.sh"
- , File.notPresent "/bin/npasswd"
- , User.nuked (User "user") User.YesReallyDeleteHome
- ]
- ]
+ `describe` "worked around grub/lvm boot bug #743126"
+ `onChange` (cmdProperty "update-grub" [] `assume` MadeChange)
+ `onChange` (cmdProperty "update-initramfs" ["-u"] `assume` MadeChange)
+ nukecruft :: Property Linux
+ nukecruft = tightenTargets $
+ combineProperties "nuked cloudatcost cruft" $ props
+ & File.notPresent "/etc/rc.local"
+ & File.notPresent "/etc/init.d/S97-setup.sh"
+ & File.notPresent "/zang-debian.sh"
+ & File.notPresent "/bin/npasswd"
+ & User.nuked (User "user") User.YesReallyDeleteHome
diff --git a/src/Propellor/Property/HostingProvider/DigitalOcean.hs b/src/Propellor/Property/HostingProvider/DigitalOcean.hs
index f49b86b3..c1e0ffc9 100644
--- a/src/Propellor/Property/HostingProvider/DigitalOcean.hs
+++ b/src/Propellor/Property/HostingProvider/DigitalOcean.hs
@@ -18,16 +18,15 @@ import Data.List
-- If the power is cycled, the non-distro kernel still boots up.
-- So, this property also checks if the running kernel is present in /boot,
-- and if not, reboots immediately into a distro kernel.
-distroKernel :: Property NoInfo
-distroKernel = propertyList "digital ocean distro kernel hack"
- [ Apt.installed ["grub-pc", "kexec-tools", "file"]
- , "/etc/default/kexec" `File.containsLines`
+distroKernel :: Property DebianLike
+distroKernel = propertyList "digital ocean distro kernel hack" $ props
+ & Apt.installed ["grub-pc", "kexec-tools", "file"]
+ & "/etc/default/kexec" `File.containsLines`
[ "LOAD_KEXEC=true"
, "USE_GRUB_CONFIG=true"
] `describe` "kexec configured"
- , check (not <$> runningInstalledKernel) Reboot.now
+ & check (not <$> runningInstalledKernel) Reboot.now
`describe` "running installed kernel"
- ]
runningInstalledKernel :: IO Bool
runningInstalledKernel = do
diff --git a/src/Propellor/Property/HostingProvider/Linode.hs b/src/Propellor/Property/HostingProvider/Linode.hs
index 274412a0..71719d87 100644
--- a/src/Propellor/Property/HostingProvider/Linode.hs
+++ b/src/Propellor/Property/HostingProvider/Linode.hs
@@ -8,12 +8,13 @@ import Utility.FileMode
-- | Linode's pv-grub-x86_64 does not currently support booting recent
-- Debian kernels compressed with xz. This sets up pv-grub chaining to enable
-- it.
-chainPVGrub :: Grub.TimeoutSecs -> Property NoInfo
+chainPVGrub :: Grub.TimeoutSecs -> Property DebianLike
chainPVGrub = Grub.chainPVGrub "hd0" "xen/xvda"
-- | Linode disables mlocate's cron job's execute permissions,
-- presumably to avoid disk IO. This ensures it's executable.
-mlocateEnabled :: Property NoInfo
-mlocateEnabled = "/etc/cron.daily/mlocate"
- `File.mode` combineModes (readModes ++ executeModes)
+mlocateEnabled :: Property DebianLike
+mlocateEnabled = tightenTargets $
+ "/etc/cron.daily/mlocate"
+ `File.mode` combineModes (readModes ++ executeModes)
diff --git a/src/Propellor/Property/Hostname.hs b/src/Propellor/Property/Hostname.hs
index 7ab350ae..e1342d91 100644
--- a/src/Propellor/Property/Hostname.hs
+++ b/src/Propellor/Property/Hostname.hs
@@ -22,20 +22,20 @@ import Data.List.Utils
-- Also, the </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 NoInfo
+sane :: Property UnixLike
sane = sane' extractDomain
-sane' :: ExtractDomain -> Property NoInfo
-sane' extractdomain = property ("sane hostname") $
- ensureProperty . setTo' extractdomain =<< asks hostName
+sane' :: ExtractDomain -> Property UnixLike
+sane' extractdomain = property' ("sane hostname") $ \w ->
+ ensureProperty w . setTo' extractdomain =<< asks hostName
-- Like `sane`, but you can specify the hostname to use, instead
-- of the default hostname of the `Host`.
-setTo :: HostName -> Property NoInfo
+setTo :: HostName -> Property UnixLike
setTo = setTo' extractDomain
-setTo' :: ExtractDomain -> HostName -> Property NoInfo
-setTo' extractdomain hn = combineProperties desc
+setTo' :: ExtractDomain -> HostName -> Property UnixLike
+setTo' extractdomain hn = combineProperties desc $ toProps
[ "/etc/hostname" `File.hasContent` [basehost]
, hostslines $ catMaybes
[ if null domain
@@ -65,11 +65,12 @@ setTo' extractdomain hn = combineProperties desc
-- | Makes </etc/resolv.conf> contain search and domain lines for
-- the domain that the hostname is in.
-searchDomain :: Property NoInfo
+searchDomain :: Property UnixLike
searchDomain = searchDomain' extractDomain
-searchDomain' :: ExtractDomain -> Property NoInfo
-searchDomain' extractdomain = property desc (ensureProperty . go =<< asks hostName)
+searchDomain' :: ExtractDomain -> Property UnixLike
+searchDomain' extractdomain = property' desc $ \w ->
+ (ensureProperty w . go =<< asks hostName)
where
desc = "resolv.conf search and domain configured"
go hn =
diff --git a/src/Propellor/Property/Journald.hs b/src/Propellor/Property/Journald.hs
index 2fbb780e..d0261626 100644
--- a/src/Propellor/Property/Journald.hs
+++ b/src/Propellor/Property/Journald.hs
@@ -5,7 +5,7 @@ import qualified Propellor.Property.Systemd as Systemd
import Utility.DataUnits
-- | Configures journald, restarting it so the changes take effect.
-configured :: Systemd.Option -> String -> Property NoInfo
+configured :: Systemd.Option -> String -> Property Linux
configured option value =
Systemd.configured "/etc/systemd/journald.conf" option value
`onChange` Systemd.restarted "systemd-journald"
@@ -14,28 +14,28 @@ configured option value =
-- Examples: "100 megabytes" or "0.5tb"
type DataSize = String
-configuredSize :: Systemd.Option -> DataSize -> Property NoInfo
+configuredSize :: Systemd.Option -> DataSize -> Property Linux
configuredSize option s = case readSize dataUnits s of
Just sz -> configured option (systemdSizeUnits sz)
Nothing -> property ("unable to parse " ++ option ++ " data size " ++ s) $
return FailedChange
-systemMaxUse :: DataSize -> Property NoInfo
+systemMaxUse :: DataSize -> Property Linux
systemMaxUse = configuredSize "SystemMaxUse"
-runtimeMaxUse :: DataSize -> Property NoInfo
+runtimeMaxUse :: DataSize -> Property Linux
runtimeMaxUse = configuredSize "RuntimeMaxUse"
-systemKeepFree :: DataSize -> Property NoInfo
+systemKeepFree :: DataSize -> Property Linux
systemKeepFree = configuredSize "SystemKeepFree"
-runtimeKeepFree :: DataSize -> Property NoInfo
+runtimeKeepFree :: DataSize -> Property Linux
runtimeKeepFree = configuredSize "RuntimeKeepFree"
-systemMaxFileSize :: DataSize -> Property NoInfo
+systemMaxFileSize :: DataSize -> Property Linux
systemMaxFileSize = configuredSize "SystemMaxFileSize"
-runtimeMaxFileSize :: DataSize -> Property NoInfo
+runtimeMaxFileSize :: DataSize -> Property Linux
runtimeMaxFileSize = configuredSize "RuntimeMaxFileSize"
-- Generates size units as used in journald.conf.
diff --git a/src/Propellor/Property/Kerberos.hs b/src/Propellor/Property/Kerberos.hs
index cb6e06cc..3c351943 100644
--- a/src/Propellor/Property/Kerberos.hs
+++ b/src/Propellor/Property/Kerberos.hs
@@ -34,25 +34,25 @@ keyTabPath = maybe defaultKeyTab id
principal :: String -> Maybe String -> Maybe Realm -> Principal
principal p i r = p ++ maybe "" ("/"++) i ++ maybe "" ("@" ++) r
-installed :: Property NoInfo
+installed :: Property DebianLike
installed = Apt.installed ["krb5-user"]
-kdcInstalled :: Property NoInfo
+kdcInstalled :: Property DebianLike
kdcInstalled = Apt.serviceInstalledRunning "krb5-kdc"
-adminServerInstalled :: Property NoInfo
+adminServerInstalled :: Property DebianLike
adminServerInstalled = Apt.serviceInstalledRunning "krb5-admin-server"
-kpropServerInstalled :: Property HasInfo
+kpropServerInstalled :: Property DebianLike
kpropServerInstalled = propertyList "kprop server installed" $ props
& kdcInstalled
& Apt.installed ["openbsd-inetd"]
& "/etc/inetd.conf" `File.containsLines`
- [ "krb5_prop\tstream\ttcp\tnowait\troot\t/usr/sbin/kpropd kpropd"
- , "krb5_prop\tstream\ttcp6\tnowait\troot\t/usr/sbin/kpropd kpropd"
- ]
+ [ "krb5_prop\tstream\ttcp\tnowait\troot\t/usr/sbin/kpropd kpropd"
+ , "krb5_prop\tstream\ttcp6\tnowait\troot\t/usr/sbin/kpropd kpropd"
+ ]
-kpropAcls :: [String] -> Property NoInfo
+kpropAcls :: [String] -> Property UnixLike
kpropAcls ps = kpropdAclPath `File.hasContent` ps `describe` "kprop server ACLs"
k5srvutil :: (Maybe FilePath) -> [String] -> IO String
@@ -82,13 +82,14 @@ k5loginPath user = do
h <- homedir user
return $ h </> ".k5login"
-k5login :: User -> [Principal] -> Property NoInfo
-k5login user@(User u) ps = property (u ++ " has k5login") $ do
+k5login :: User -> [Principal] -> Property UnixLike
+k5login user@(User u) ps = property' desc $ \w -> do
f <- liftIO $ k5loginPath user
liftIO $ do
createDirectoryIfMissing True (takeDirectory f)
writeFile f (unlines ps)
- ensureProperties
- [ File.ownerGroup f user (userGroup user)
- , File.ownerGroup (takeDirectory f) user (userGroup user)
- ]
+ ensureProperty w $ combineProperties desc $ props
+ & File.ownerGroup f user (userGroup user)
+ & File.ownerGroup (takeDirectory f) user (userGroup user)
+ where
+ desc = u ++ " has k5login"
diff --git a/src/Propellor/Property/LetsEncrypt.hs b/src/Propellor/Property/LetsEncrypt.hs
index d5528c64..bf38046b 100644
--- a/src/Propellor/Property/LetsEncrypt.hs
+++ b/src/Propellor/Property/LetsEncrypt.hs
@@ -7,7 +7,7 @@ import qualified Propellor.Property.Apt as Apt
import System.Posix.Files
-installed :: Property NoInfo
+installed :: Property DebianLike
installed = Apt.installed ["letsencrypt"]
-- | Tell the letsencrypt client that you agree with the Let's Encrypt
@@ -39,15 +39,16 @@ type WebRoot = FilePath
--
-- See `Propellor.Property.Apache.httpsVirtualHost` for a more complete
-- integration of apache with letsencrypt, that's built on top of this.
-letsEncrypt :: AgreeTOS -> Domain -> WebRoot -> Property NoInfo
+letsEncrypt :: AgreeTOS -> Domain -> WebRoot -> Property DebianLike
letsEncrypt tos domain = letsEncrypt' tos domain []
-- | Like `letsEncrypt`, but the certificate can be obtained for multiple
-- domains.
-letsEncrypt' :: AgreeTOS -> Domain -> [Domain] -> WebRoot -> Property NoInfo
+letsEncrypt' :: AgreeTOS -> Domain -> [Domain] -> WebRoot -> Property DebianLike
letsEncrypt' (AgreeTOS memail) domain domains webroot =
prop `requires` installed
where
+ prop :: Property UnixLike
prop = property desc $ do
startstats <- liftIO getstats
(transcript, ok) <- liftIO $
diff --git a/src/Propellor/Property/LightDM.hs b/src/Propellor/Property/LightDM.hs
index 75e3b19a..339fa9a3 100644
--- a/src/Propellor/Property/LightDM.hs
+++ b/src/Propellor/Property/LightDM.hs
@@ -1,5 +1,3 @@
-{-# LANGUAGE FlexibleInstances #-}
-
-- | Maintainer: Sean Whitton <spwhitton@spwhitton.name>
module Propellor.Property.LightDM where
@@ -8,11 +6,11 @@ import Propellor.Base
import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.ConfFile as ConfFile
-installed :: Property NoInfo
+installed :: Property DebianLike
installed = Apt.installed ["lightdm"]
-- | Configures LightDM to skip the login screen and autologin as a user.
-autoLogin :: User -> Property NoInfo
+autoLogin :: User -> Property UnixLike
autoLogin (User u) = "/etc/lightdm/lightdm.conf" `ConfFile.containsIniSetting`
("SeatDefaults", "autologin-user", u)
`describe` "lightdm autologin"
diff --git a/src/Propellor/Property/List.hs b/src/Propellor/Property/List.hs
index 74aa6ca6..0eec04c7 100644
--- a/src/Propellor/Property/List.hs
+++ b/src/Propellor/Property/List.hs
@@ -1,86 +1,59 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
module Propellor.Property.List (
props,
- PropertyList(..),
- PropertyListType,
- PropList(..),
+ Props,
+ toProps,
+ propertyList,
+ combineProperties,
) where
import Propellor.Types
-import Propellor.Engine
+import Propellor.Types.Core
+import Propellor.Types.MetaTypes
import Propellor.PropAccum
+import Propellor.Engine
+import Propellor.Exception
import Data.Monoid
--- | Starts accumulating a list of properties.
+toProps :: [Property (MetaTypes metatypes)] -> Props (MetaTypes metatypes)
+toProps ps = Props (map toChildProperty ps)
+
+-- | Combines a list of properties, resulting in a single property
+-- that when run will run each property in the list in turn,
+-- and print out the description of each as it's run. Does not stop
+-- on failure; does propagate overall success/failure.
+--
+-- For example:
--
-- > propertyList "foo" $ props
--- > & someproperty
--- > ! oldproperty
--- > & otherproperty
-props :: PropList
-props = PropList []
-
-data PropList = PropList [Property HasInfo]
-
-instance PropAccum PropList where
- PropList l `addProp` p = PropList (toProp p : l)
- PropList l `addPropFront` p = PropList (l ++ [toProp p])
- getProperties (PropList l) = reverse l
-
-class PropertyList l where
- -- | Combines a list of properties, resulting in a single property
- -- that when run will run each property in the list in turn,
- -- and print out the description of each as it's run. Does not stop
- -- on failure; does propagate overall success/failure.
- --
- -- Note that Property HasInfo and Property NoInfo are not the same
- -- type, and so cannot be mixed in a list. To make a list of
- -- mixed types, which can also include RevertableProperty,
- -- use `props`
- propertyList :: Desc -> l -> Property (PropertyListType l)
-
- -- | Combines a list of properties, resulting in one property that
- -- ensures each in turn. Stops if a property fails.
- combineProperties :: Desc -> l -> Property (PropertyListType l)
-
--- | Type level function to calculate whether a PropertyList has Info.
-type family PropertyListType t
-type instance PropertyListType [Property HasInfo] = HasInfo
-type instance PropertyListType [Property NoInfo] = NoInfo
-type instance PropertyListType [RevertableProperty NoInfo] = NoInfo
-type instance PropertyListType [RevertableProperty HasInfo] = HasInfo
-type instance PropertyListType PropList = HasInfo
-
-instance PropertyList [Property NoInfo] where
- propertyList desc ps = simpleProperty desc (ensureProperties ps) ps
- combineProperties desc ps = simpleProperty desc (combineSatisfy ps NoChange) ps
-
-instance PropertyList [Property HasInfo] where
- -- It's ok to use ignoreInfo here, because the ps are made the
- -- child properties of the property, and so their info is visible
- -- that way.
- propertyList desc ps = infoProperty desc (ensureProperties $ map ignoreInfo ps) mempty ps
- combineProperties desc ps = infoProperty desc (combineSatisfy ps NoChange) mempty ps
-
-instance PropertyList [RevertableProperty HasInfo] where
- propertyList desc ps = propertyList desc (map setupRevertableProperty ps)
- combineProperties desc ps = combineProperties desc (map setupRevertableProperty ps)
-
-instance PropertyList [RevertableProperty NoInfo] where
- propertyList desc ps = propertyList desc (map setupRevertableProperty ps)
- combineProperties desc ps = combineProperties desc (map setupRevertableProperty ps)
-
-instance PropertyList PropList where
- propertyList desc = propertyList desc . getProperties
- combineProperties desc = combineProperties desc . getProperties
-
-combineSatisfy :: [Property i] -> Result -> Propellor Result
+-- > & bar
+-- > & baz
+propertyList :: SingI metatypes => Desc -> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes)
+propertyList desc (Props ps) =
+ property desc (ensureChildProperties cs)
+ `addChildren` cs
+ where
+ cs = map toChildProperty ps
+
+-- | Combines a list of properties, resulting in one property that
+-- ensures each in turn. Stops if a property fails.
+combineProperties :: SingI metatypes => Desc -> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes)
+combineProperties desc (Props ps) =
+ property desc (combineSatisfy cs NoChange)
+ `addChildren` cs
+ where
+ cs = map toChildProperty ps
+
+combineSatisfy :: [ChildProperty] -> Result -> Propellor Result
combineSatisfy [] rs = return rs
-combineSatisfy (l:ls) rs = do
- r <- ensureProperty $ ignoreInfo l
+combineSatisfy (p:ps) rs = do
+ r <- catchPropellor $ getSatisfy p
case r of
FailedChange -> return FailedChange
- _ -> combineSatisfy ls (r <> rs)
+ _ -> combineSatisfy ps (r <> rs)
diff --git a/src/Propellor/Property/Locale.hs b/src/Propellor/Property/Locale.hs
index 06cd63ad..b7cf242c 100644
--- a/src/Propellor/Property/Locale.hs
+++ b/src/Propellor/Property/Locale.hs
@@ -21,14 +21,17 @@ type LocaleVariable = String
--
-- Note that reverting this property does not make a locale unavailable. That's
-- because it might be required for other Locale.selectedFor statements.
-selectedFor :: Locale -> [LocaleVariable] -> RevertableProperty NoInfo
+selectedFor :: Locale -> [LocaleVariable] -> RevertableProperty DebianLike DebianLike
locale `selectedFor` vars = select <!> deselect
where
- select = check (not <$> isselected) (cmdProperty "update-locale" selectArgs)
- `requires` available locale
- `describe` (locale ++ " locale selected")
- deselect = check isselected (cmdProperty "update-locale" vars)
- `describe` (locale ++ " locale deselected")
+ select = tightenTargets $
+ check (not <$> isselected)
+ (cmdProperty "update-locale" selectArgs)
+ `requires` available locale
+ `describe` (locale ++ " locale selected")
+ deselect = tightenTargets $
+ check isselected (cmdProperty "update-locale" vars)
+ `describe` (locale ++ " locale deselected")
selectArgs = zipWith (++) vars (repeat ('=':locale))
isselected = locale `isSelectedFor` vars
@@ -46,20 +49,21 @@ locale `isSelectedFor` vars = do
--
-- Per Debian bug #684134 we cannot ensure a locale is generated by means of
-- Apt.reConfigure. So localeAvailable edits /etc/locale.gen manually.
-available :: Locale -> RevertableProperty NoInfo
-available locale = (ensureAvailable <!> ensureUnavailable)
+available :: Locale -> RevertableProperty DebianLike DebianLike
+available locale = ensureAvailable <!> ensureUnavailable
where
f = "/etc/locale.gen"
desc = (locale ++ " locale generated")
- ensureAvailable =
- property desc $ (lines <$> (liftIO $ readFile f))
- >>= \locales ->
- if locale `presentIn` locales
- then ensureProperty $
- fileProperty desc (foldr uncomment []) f
- `onChange` regenerate
- else return FailedChange -- locale unavailable for generation
- ensureUnavailable =
+ ensureAvailable :: Property DebianLike
+ ensureAvailable = property' desc $ \w -> do
+ locales <- lines <$> (liftIO $ readFile f)
+ if locale `presentIn` locales
+ then ensureProperty w $
+ fileProperty desc (foldr uncomment []) f
+ `onChange` regenerate
+ else return FailedChange -- locale unavailable for generation
+ ensureUnavailable :: Property DebianLike
+ ensureUnavailable = tightenTargets $
fileProperty (locale ++ " locale not generated") (foldr comment []) f
`onChange` regenerate
diff --git a/src/Propellor/Property/Logcheck.hs b/src/Propellor/Property/Logcheck.hs
index 22621cc2..ced9fce2 100644
--- a/src/Propellor/Property/Logcheck.hs
+++ b/src/Propellor/Property/Logcheck.hs
@@ -28,9 +28,9 @@ defaultPrefix = "^\\w{3} [ :[:digit:]]{11} [._[:alnum:]-]+ "
ignoreFilePath :: ReportLevel -> Service -> FilePath
ignoreFilePath t n = "/etc/logcheck/ignore.d." ++ (show t) </> n
-ignoreLines :: ReportLevel -> Service -> [String] -> Property NoInfo
+ignoreLines :: ReportLevel -> Service -> [String] -> Property UnixLike
ignoreLines t n ls = (ignoreFilePath t n) `File.containsLines` ls
`describe` ("logcheck ignore lines for " ++ n ++ "(" ++ (show t) ++ ")")
-installed :: Property NoInfo
+installed :: Property DebianLike
installed = Apt.installed ["logcheck"]
diff --git a/src/Propellor/Property/Mount.hs b/src/Propellor/Property/Mount.hs
index 590cede9..5921755c 100644
--- a/src/Propellor/Property/Mount.hs
+++ b/src/Propellor/Property/Mount.hs
@@ -37,16 +37,17 @@ formatMountOpts (MountOpts []) = "defaults"
formatMountOpts (MountOpts l) = intercalate "," l
-- | Mounts a device.
-mounted :: FsType -> Source -> MountPoint -> MountOpts -> Property NoInfo
+mounted :: FsType -> Source -> MountPoint -> MountOpts -> Property UnixLike
mounted fs src mnt opts = property (mnt ++ " mounted") $
toResult <$> liftIO (mount fs src mnt opts)
-- | Bind mounts the first directory so its contents also appear
-- in the second directory.
-bindMount :: FilePath -> FilePath -> Property NoInfo
-bindMount src dest = cmdProperty "mount" ["--bind", src, dest]
- `assume` MadeChange
- `describe` ("bind mounted " ++ src ++ " to " ++ dest)
+bindMount :: FilePath -> FilePath -> Property Linux
+bindMount src dest = tightenTargets $
+ cmdProperty "mount" ["--bind", src, dest]
+ `assume` MadeChange
+ `describe` ("bind mounted " ++ src ++ " to " ++ dest)
mount :: FsType -> Source -> MountPoint -> MountOpts -> IO Bool
mount fs src mnt opts = boolSystem "mount" $
@@ -66,10 +67,10 @@ newtype SwapPartition = SwapPartition FilePath
-- and its mount options are all automatically probed.
--
-- The SwapPartitions are also included in the generated fstab.
-fstabbed :: [MountPoint] -> [SwapPartition] -> Property NoInfo
-fstabbed mnts swaps = property "fstabbed" $ do
+fstabbed :: [MountPoint] -> [SwapPartition] -> Property Linux
+fstabbed mnts swaps = property' "fstabbed" $ \o -> do
fstab <- liftIO $ genFstab mnts swaps id
- ensureProperty $
+ ensureProperty o $
"/etc/fstab" `File.hasContent` fstab
genFstab :: [MountPoint] -> [SwapPartition] -> (MountPoint -> MountPoint) -> IO [String]
diff --git a/src/Propellor/Property/Munin.hs b/src/Propellor/Property/Munin.hs
index 2464985a..dd74d91b 100644
--- a/src/Propellor/Property/Munin.hs
+++ b/src/Propellor/Property/Munin.hs
@@ -19,19 +19,19 @@ import qualified Propellor.Property.Service as Service
nodePort :: Integer
nodePort = 4949
-nodeInstalled :: Property NoInfo
+nodeInstalled :: Property DebianLike
nodeInstalled = Apt.serviceInstalledRunning "munin-node"
-nodeRestarted :: Property NoInfo
+nodeRestarted :: Property DebianLike
nodeRestarted = Service.restarted "munin-node"
nodeConfPath :: FilePath
nodeConfPath = "/etc/munin/munin-node.conf"
-masterInstalled :: Property NoInfo
+masterInstalled :: Property DebianLike
masterInstalled = Apt.serviceInstalledRunning "munin"
-masterRestarted :: Property NoInfo
+masterRestarted :: Property DebianLike
masterRestarted = Service.restarted "munin"
masterConfPath :: FilePath
diff --git a/src/Propellor/Property/Network.hs b/src/Propellor/Property/Network.hs
index 382f5d9d..9ed9e591 100644
--- a/src/Propellor/Property/Network.hs
+++ b/src/Propellor/Property/Network.hs
@@ -7,8 +7,8 @@ import Data.Char
type Interface = String
-ifUp :: Interface -> Property NoInfo
-ifUp iface = cmdProperty "ifup" [iface]
+ifUp :: Interface -> Property DebianLike
+ifUp iface = tightenTargets $ cmdProperty "ifup" [iface]
`assume` MadeChange
-- | Resets /etc/network/interfaces to a clean and empty state,
@@ -18,8 +18,8 @@ ifUp iface = cmdProperty "ifup" [iface]
-- This can be used as a starting point to defining other interfaces.
--
-- No interfaces are brought up or down by this property.
-cleanInterfacesFile :: Property NoInfo
-cleanInterfacesFile = hasContent interfacesFile
+cleanInterfacesFile :: Property DebianLike
+cleanInterfacesFile = tightenTargets $ hasContent interfacesFile
[ "# Deployed by propellor, do not edit."
, ""
, "source-directory interfaces.d"
@@ -31,8 +31,8 @@ cleanInterfacesFile = hasContent interfacesFile
`describe` ("clean " ++ interfacesFile)
-- | Configures an interface to get its address via dhcp.
-dhcp :: Interface -> Property NoInfo
-dhcp iface = hasContent (interfaceDFile iface)
+dhcp :: Interface -> Property DebianLike
+dhcp iface = tightenTargets $ hasContent (interfaceDFile iface)
[ "auto " ++ iface
, "iface " ++ iface ++ " inet dhcp"
]
@@ -50,18 +50,20 @@ dhcp iface = hasContent (interfaceDFile iface)
--
-- (ipv6 addresses are not included because it's assumed they come up
-- automatically in most situations.)
-static :: Interface -> Property NoInfo
-static iface = check (not <$> doesFileExist f) setup
- `describe` desc
- `requires` interfacesDEnabled
+static :: Interface -> Property DebianLike
+static iface = tightenTargets $
+ check (not <$> doesFileExist f) setup
+ `describe` desc
+ `requires` interfacesDEnabled
where
f = interfaceDFile iface
desc = "static " ++ iface
- setup = property desc $ do
+ setup :: Property DebianLike
+ setup = property' desc $ \o -> do
ls <- liftIO $ lines <$> readProcess "ip"
["-o", "addr", "show", iface, "scope", "global"]
stanzas <- liftIO $ concat <$> mapM mkstanza ls
- ensureProperty $ hasContent f $ ("auto " ++ iface) : stanzas
+ ensureProperty o $ hasContent f $ ("auto " ++ iface) : stanzas
mkstanza ipline = case words ipline of
-- Note that the IP address is written CIDR style, so
-- the netmask does not need to be specified separately.
@@ -81,8 +83,8 @@ static iface = check (not <$> doesFileExist f) setup
_ -> Nothing
-- | 6to4 ipv6 connection, should work anywhere
-ipv6to4 :: Property NoInfo
-ipv6to4 = hasContent (interfaceDFile "sit0")
+ipv6to4 :: Property DebianLike
+ipv6to4 = tightenTargets $ hasContent (interfaceDFile "sit0")
[ "# Deployed by propellor, do not edit."
, "iface sit0 inet6 static"
, "\taddress 2002:5044:5531::1"
@@ -107,6 +109,8 @@ escapeInterfaceDName :: Interface -> FilePath
escapeInterfaceDName = filter (\c -> isAscii c && (isAlphaNum c || c `elem` "_-"))
-- | Ensures that files in the the interfaces.d directory are used.
-interfacesDEnabled :: Property NoInfo
-interfacesDEnabled = containsLine interfacesFile "source-directory interfaces.d"
- `describe` "interfaces.d directory enabled"
+-- interfacesDEnabled :: Property DebianLike
+interfacesDEnabled :: Property DebianLike
+interfacesDEnabled = tightenTargets $
+ containsLine interfacesFile "source-directory interfaces.d"
+ `describe` "interfaces.d directory enabled"
diff --git a/src/Propellor/Property/Nginx.hs b/src/Propellor/Property/Nginx.hs
index 8fb5c49b..e40ba657 100644
--- a/src/Propellor/Property/Nginx.hs
+++ b/src/Propellor/Property/Nginx.hs
@@ -9,7 +9,7 @@ import qualified Propellor.Property.Service as Service
type ConfigFile = [String]
-siteEnabled :: HostName -> ConfigFile -> RevertableProperty NoInfo
+siteEnabled :: HostName -> ConfigFile -> RevertableProperty DebianLike DebianLike
siteEnabled hn cf = enable <!> disable
where
enable = siteVal hn `File.isSymlinkedTo` siteValRelativeCfg hn
@@ -22,11 +22,11 @@ siteEnabled hn cf = enable <!> disable
`requires` installed
`onChange` reloaded
-siteAvailable :: HostName -> ConfigFile -> Property NoInfo
-siteAvailable hn cf = ("nginx site available " ++ hn) ==>
- siteCfg hn `File.hasContent` (comment : cf)
+siteAvailable :: HostName -> ConfigFile -> Property DebianLike
+siteAvailable hn cf = "nginx site available " ++ hn ==> tightenTargets go
where
comment = "# deployed with propellor, do not modify"
+ go = siteCfg hn `File.hasContent` (comment : cf)
siteCfg :: HostName -> FilePath
siteCfg hn = "/etc/nginx/sites-available/" ++ hn
@@ -37,11 +37,11 @@ siteVal hn = "/etc/nginx/sites-enabled/" ++ hn
siteValRelativeCfg :: HostName -> File.LinkTarget
siteValRelativeCfg hn = File.LinkTarget ("../sites-available/" ++ hn)
-installed :: Property NoInfo
+installed :: Property DebianLike
installed = Apt.installed ["nginx"]
-restarted :: Property NoInfo
+restarted :: Property DebianLike
restarted = Service.restarted "nginx"
-reloaded :: Property NoInfo
+reloaded :: Property DebianLike
reloaded = Service.reloaded "nginx"
diff --git a/src/Propellor/Property/OS.hs b/src/Propellor/Property/OS.hs
index e5da0921..5a3ccc70 100644
--- a/src/Propellor/Property/OS.hs
+++ b/src/Propellor/Property/OS.hs
@@ -46,7 +46,7 @@ import Control.Exception (throw)
-- install succeeds, to bootstrap from the cleanly installed system to
-- a fully working system. For example:
--
--- > & os (System (Debian Unstable) "amd64")
+-- > & osDebian Unstable "amd64"
-- > & cleanInstallOnce (Confirmed "foo.example.com")
-- > `onChange` propertyList "fixing up after clean install"
-- > [ preserveNetwork
@@ -64,7 +64,7 @@ import Control.Exception (throw)
-- > & User.accountFor "joey"
-- > & User.hasSomePassword "joey"
-- > -- rest of system properties here
-cleanInstallOnce :: Confirmation -> Property NoInfo
+cleanInstallOnce :: Confirmation -> Property Linux
cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $
go `requires` confirmed "clean install confirmed" confirmation
where
@@ -83,14 +83,18 @@ cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $
`requires`
osbootstrapped
- osbootstrapped = withOS (newOSDir ++ " bootstrapped") $ \o -> case o of
- (Just d@(System (Debian _) _)) -> debootstrap d
- (Just u@(System (Buntish _) _)) -> debootstrap u
- _ -> unsupportedOS
+ osbootstrapped :: Property Linux
+ osbootstrapped = withOS (newOSDir ++ " bootstrapped") $ \w o -> case o of
+ (Just d@(System (Debian _) _)) -> ensureProperty w $
+ debootstrap d
+ (Just u@(System (Buntish _) _)) -> ensureProperty w $
+ debootstrap u
+ _ -> unsupportedOS'
- debootstrap targetos = ensureProperty $
- -- Ignore the os setting, and install debootstrap from
- -- source, since we don't know what OS we're running in yet.
+ debootstrap :: System -> Property Linux
+ debootstrap targetos =
+ -- Install debootstrap from source, since we don't know
+ -- what OS we're currently running in.
Debootstrap.built' Debootstrap.sourceInstall
newOSDir targetos Debootstrap.DefaultConfig
-- debootstrap, I wish it was faster..
@@ -100,6 +104,7 @@ cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $
-- sync instead?
-- This is the fun bit.
+ flipped :: Property Linux
flipped = property (newOSDir ++ " moved into place") $ liftIO $ do
-- First, unmount most mount points, lazily, so
-- they don't interfere with moving things around.
@@ -137,6 +142,7 @@ cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $
return MadeChange
+ propellorbootstrapped :: Property UnixLike
propellorbootstrapped = property "propellor re-debootstrapped in new os" $
return NoChange
-- re-bootstrap propellor in /usr/local/propellor,
@@ -145,6 +151,7 @@ cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $
-- be present in /old-os's /usr/local/propellor)
-- TODO
+ finalized :: Property UnixLike
finalized = property "clean OS installed" $ do
liftIO $ writeFile flagfile ""
return MadeChange
@@ -179,7 +186,7 @@ massRename = go []
data Confirmation = Confirmed HostName
-confirmed :: Desc -> Confirmation -> Property NoInfo
+confirmed :: Desc -> Confirmation -> Property UnixLike
confirmed desc (Confirmed c) = property desc $ do
hostname <- asks hostName
if hostname /= c
@@ -191,25 +198,26 @@ confirmed desc (Confirmed c) = property desc $ do
-- | </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 NoInfo
+preserveNetwork :: Property DebianLike
preserveNetwork = go `requires` Network.cleanInterfacesFile
where
- go = property "preserve network configuration" $ do
+ go :: Property DebianLike
+ go = property' "preserve network configuration" $ \w -> do
ls <- liftIO $ lines <$> readProcess "ip"
["route", "list", "scope", "global"]
case words <$> headMaybe ls of
Just ("default":"via":_:"dev":iface:_) ->
- ensureProperty $ Network.static iface
+ ensureProperty w $ Network.static iface
_ -> do
warningMessage "did not find any default ipv4 route"
return FailedChange
-- | </etc/resolv.conf> is copied from the old OS
-preserveResolvConf :: Property NoInfo
+preserveResolvConf :: Property Linux
preserveResolvConf = check (fileExist oldloc) $
- property (newloc ++ " copied from old OS") $ do
+ property' (newloc ++ " copied from old OS") $ \w -> do
ls <- liftIO $ lines <$> readFile oldloc
- ensureProperty $ newloc `File.hasContent` ls
+ ensureProperty w $ newloc `File.hasContent` ls
where
newloc = "/etc/resolv.conf"
oldloc = oldOSDir ++ newloc
@@ -217,20 +225,23 @@ preserveResolvConf = check (fileExist oldloc) $
-- | </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 NoInfo
+preserveRootSshAuthorized :: Property UnixLike
preserveRootSshAuthorized = check (fileExist oldloc) $
- property (newloc ++ " copied from old OS") $ do
+ property' desc $ \w -> do
ks <- liftIO $ lines <$> readFile oldloc
- ensureProperties (map (setupRevertableProperty . Ssh.authorizedKey (User "root")) ks)
+ ensureProperty w $ combineProperties desc $
+ toProps $ map (setupRevertableProperty . Ssh.authorizedKey (User "root")) ks
where
+ desc = newloc ++ " copied from old OS"
newloc = "/root/.ssh/authorized_keys"
oldloc = oldOSDir ++ newloc
-- Removes the old OS's backup from </old-os>
-oldOSRemoved :: Confirmation -> Property NoInfo
+oldOSRemoved :: Confirmation -> Property UnixLike
oldOSRemoved confirmation = check (doesDirectoryExist oldOSDir) $
go `requires` confirmed "old OS backup removal confirmed" confirmation
where
+ go :: Property UnixLike
go = property "old OS backup removed" $ do
liftIO $ removeDirectoryRecursive oldOSDir
return MadeChange
diff --git a/src/Propellor/Property/Obnam.hs b/src/Propellor/Property/Obnam.hs
index 666328ac..6d6f4a7f 100644
--- a/src/Propellor/Property/Obnam.hs
+++ b/src/Propellor/Property/Obnam.hs
@@ -40,7 +40,7 @@ data NumClients = OnlyClient | MultipleClients
-- Since obnam uses a fair amount of system resources, only one obnam
-- backup job will be run at a time. Other jobs will wait their turns to
-- run.
-backup :: FilePath -> Cron.Times -> [ObnamParam] -> NumClients -> Property NoInfo
+backup :: FilePath -> Cron.Times -> [ObnamParam] -> NumClients -> Property DebianLike
backup dir crontimes params numclients =
backup' dir crontimes params numclients
`requires` restored dir params
@@ -50,7 +50,7 @@ backup dir crontimes params numclients =
--
-- The gpg secret key will be automatically imported
-- into root's keyring using Propellor.Property.Gpg.keyImported
-backupEncrypted :: FilePath -> Cron.Times -> [ObnamParam] -> NumClients -> Gpg.GpgKeyId -> Property HasInfo
+backupEncrypted :: FilePath -> Cron.Times -> [ObnamParam] -> NumClients -> Gpg.GpgKeyId -> Property (HasInfo + DebianLike)
backupEncrypted dir crontimes params numclients keyid =
backup dir crontimes params' numclients
`requires` Gpg.keyImported keyid (User "root")
@@ -58,7 +58,7 @@ backupEncrypted dir crontimes params numclients keyid =
params' = ("--encrypt-with=" ++ Gpg.getGpgKeyId keyid) : params
-- | Does a backup, but does not automatically restore.
-backup' :: FilePath -> Cron.Times -> [ObnamParam] -> NumClients -> Property NoInfo
+backup' :: FilePath -> Cron.Times -> [ObnamParam] -> NumClients -> Property DebianLike
backup' dir crontimes params numclients = cronjob `describe` desc
where
desc = dir ++ " backed up by obnam"
@@ -96,11 +96,12 @@ backup' dir crontimes params numclients = cronjob `describe` desc
--
-- The restore is performed atomically; restoring to a temp directory
-- and then moving it to the directory.
-restored :: FilePath -> [ObnamParam] -> Property NoInfo
-restored dir params = property (dir ++ " restored by obnam") go
- `requires` installed
+restored :: FilePath -> [ObnamParam] -> Property DebianLike
+restored dir params = go `requires` installed
where
- go = ifM (liftIO needsRestore)
+ desc = dir ++ " restored by obnam"
+ go :: Property DebianLike
+ go = property desc $ ifM (liftIO needsRestore)
( do
warningMessage $ dir ++ " is empty/missing; restoring from backup ..."
liftIO restore
@@ -152,5 +153,5 @@ keepParam ps = "--keep=" ++ intercalate "," (map go ps)
isKeepParam :: ObnamParam -> Bool
isKeepParam p = "--keep=" `isPrefixOf` p
-installed :: Property NoInfo
+installed :: Property DebianLike
installed = Apt.installed ["obnam"]
diff --git a/src/Propellor/Property/OpenId.hs b/src/Propellor/Property/OpenId.hs
index 0f73bfb6..0abf38a6 100644
--- a/src/Propellor/Property/OpenId.hs
+++ b/src/Propellor/Property/OpenId.hs
@@ -16,7 +16,7 @@ import Data.List
--
-- It's probably a good idea to put this property inside a docker or
-- systemd-nspawn container.
-providerFor :: [User] -> HostName -> Maybe Port -> Property HasInfo
+providerFor :: [User] -> HostName -> Maybe Port -> Property (HasInfo + DebianLike)
providerFor users hn mp = propertyList desc $ props
& Apt.serviceInstalledRunning "apache2"
& apacheconfigured
@@ -24,7 +24,7 @@ providerFor users hn mp = propertyList desc $ props
`onChange` Apache.restarted
& File.fileProperty (desc ++ " configured")
(map setbaseurl) "/etc/simpleid/config.inc"
- & propertyList desc (map identfile users)
+ & propertyList desc (toProps $ map identfile users)
where
baseurl = hn ++ case mp of
Nothing -> ""
@@ -37,7 +37,7 @@ providerFor users hn mp = propertyList desc $ props
| otherwise = l
apacheconfigured = case mp of
- Nothing -> toProp $
+ Nothing -> setupRevertableProperty $
Apache.virtualHost hn (Port 80) "/var/www/html"
Just p -> propertyList desc $ props
& Apache.listenPorts [p]
diff --git a/src/Propellor/Property/Parted.hs b/src/Propellor/Property/Parted.hs
index 5d6afa9c..bc8a256d 100644
--- a/src/Propellor/Property/Parted.hs
+++ b/src/Propellor/Property/Parted.hs
@@ -153,18 +153,17 @@ data Eep = YesReallyDeleteDiskContents
-- The FilePath can be a block device (eg, \/dev\/sda), or a disk image file.
--
-- This deletes any existing partitions in the disk! Use with EXTREME caution!
-partitioned :: Eep -> FilePath -> PartTable -> Property NoInfo
-partitioned eep disk (PartTable tabletype parts) = property desc $ do
+partitioned :: Eep -> FilePath -> PartTable -> Property DebianLike
+partitioned eep disk (PartTable tabletype parts) = property' desc $ \w -> do
isdev <- liftIO $ isBlockDevice <$> getFileStatus disk
- ensureProperty $ combineProperties desc
- [ parted eep disk partedparams
- , if isdev
+ ensureProperty w $ combineProperties desc $ props
+ & parted eep disk partedparams
+ & if isdev
then formatl (map (\n -> disk ++ show n) [1 :: Int ..])
else Partition.kpartx disk (formatl . map Partition.partitionLoopDev)
- ]
where
desc = disk ++ " partitioned"
- formatl devs = combineProperties desc (map format (zip parts devs))
+ formatl devs = combineProperties desc (toProps $ map format (zip parts devs))
partedparams = concat $ mklabel : mkparts (1 :: Integer) mempty parts []
format (p, dev) = Partition.formatted' (partMkFsOpts p)
Partition.YesReallyFormatPartition (partFs p) dev
@@ -193,12 +192,12 @@ partitioned eep disk (PartTable tabletype parts) = property desc $ do
--
-- Parted is run in script mode, so it will never prompt for input.
-- It is asked to use cylinder alignment for the disk.
-parted :: Eep -> FilePath -> [String] -> Property NoInfo
+parted :: Eep -> FilePath -> [String] -> Property DebianLike
parted YesReallyDeleteDiskContents disk ps = p `requires` installed
where
p = cmdProperty "parted" ("--script":"--align":"cylinder":disk:ps)
`assume` MadeChange
-- | Gets parted installed.
-installed :: Property NoInfo
+installed :: Property DebianLike
installed = Apt.installed ["parted"]
diff --git a/src/Propellor/Property/Partition.hs b/src/Propellor/Property/Partition.hs
index b2f50339..2bf5b927 100644
--- a/src/Propellor/Property/Partition.hs
+++ b/src/Propellor/Property/Partition.hs
@@ -3,6 +3,7 @@
module Propellor.Property.Partition where
import Propellor.Base
+import Propellor.Types.Core
import qualified Propellor.Property.Apt as Apt
import Utility.Applicative
@@ -16,7 +17,7 @@ data Fs = EXT2 | EXT3 | EXT4 | BTRFS | REISERFS | XFS | FAT | VFAT | NTFS | Linu
data Eep = YesReallyFormatPartition
-- | Formats a partition.
-formatted :: Eep -> Fs -> FilePath -> Property NoInfo
+formatted :: Eep -> Fs -> FilePath -> Property DebianLike
formatted = formatted' []
-- | Options passed to a mkfs.* command when making a filesystem.
@@ -24,7 +25,7 @@ formatted = formatted' []
-- Eg, ["-m0"]
type MkfsOpts = [String]
-formatted' :: MkfsOpts -> Eep -> Fs -> FilePath -> Property NoInfo
+formatted' :: MkfsOpts -> Eep -> Fs -> FilePath -> Property DebianLike
formatted' opts YesReallyFormatPartition fs dev = cmdProperty cmd opts'
`assume` MadeChange
`requires` Apt.installed [pkg]
@@ -64,17 +65,18 @@ isLoopDev' f
-- within a disk image file. The resulting loop devices are passed to the
-- property, which can operate on them. Always cleans up after itself,
-- by removing the device maps after the property is run.
-kpartx :: FilePath -> ([LoopDev] -> Property NoInfo) -> Property NoInfo
+kpartx :: FilePath -> ([LoopDev] -> Property DebianLike) -> Property DebianLike
kpartx diskimage mkprop = go `requires` Apt.installed ["kpartx"]
where
- go = property (propertyDesc (mkprop [])) $ do
+ go :: Property DebianLike
+ go = property' (getDesc (mkprop [])) $ \w -> do
cleanup -- idempotency
loopdevs <- liftIO $ kpartxParse
<$> readProcess "kpartx" ["-avs", diskimage]
bad <- liftIO $ filterM (not <$$> isLoopDev) loopdevs
unless (null bad) $
error $ "kpartx output seems to include non-loop-devices (possible parse failure): " ++ show bad
- r <- ensureProperty (mkprop loopdevs)
+ r <- ensureProperty w (mkprop loopdevs)
cleanup
return r
cleanup = void $ liftIO $ boolSystem "kpartx" [Param "-d", File diskimage]
diff --git a/src/Propellor/Property/Postfix.hs b/src/Propellor/Property/Postfix.hs
index df244061..45aa4e42 100644
--- a/src/Propellor/Property/Postfix.hs
+++ b/src/Propellor/Property/Postfix.hs
@@ -12,13 +12,13 @@ import qualified Data.Map as M
import Data.List
import Data.Char
-installed :: Property NoInfo
+installed :: Property DebianLike
installed = Apt.serviceInstalledRunning "postfix"
-restarted :: Property NoInfo
+restarted :: Property DebianLike
restarted = Service.restarted "postfix"
-reloaded :: Property NoInfo
+reloaded :: Property DebianLike
reloaded = Service.reloaded "postfix"
-- | Configures postfix as a satellite system, which
@@ -28,38 +28,39 @@ reloaded = Service.reloaded "postfix"
-- The smarthost may refuse to relay mail on to other domains, without
-- further configuration/keys. But this should be enough to get cron job
-- mail flowing to a place where it will be seen.
-satellite :: Property NoInfo
+satellite :: Property DebianLike
satellite = check (not <$> mainCfIsSet "relayhost") setup
`requires` installed
where
- setup = property "postfix satellite system" $ do
+ desc = "postfix satellite system"
+ setup :: Property DebianLike
+ setup = property' desc $ \w -> do
hn <- asks hostName
let (_, domain) = separate (== '.') hn
- ensureProperties
- [ Apt.reConfigure "postfix"
+ ensureProperty w $ combineProperties desc $ props
+ & Apt.reConfigure "postfix"
[ ("postfix/main_mailer_type", "select", "Satellite system")
, ("postfix/root_address", "string", "root")
, ("postfix/destinations", "string", "localhost")
, ("postfix/mailname", "string", hn)
]
- , mainCf ("relayhost", "smtp." ++ domain)
+ & mainCf ("relayhost", "smtp." ++ domain)
`onChange` reloaded
- ]
-- | Sets up a file by running a property (which the filename is passed
-- to). If the setup property makes a change, postmap will be run on the
-- file, and postfix will be reloaded.
mappedFile
- :: Combines (Property x) (Property NoInfo)
+ :: Combines (Property x) (Property UnixLike)
=> FilePath
-> (FilePath -> Property x)
- -> Property (CInfo x NoInfo)
+ -> CombinedType (Property x) (Property UnixLike)
mappedFile f setup = setup f
`onChange` (cmdProperty "postmap" [f] `assume` MadeChange)
-- | Run newaliases command, which should be done after changing
-- @/etc/aliases@.
-newaliases :: Property NoInfo
+newaliases :: Property UnixLike
newaliases = check ("/etc/aliases" `isNewerThan` "/etc/aliases.db")
(cmdProperty "newaliases" [])
@@ -68,9 +69,9 @@ mainCfFile :: FilePath
mainCfFile = "/etc/postfix/main.cf"
-- | Sets a main.cf @name=value@ pair. Does not reload postfix immediately.
-mainCf :: (String, String) -> Property NoInfo
+mainCf :: (String, String) -> Property UnixLike
mainCf (name, value) = check notset set
- `describe` ("postfix main.cf " ++ setting)
+ `describe` ("postfix main.cf " ++ setting)
where
setting = name ++ "=" ++ value
notset = (/= Just value) <$> getMainCf name
@@ -105,7 +106,7 @@ mainCfIsSet name = do
--
-- Note that multiline configurations that continue onto the next line
-- are not currently supported.
-dedupMainCf :: Property NoInfo
+dedupMainCf :: Property UnixLike
dedupMainCf = File.fileProperty "postfix main.cf dedupped" dedupCf mainCfFile
dedupCf :: [String] -> [String]
@@ -252,7 +253,7 @@ parseServiceLine l = Service
nws = length ws
-- | Enables a `Service` in postfix's `masterCfFile`.
-service :: Service -> RevertableProperty NoInfo
+service :: Service -> RevertableProperty DebianLike DebianLike
service s = (enable <!> disable)
`describe` desc
where
@@ -276,7 +277,7 @@ service s = (enable <!> disable)
-- It would be wise to enable fail2ban, for example:
--
-- > Fail2Ban.jailEnabled "postfix-sasl"
-saslAuthdInstalled :: Property NoInfo
+saslAuthdInstalled :: Property DebianLike
saslAuthdInstalled = setupdaemon
`requires` Service.running "saslauthd"
`requires` postfixgroup
@@ -303,7 +304,7 @@ saslAuthdInstalled = setupdaemon
-- | Uses `saslpasswd2` to set the password for a user in the sasldb2 file.
--
-- The password is taken from the privdata.
-saslPasswdSet :: Domain -> User -> Property HasInfo
+saslPasswdSet :: Domain -> User -> Property (HasInfo + UnixLike)
saslPasswdSet domain (User user) = go `changesFileContent` "/etc/sasldb2"
where
go = withPrivData src ctx $ \getpw ->
diff --git a/src/Propellor/Property/PropellorRepo.hs b/src/Propellor/Property/PropellorRepo.hs
index d4fc089a..e60e7848 100644
--- a/src/Propellor/Property/PropellorRepo.hs
+++ b/src/Propellor/Property/PropellorRepo.hs
@@ -11,7 +11,7 @@ import Propellor.Git.Config
--
-- This property is useful when hosts are being updated without using
-- --spin, eg when using the `Propellor.Property.Cron.runPropellor` cron job.
-hasOriginUrl :: String -> Property NoInfo
+hasOriginUrl :: String -> Property UnixLike
hasOriginUrl u = property ("propellor repo url " ++ u) $ do
curru <- liftIO getRepoUrl
if curru == Just u
diff --git a/src/Propellor/Property/Prosody.hs b/src/Propellor/Property/Prosody.hs
index 47095504..8017be4a 100644
--- a/src/Propellor/Property/Prosody.hs
+++ b/src/Propellor/Property/Prosody.hs
@@ -11,7 +11,7 @@ type ConfigFile = [String]
type Conf = String
-confEnabled :: Conf -> ConfigFile -> RevertableProperty NoInfo
+confEnabled :: Conf -> ConfigFile -> RevertableProperty DebianLike DebianLike
confEnabled conf cf = enable <!> disable
where
enable = dir `File.isSymlinkedTo` target
@@ -29,9 +29,9 @@ confEnabled conf cf = enable <!> disable
`requires` installed
`onChange` reloaded
-confAvailable :: Conf -> ConfigFile -> Property NoInfo
+confAvailable :: Conf -> ConfigFile -> Property DebianLike
confAvailable conf cf = ("prosody conf available " ++ conf) ==>
- confAvailPath conf `File.hasContent` (comment : cf)
+ tightenTargets (confAvailPath conf `File.hasContent` (comment : cf))
where
comment = "-- deployed with propellor, do not modify"
@@ -41,11 +41,11 @@ confAvailPath conf = "/etc/prosody/conf.avail" </> conf <.> "cfg.lua"
confValPath :: Conf -> FilePath
confValPath conf = "/etc/prosody/conf.d" </> conf <.> "cfg.lua"
-installed :: Property NoInfo
+installed :: Property DebianLike
installed = Apt.installed ["prosody"]
-restarted :: Property NoInfo
+restarted :: Property DebianLike
restarted = Service.restarted "prosody"
-reloaded :: Property NoInfo
+reloaded :: Property DebianLike
reloaded = Service.reloaded "prosody"
diff --git a/src/Propellor/Property/Reboot.hs b/src/Propellor/Property/Reboot.hs
index 26b85840..5b854fa3 100644
--- a/src/Propellor/Property/Reboot.hs
+++ b/src/Propellor/Property/Reboot.hs
@@ -2,8 +2,8 @@ module Propellor.Property.Reboot where
import Propellor.Base
-now :: Property NoInfo
-now = cmdProperty "reboot" []
+now :: Property Linux
+now = tightenTargets $ cmdProperty "reboot" []
`assume` MadeChange
`describe` "reboot now"
@@ -14,7 +14,7 @@ now = cmdProperty "reboot" []
--
-- The reboot can be forced to run, which bypasses the init system. Useful
-- if the init system might not be running for some reason.
-atEnd :: Bool -> (Result -> Bool) -> Property NoInfo
+atEnd :: Bool -> (Result -> Bool) -> Property Linux
atEnd force resultok = property "scheduled reboot at end of propellor run" $ do
endAction "rebooting" atend
return NoChange
diff --git a/src/Propellor/Property/Rsync.hs b/src/Propellor/Property/Rsync.hs
index 0c77df58..b40396de 100644
--- a/src/Propellor/Property/Rsync.hs
+++ b/src/Propellor/Property/Rsync.hs
@@ -16,7 +16,7 @@ filesUnder d = Pattern (d ++ "/*")
-- | Ensures that the Dest directory exists and has identical contents as
-- the Src directory.
-syncDir :: Src -> Dest -> Property NoInfo
+syncDir :: Src -> Dest -> Property DebianLike
syncDir = syncDirFiltered []
data Filter
@@ -43,7 +43,7 @@ newtype Pattern = Pattern String
-- Rsync checks each name to be transferred against its list of Filter
-- rules, and the first matching one is acted on. If no matching rule
-- is found, the file is processed.
-syncDirFiltered :: [Filter] -> Src -> Dest -> Property NoInfo
+syncDirFiltered :: [Filter] -> Src -> Dest -> Property DebianLike
syncDirFiltered filters src dest = rsync $
[ "-av"
-- Add trailing '/' to get rsync to sync the Dest directory,
@@ -56,7 +56,7 @@ syncDirFiltered filters src dest = rsync $
, "--quiet"
] ++ map toRsync filters
-rsync :: [String] -> Property NoInfo
+rsync :: [String] -> Property DebianLike
rsync ps = cmdProperty "rsync" ps
`assume` MadeChange
`requires` Apt.installed ["rsync"]
diff --git a/src/Propellor/Property/Scheduled.hs b/src/Propellor/Property/Scheduled.hs
index 64a530bc..729a3749 100644
--- a/src/Propellor/Property/Scheduled.hs
+++ b/src/Propellor/Property/Scheduled.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}
module Propellor.Property.Scheduled
( period
@@ -10,6 +10,7 @@ module Propellor.Property.Scheduled
) where
import Propellor.Base
+import Propellor.Types.Core
import Utility.Scheduled
import Data.Time.Clock
@@ -22,24 +23,24 @@ import qualified Data.Map as M
-- last run.
period :: (IsProp (Property i)) => Property i -> Recurrance -> Property i
period prop recurrance = flip describe desc $ adjustPropertySatisfy prop $ \satisfy -> do
- lasttime <- liftIO $ getLastChecked (propertyDesc prop)
+ lasttime <- liftIO $ getLastChecked (getDesc prop)
nexttime <- liftIO $ fmap startTime <$> nextTime schedule lasttime
t <- liftIO localNow
if Just t >= nexttime
then do
r <- satisfy
- liftIO $ setLastChecked t (propertyDesc prop)
+ liftIO $ setLastChecked t (getDesc prop)
return r
else noChange
where
schedule = Schedule recurrance AnyTime
- desc = propertyDesc prop ++ " (period " ++ fromRecurrance recurrance ++ ")"
+ desc = getDesc prop ++ " (period " ++ fromRecurrance recurrance ++ ")"
-- | Like period, but parse a human-friendly string.
-periodParse :: Property NoInfo -> String -> Property NoInfo
+periodParse :: (IsProp (Property i)) => Property i -> String -> Property i
periodParse prop s = case toRecurrance s of
Just recurrance -> period prop recurrance
- Nothing -> property "periodParse" $ do
+ Nothing -> adjustPropertySatisfy prop $ \_ -> do
liftIO $ warningMessage $ "failed periodParse: " ++ s
noChange
diff --git a/src/Propellor/Property/Service.hs b/src/Propellor/Property/Service.hs
index 0e96ed4c..46f9e8ef 100644
--- a/src/Propellor/Property/Service.hs
+++ b/src/Propellor/Property/Service.hs
@@ -11,17 +11,17 @@ type ServiceName = String
-- Note that due to the general poor state of init scripts, the best
-- we can do is try to start the service, and if it fails, assume
-- this means it's already running.
-running :: ServiceName -> Property NoInfo
+running :: ServiceName -> Property DebianLike
running = signaled "start" "running"
-restarted :: ServiceName -> Property NoInfo
+restarted :: ServiceName -> Property DebianLike
restarted = signaled "restart" "restarted"
-reloaded :: ServiceName -> Property NoInfo
+reloaded :: ServiceName -> Property DebianLike
reloaded = signaled "reload" "reloaded"
-signaled :: String -> Desc -> ServiceName -> Property NoInfo
-signaled cmd desc svc = p `describe` (desc ++ " " ++ svc)
+signaled :: String -> Desc -> ServiceName -> Property DebianLike
+signaled cmd desc svc = tightenTargets $ p `describe` (desc ++ " " ++ svc)
where
p = scriptProperty ["service " ++ shellEscape svc ++ " " ++ cmd ++ " >/dev/null 2>&1 || true"]
`assume` NoChange
diff --git a/src/Propellor/Property/SiteSpecific/Branchable.hs b/src/Propellor/Property/SiteSpecific/Branchable.hs
index 5c85610b..239bcbeb 100644
--- a/src/Propellor/Property/SiteSpecific/Branchable.hs
+++ b/src/Propellor/Property/SiteSpecific/Branchable.hs
@@ -9,7 +9,7 @@ import qualified Propellor.Property.Postfix as Postfix
import qualified Propellor.Property.Gpg as Gpg
import qualified Propellor.Property.Sudo as Sudo
-server :: [Host] -> Property HasInfo
+server :: [Host] -> Property (HasInfo + DebianLike)
server hosts = propertyList "branchable server" $ props
& "/etc/timezone" `File.hasContent` ["Etc/UTC"]
& "/etc/locale.gen" `File.containsLines`
diff --git a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
index 2932baf7..ce89b94a 100644
--- a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
+++ b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
@@ -25,7 +25,7 @@ builddir = gitbuilderdir </> "build"
type TimeOut = String -- eg, 5h
-autobuilder :: Architecture -> Times -> TimeOut -> Property HasInfo
+autobuilder :: Architecture -> Times -> TimeOut -> Property (HasInfo + DebianLike)
autobuilder arch crontimes timeout = combineProperties "gitannexbuilder" $ props
& Apt.serviceInstalledRunning "cron"
& Cron.niceJob "gitannexbuilder" crontimes (User builduser) gitbuilderdir
@@ -37,6 +37,7 @@ autobuilder arch crontimes timeout = combineProperties "gitannexbuilder" $ props
-- The builduser account does not have a password set,
-- instead use the password privdata to hold the rsync server
-- password used to upload the built image.
+ rsyncpassword :: Property (HasInfo + DebianLike)
rsyncpassword = withPrivData (Password builduser) context $ \getpw ->
property "rsync password" $ getpw $ \pw -> do
have <- liftIO $ catchDefaultIO "" $
@@ -46,7 +47,7 @@ autobuilder arch crontimes timeout = combineProperties "gitannexbuilder" $ props
then makeChange $ writeFile pwfile want
else noChange
-tree :: Architecture -> Flavor -> Property HasInfo
+tree :: Architecture -> Flavor -> Property DebianLike
tree buildarch flavor = combineProperties "gitannexbuilder tree" $ props
& Apt.installed ["git"]
& File.dirExists gitbuilderdir
@@ -66,14 +67,14 @@ tree buildarch flavor = combineProperties "gitannexbuilder tree" $ props
[ "git clone git://git-annex.branchable.com/ " ++ builddir
]
-buildDepsApt :: Property HasInfo
+buildDepsApt :: Property DebianLike
buildDepsApt = combineProperties "gitannexbuilder build deps" $ props
& Apt.buildDep ["git-annex"]
& buildDepsNoHaskellLibs
& Apt.buildDepIn builddir
`describe` "git-annex source build deps installed"
-buildDepsNoHaskellLibs :: Property NoInfo
+buildDepsNoHaskellLibs :: Property DebianLike
buildDepsNoHaskellLibs = Apt.installed
["git", "rsync", "moreutils", "ca-certificates",
"debhelper", "ghc", "curl", "openssh-client", "git-remote-gcrypt",
@@ -83,8 +84,9 @@ buildDepsNoHaskellLibs = Apt.installed
"libmagic-dev", "alex", "happy", "c2hs"
]
-haskellPkgsInstalled :: String -> Property NoInfo
-haskellPkgsInstalled dir = flagFile go ("/haskellpkgsinstalled")
+haskellPkgsInstalled :: String -> Property DebianLike
+haskellPkgsInstalled dir = tightenTargets $
+ flagFile go ("/haskellpkgsinstalled")
where
go = userScriptProperty (User builduser)
[ "cd " ++ builddir ++ " && ./standalone/" ++ dir ++ "/install-haskell-packages"
@@ -93,7 +95,7 @@ haskellPkgsInstalled dir = flagFile go ("/haskellpkgsinstalled")
-- Installs current versions of git-annex's deps from cabal, but only
-- does so once.
-cabalDeps :: Property NoInfo
+cabalDeps :: Property UnixLike
cabalDeps = flagFile go cabalupdated
where
go = userScriptProperty (User builduser)
@@ -101,20 +103,20 @@ cabalDeps = flagFile go cabalupdated
`assume` MadeChange
cabalupdated = homedir </> ".cabal" </> "packages" </> "hackage.haskell.org" </> "00-index.cache"
-autoBuilderContainer :: (System -> Flavor -> Property HasInfo) -> System -> Flavor -> Times -> TimeOut -> Systemd.Container
-autoBuilderContainer mkprop osver@(System _ arch) flavor crontime timeout =
- Systemd.container name osver (Chroot.debootstrapped mempty)
- & mkprop osver flavor
+autoBuilderContainer :: (DebianSuite -> Architecture -> Flavor -> Property (HasInfo + Debian)) -> DebianSuite -> Architecture -> Flavor -> Times -> TimeOut -> Systemd.Container
+autoBuilderContainer mkprop suite arch flavor crontime timeout =
+ Systemd.container name $ \d -> Chroot.debootstrapped mempty d $ props
+ & mkprop suite arch flavor
& autobuilder arch crontime timeout
where
name = arch ++ fromMaybe "" flavor ++ "-git-annex-builder"
type Flavor = Maybe String
-standardAutoBuilder :: System -> Flavor -> Property HasInfo
-standardAutoBuilder osver@(System _ arch) flavor =
+standardAutoBuilder :: DebianSuite -> Architecture -> Flavor -> Property (HasInfo + Debian)
+standardAutoBuilder suite arch flavor =
propertyList "standard git-annex autobuilder" $ props
- & os osver
+ & osDebian suite arch
& buildDepsApt
& Apt.stdSourcesList
& Apt.unattendedUpgrades
@@ -122,10 +124,10 @@ standardAutoBuilder osver@(System _ arch) flavor =
& User.accountFor (User builduser)
& tree arch flavor
-stackAutoBuilder :: System -> Flavor -> Property HasInfo
-stackAutoBuilder osver@(System _ arch) flavor =
+stackAutoBuilder :: DebianSuite -> Architecture -> Flavor -> Property (HasInfo + Debian)
+stackAutoBuilder suite arch flavor =
propertyList "git-annex autobuilder using stack" $ props
- & os osver
+ & osDebian suite arch
& buildDepsNoHaskellLibs
& Apt.stdSourcesList
& Apt.unattendedUpgrades
@@ -134,34 +136,34 @@ stackAutoBuilder osver@(System _ arch) flavor =
& tree arch flavor
& stackInstalled
-stackInstalled :: Property NoInfo
-stackInstalled = withOS "stack installed" $ \o ->
+stackInstalled :: Property Linux
+stackInstalled = withOS "stack installed" $ \w o ->
case o of
(Just (System (Debian (Stable "jessie")) "i386")) ->
- ensureProperty $ manualinstall "i386"
- _ -> ensureProperty $ Apt.installed ["haskell-stack"]
+ ensureProperty w $ manualinstall "i386"
+ _ -> ensureProperty w $ Apt.installed ["haskell-stack"]
where
-- Warning: Using a binary downloaded w/o validation.
- manualinstall arch = check (not <$> doesFileExist binstack) $
- propertyList "stack installed from upstream tarball"
- [ cmdProperty "wget" ["https://www.stackage.org/stack/linux-" ++ arch, "-O", tmptar]
+ manualinstall :: Architecture -> Property Linux
+ manualinstall arch = tightenTargets $ check (not <$> doesFileExist binstack) $
+ propertyList "stack installed from upstream tarball" $ props
+ & cmdProperty "wget" ["https://www.stackage.org/stack/linux-" ++ arch, "-O", tmptar]
`assume` MadeChange
- , File.dirExists tmpdir
- , cmdProperty "tar" ["xf", tmptar, "-C", tmpdir, "--strip-components=1"]
+ & File.dirExists tmpdir
+ & cmdProperty "tar" ["xf", tmptar, "-C", tmpdir, "--strip-components=1"]
`assume` MadeChange
- , cmdProperty "mv" [tmpdir </> "stack", binstack]
+ & cmdProperty "mv" [tmpdir </> "stack", binstack]
`assume` MadeChange
- , cmdProperty "rm" ["-rf", tmpdir, tmptar]
+ & cmdProperty "rm" ["-rf", tmpdir, tmptar]
`assume` MadeChange
- ]
binstack = "/usr/bin/stack"
tmptar = "/root/stack.tar.gz"
tmpdir = "/root/stack"
-armAutoBuilder :: System -> Flavor -> Property HasInfo
-armAutoBuilder osver flavor =
+armAutoBuilder :: DebianSuite -> Architecture -> Flavor -> Property (HasInfo + Debian)
+armAutoBuilder suite arch flavor =
propertyList "arm git-annex autobuilder" $ props
- & standardAutoBuilder osver flavor
+ & standardAutoBuilder suite arch flavor
& buildDepsNoHaskellLibs
-- Works around ghc crash with parallel builds on arm.
& (homedir </> ".cabal" </> "config")
@@ -172,26 +174,30 @@ armAutoBuilder osver flavor =
androidAutoBuilderContainer :: Times -> TimeOut -> Systemd.Container
androidAutoBuilderContainer crontimes timeout =
- androidContainer "android-git-annex-builder" (tree "android" Nothing) builddir
- & Apt.unattendedUpgrades
- & buildDepsNoHaskellLibs
- & autobuilder "android" crontimes timeout
+ androidAutoBuilderContainer' "android-git-annex-builder"
+ (tree "android" Nothing) builddir crontimes timeout
-- Android is cross-built in a Debian i386 container, using the Android NDK.
-androidContainer
- :: (IsProp (Property (CInfo NoInfo i)), (Combines (Property NoInfo) (Property i)))
- => Systemd.MachineName
- -> Property i
+androidAutoBuilderContainer'
+ :: Systemd.MachineName
+ -> Property DebianLike
-> FilePath
+ -> Times
+ -> TimeOut
-> Systemd.Container
-androidContainer name setupgitannexdir gitannexdir = Systemd.container name osver bootstrap
- & Apt.stdSourcesList
- & User.accountFor (User builduser)
- & File.dirExists gitbuilderdir
- & File.ownerGroup homedir (User builduser) (Group builduser)
- & flagFile chrootsetup ("/chrootsetup")
- `requires` setupgitannexdir
- & haskellPkgsInstalled "android"
+androidAutoBuilderContainer' name setupgitannexdir gitannexdir crontimes timeout =
+ Systemd.container name $ \d -> bootstrap d $ props
+ & osDebian (Stable "jessie") "i386"
+ & Apt.stdSourcesList
+ & User.accountFor (User builduser)
+ & File.dirExists gitbuilderdir
+ & File.ownerGroup homedir (User builduser) (Group builduser)
+ & flagFile chrootsetup ("/chrootsetup")
+ `requires` setupgitannexdir
+ & haskellPkgsInstalled "android"
+ & Apt.unattendedUpgrades
+ & buildDepsNoHaskellLibs
+ & autobuilder "android" crontimes timeout
where
-- Use git-annex's android chroot setup script, which will install
-- ghc-android and the NDK, all build deps, etc, in the home
@@ -200,5 +206,4 @@ androidContainer name setupgitannexdir gitannexdir = Systemd.container name osve
[ "cd " ++ gitannexdir ++ " && ./standalone/android/buildchroot-inchroot"
]
`assume` MadeChange
- osver = System (Debian (Stable "jessie")) "i386"
bootstrap = Chroot.debootstrapped mempty
diff --git a/src/Propellor/Property/SiteSpecific/GitHome.hs b/src/Propellor/Property/SiteSpecific/GitHome.hs
index 83a1a16a..f14b5f12 100644
--- a/src/Propellor/Property/SiteSpecific/GitHome.hs
+++ b/src/Propellor/Property/SiteSpecific/GitHome.hs
@@ -5,14 +5,15 @@ import qualified Propellor.Property.Apt as Apt
import Propellor.Property.User
-- | Clones Joey Hess's git home directory, and runs its fixups script.
-installedFor :: User -> Property NoInfo
+installedFor :: User -> Property DebianLike
installedFor user@(User u) = check (not <$> hasGitDir user) $
- property ("githome " ++ u) (go =<< liftIO (homedir user))
- `requires` Apt.installed ["git"]
+ go `requires` Apt.installed ["git"]
where
- go home = do
+ go :: Property DebianLike
+ go = property' ("githome " ++ u) $ \w -> do
+ home <- liftIO (homedir user)
let tmpdir = home </> "githome"
- ensureProperty $ combineProperties "githome setup"
+ ensureProperty w $ combineProperties "githome setup" $ toProps
[ userScriptProperty user ["git clone " ++ url ++ " " ++ tmpdir]
`assume` MadeChange
, property "moveout" $ makeChange $ void $
diff --git a/src/Propellor/Property/SiteSpecific/IABak.hs b/src/Propellor/Property/SiteSpecific/IABak.hs
index bb62fba7..b245e444 100644
--- a/src/Propellor/Property/SiteSpecific/IABak.hs
+++ b/src/Propellor/Property/SiteSpecific/IABak.hs
@@ -15,14 +15,14 @@ repo = "https://github.com/ArchiveTeam/IA.BAK/"
userrepo :: String
userrepo = "git@gitlab.com:archiveteam/IA.bak.users.git"
-publicFace :: Property HasInfo
+publicFace :: Property DebianLike
publicFace = propertyList "iabak public face" $ props
& Git.cloned (User "root") repo "/usr/local/IA.BAK" (Just "server")
& Apt.serviceInstalledRunning "apache2"
& Cron.niceJob "graph-gen" (Cron.Times "*/10 * * * *") (User "root") "/"
"/usr/local/IA.BAK/web/graph-gen.sh"
-gitServer :: [Host] -> Property HasInfo
+gitServer :: [Host] -> Property (HasInfo + DebianLike)
gitServer knownhosts = propertyList "iabak git server" $ props
& Git.cloned (User "root") repo "/usr/local/IA.BAK" (Just "server")
& Git.cloned (User "root") repo "/usr/local/IA.BAK/client" (Just "master")
@@ -42,7 +42,7 @@ gitServer knownhosts = propertyList "iabak git server" $ props
"/usr/local/IA.BAK"
"./expireemailer"
-registrationServer :: [Host] -> Property HasInfo
+registrationServer :: [Host] -> Property (HasInfo + DebianLike)
registrationServer knownhosts = propertyList "iabak registration server" $ props
& User.accountFor (User "registrar")
& Ssh.userKeys (User "registrar") (Context "IA.bak.users.git") sshKeys
@@ -66,7 +66,7 @@ sshKeys =
[ (SshRsa, "ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQCoiE+CPiIQyfWnl/E9iKG3eo4QzlH30vi7xAgKolGaTu6qKy4XPtl+8MNm2Dqn9QEYRVyyOT/XH0yP5dRc6uyReT8dBy03MmLkVbj8Q+nKCz5YOMTxrY3sX6RRXU1zVGjeVd0DtC+rKRT7reoCxef42LAJTm8nCyZu/enAuso5qHqBbqulFz2YXEKfU1SEEXLawtvgGck1KmCyg+pqazeI1eHWXrojQf5isTBKfPQLWVppBkWAf5cA4wP5U1vN9dVirIdw66ds1M8vnGlkTBjxP/HLGBWGYhZHE7QXjXRsk2RIXlHN9q6GdNu8+F3HXS22mst47E4UAeRoiXSMMtF5")
]
-graphiteServer :: Property HasInfo
+graphiteServer :: Property (HasInfo + DebianLike)
graphiteServer = propertyList "iabak graphite server" $ props
& Apt.serviceInstalledRunning "apache2"
& Apt.installed ["libapache2-mod-wsgi", "graphite-carbon", "graphite-web"]
@@ -114,7 +114,8 @@ graphiteServer = propertyList "iabak graphite server" $ props
, "</VirtualHost>"
]
where
+ graphiteCSRF :: Property (HasInfo + DebianLike)
graphiteCSRF = withPrivData (Password "csrf-token") (Context "iabak.archiveteam.org") $
- \gettoken -> property "graphite-web CSRF token" $
- gettoken $ \token -> ensureProperty $ File.containsLine
+ \gettoken -> property' "graphite-web CSRF token" $ \w ->
+ gettoken $ \token -> ensureProperty w $ File.containsLine
"/etc/graphite/local_settings.py" ("SECRET_KEY = '"++ privDataVal token ++"'")
diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs
index 03f2efcb..0ce64939 100644
--- a/src/Propellor/Property/SiteSpecific/JoeySites.hs
+++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs
@@ -1,6 +1,8 @@
-- | Specific configuration for Joey Hess's sites. Probably not useful to
-- others except as an example.
+{-# LANGUAGE FlexibleContexts, TypeFamilies #-}
+
module Propellor.Property.SiteSpecific.JoeySites where
import Propellor.Base
@@ -24,7 +26,7 @@ import Data.List
import System.Posix.Files
import Data.String.Utils
-scrollBox :: Property HasInfo
+scrollBox :: Property (HasInfo + DebianLike)
scrollBox = propertyList "scroll server" $ props
& User.accountFor (User "scroll")
& Git.cloned (User "scroll") "git://git.kitenet.net/scroll" (d </> "scroll") Nothing
@@ -94,16 +96,12 @@ scrollBox = propertyList "scroll server" $ props
s = d </> "login.sh"
g = d </> "game.sh"
-oldUseNetServer :: [Host] -> Property HasInfo
+oldUseNetServer :: [Host] -> Property (HasInfo + DebianLike)
oldUseNetServer hosts = propertyList "olduse.net server" $ props
& Apt.installed ["leafnode"]
& oldUseNetInstalled "oldusenet-server"
& oldUseNetBackup
- & check (not . isSymbolicLink <$> getSymbolicLinkStatus newsspool)
- (property "olduse.net spool in place" $ makeChange $ do
- removeDirectoryRecursive newsspool
- createSymbolicLink (datadir </> "news") newsspool
- )
+ & spoolsymlink
& "/etc/news/leafnode/config" `File.hasContent`
[ "# olduse.net configuration (deployed by propellor)"
, "expire = 1000000" -- no expiry via texpire
@@ -135,7 +133,15 @@ oldUseNetServer hosts = propertyList "olduse.net server" $ props
, Apache.allowAll
, " </Directory>"
]
+
+ spoolsymlink :: Property UnixLike
+ spoolsymlink = check (not . isSymbolicLink <$> getSymbolicLinkStatus newsspool)
+ (property "olduse.net spool in place" $ makeChange $ do
+ removeDirectoryRecursive newsspool
+ createSymbolicLink (datadir </> "news") newsspool
+ )
+ oldUseNetBackup :: Property (HasInfo + DebianLike)
oldUseNetBackup = Obnam.backup datadir (Cron.Times "33 4 * * *")
[ "--repository=sftp://2318@usw-s002.rsync.net/~/olduse.net"
, "--client-name=spool"
@@ -149,12 +155,12 @@ oldUseNetServer hosts = propertyList "olduse.net server" $ props
`requires` Ssh.knownHost hosts "usw-s002.rsync.net" (User "root")
keyfile = "/root/.ssh/olduse.net.key"
-oldUseNetShellBox :: Property HasInfo
+oldUseNetShellBox :: Property DebianLike
oldUseNetShellBox = propertyList "olduse.net shellbox" $ props
& oldUseNetInstalled "oldusenet"
& Service.running "shellinabox"
-oldUseNetInstalled :: Apt.Package -> Property HasInfo
+oldUseNetInstalled :: Apt.Package -> Property DebianLike
oldUseNetInstalled pkg = check (not <$> Apt.isInstalled pkg) $
propertyList ("olduse.net " ++ pkg) $ props
& Apt.installed (words "build-essential devscripts debhelper git libncursesw5-dev libpcre3-dev pkg-config bison libicu-dev libidn11-dev libcanlock2-dev libuu-dev ghc libghc-strptime-dev libghc-hamlet-dev libghc-ifelse-dev libghc-hxt-dev libghc-utf8-string-dev libghc-missingh-dev libghc-sha-dev")
@@ -170,25 +176,25 @@ oldUseNetInstalled pkg = check (not <$> Apt.isInstalled pkg) $
]
`assume` MadeChange
`describe` "olduse.net built"
-
-kgbServer :: Property HasInfo
+
+kgbServer :: Property (HasInfo + Debian)
kgbServer = propertyList desc $ props
& installed
& File.hasPrivContent "/etc/kgb-bot/kgb.conf" anyContext
`onChange` Service.restarted "kgb-bot"
where
desc = "kgb.kitenet.net setup"
- installed = withOS desc $ \o -> case o of
+ installed :: Property Debian
+ installed = withOS desc $ \w o -> case o of
(Just (System (Debian Unstable) _)) ->
- ensureProperty $ propertyList desc
- [ Apt.serviceInstalledRunning "kgb-bot"
- , "/etc/default/kgb-bot" `File.containsLine` "BOT_ENABLED=1"
+ ensureProperty w $ propertyList desc $ props
+ & Apt.serviceInstalledRunning "kgb-bot"
+ & "/etc/default/kgb-bot" `File.containsLine` "BOT_ENABLED=1"
`describe` "kgb bot enabled"
`onChange` Service.running "kgb-bot"
- ]
_ -> error "kgb server needs Debian unstable (for kgb-bot 1.31+)"
-mumbleServer :: [Host] -> Property HasInfo
+mumbleServer :: [Host] -> Property (HasInfo + DebianLike)
mumbleServer hosts = combineProperties hn $ props
& Apt.serviceInstalledRunning "mumble-server"
& Obnam.backup "/var/lib/mumble-server" (Cron.Times "55 5 * * *")
@@ -209,7 +215,7 @@ mumbleServer hosts = combineProperties hn $ props
sshkey = "/root/.ssh/mumble.debian.net.key"
-- git.kitenet.net and git.joeyh.name
-gitServer :: [Host] -> Property HasInfo
+gitServer :: [Host] -> Property (HasInfo + DebianLike)
gitServer hosts = propertyList "git.kitenet.net setup" $ props
& Obnam.backupEncrypted "/srv/git" (Cron.Times "33 3 * * *")
[ "--repository=sftp://2318@usw-s002.rsync.net/~/git.kitenet.net"
@@ -266,7 +272,7 @@ gitServer hosts = propertyList "git.kitenet.net setup" $ props
type AnnexUUID = String
-- | A website, with files coming from a git-annex repository.
-annexWebSite :: Git.RepoUrl -> HostName -> AnnexUUID -> [(String, Git.RepoUrl)] -> Property HasInfo
+annexWebSite :: Git.RepoUrl -> HostName -> AnnexUUID -> [(String, Git.RepoUrl)] -> Property (HasInfo + DebianLike)
annexWebSite origin hn uuid remotes = propertyList (hn ++" website using git-annex") $ props
& Git.cloned (User "joey") origin dir Nothing
`onChange` setup
@@ -308,7 +314,7 @@ annexWebSite origin hn uuid remotes = propertyList (hn ++" website using git-ann
, " </Directory>"
]
-apacheSite :: HostName -> Bool -> Apache.ConfigFile -> RevertableProperty NoInfo
+apacheSite :: HostName -> Bool -> Apache.ConfigFile -> RevertableProperty DebianLike DebianLike
apacheSite hn withssl middle = Apache.siteEnabled hn $ apachecfg hn withssl middle
apachecfg :: HostName -> Bool -> Apache.ConfigFile -> Apache.ConfigFile
@@ -348,7 +354,7 @@ mainhttpscert True =
, " SSLCertificateChainFile /etc/ssl/certs/startssl.pem"
]
-gitAnnexDistributor :: Property HasInfo
+gitAnnexDistributor :: Property (HasInfo + DebianLike)
gitAnnexDistributor = combineProperties "git-annex distributor, including rsync server and signer" $ props
& Apt.installed ["rsync"]
& File.hasPrivContent "/etc/rsyncd.conf" (Context "git-annex distributor")
@@ -364,19 +370,18 @@ gitAnnexDistributor = combineProperties "git-annex distributor, including rsync
-- git-annex distribution signing key
& Gpg.keyImported (Gpg.GpgKeyId "89C809CB") (User "joey")
where
- endpoint d = combineProperties ("endpoint " ++ d)
- [ File.dirExists d
- , File.ownerGroup d (User "joey") (Group "joey")
- ]
+ endpoint d = combineProperties ("endpoint " ++ d) $ props
+ & File.dirExists d
+ & File.ownerGroup d (User "joey") (Group "joey")
-downloads :: [Host] -> Property HasInfo
+downloads :: [Host] -> Property (HasInfo + DebianLike)
downloads hosts = annexWebSite "/srv/git/downloads.git"
"downloads.kitenet.net"
"840760dc-08f0-11e2-8c61-576b7e66acfd"
[("eubackup", "ssh://eubackup.kitenet.net/~/lib/downloads/")]
`requires` Ssh.knownHost hosts "eubackup.kitenet.net" (User "joey")
-tmp :: Property HasInfo
+tmp :: Property (HasInfo + DebianLike)
tmp = propertyList "tmp.kitenet.net" $ props
& annexWebSite "/srv/git/joey/tmp.git"
"tmp.kitenet.net"
@@ -386,7 +391,7 @@ tmp = propertyList "tmp.kitenet.net" $ props
& pumpRss
-- Twitter, you kill us.
-twitRss :: Property HasInfo
+twitRss :: Property DebianLike
twitRss = combineProperties "twitter rss" $ props
& Git.cloned (User "joey") "git://git.kitenet.net/twitrss.git" dir Nothing
& check (not <$> doesFileExist (dir </> "twitRss")) compiled
@@ -409,11 +414,11 @@ twitRss = combineProperties "twitter rss" $ props
]
-- Work around for expired ssl cert.
-pumpRss :: Property NoInfo
+pumpRss :: Property DebianLike
pumpRss = Cron.job "pump rss" (Cron.Times "15 * * * *") (User "joey") "/srv/web/tmp.kitenet.net/"
"wget https://rss.io.jpope.org/feed/joeyh@identi.ca.atom -O pump.atom.new --no-check-certificate 2>/dev/null; sed 's/ & / /g' pump.atom.new > pump.atom"
-ircBouncer :: Property HasInfo
+ircBouncer :: Property (HasInfo + DebianLike)
ircBouncer = propertyList "IRC bouncer" $ props
& Apt.installed ["znc"]
& User.accountFor (User "znc")
@@ -428,20 +433,19 @@ ircBouncer = propertyList "IRC bouncer" $ props
where
conf = "/home/znc/.znc/configs/znc.conf"
-kiteShellBox :: Property NoInfo
-kiteShellBox = propertyList "kitenet.net shellinabox"
- [ Apt.installed ["openssl", "shellinabox", "openssh-client"]
- , File.hasContent "/etc/default/shellinabox"
+kiteShellBox :: Property DebianLike
+kiteShellBox = propertyList "kitenet.net shellinabox" $ props
+ & Apt.installed ["openssl", "shellinabox", "openssh-client"]
+ & File.hasContent "/etc/default/shellinabox"
[ "# Deployed by propellor"
, "SHELLINABOX_DAEMON_START=1"
, "SHELLINABOX_PORT=443"
, "SHELLINABOX_ARGS=\"--no-beep --service=/:SSH:kitenet.net\""
]
`onChange` Service.restarted "shellinabox"
- , Service.running "shellinabox"
- ]
+ & Service.running "shellinabox"
-githubBackup :: Property HasInfo
+githubBackup :: Property (HasInfo + DebianLike)
githubBackup = propertyList "github-backup box" $ props
& Apt.installed ["github-backup", "moreutils"]
& githubKeys
@@ -462,7 +466,7 @@ githubBackup = propertyList "github-backup box" $ props
] ++ map gitriddance githubMirrors
gitriddance (r, msg) = "(cd " ++ r ++ " && gitriddance " ++ shellEscape msg ++ ")"
-githubKeys :: Property HasInfo
+githubKeys :: Property (HasInfo + UnixLike)
githubKeys =
let f = "/home/joey/.github-keys"
in File.hasPrivContent f anyContext
@@ -482,12 +486,12 @@ githubMirrors =
where
plzuseurl u = "Please submit changes to " ++ u ++ " instead of using github pull requests, which are not part of my workflow. Just open a todo item there and link to a git repository containing your changes. Did you know, git is a distributed system? The git repository doesn't even need to be on github! Please send any complaints to Github; they don't allow turning off pull requests or redirecting them elsewhere. -- A robot acting on behalf of Joey Hess"
-rsyncNetBackup :: [Host] -> Property NoInfo
+rsyncNetBackup :: [Host] -> Property DebianLike
rsyncNetBackup hosts = Cron.niceJob "rsync.net copied in daily" (Cron.Times "30 5 * * *")
(User "joey") "/home/joey/lib/backup" "mkdir -p rsync.net && rsync --delete -az 2318@usw-s002.rsync.net: rsync.net"
`requires` Ssh.knownHost hosts "usw-s002.rsync.net" (User "joey")
-backupsBackedupFrom :: [Host] -> HostName -> FilePath -> Property NoInfo
+backupsBackedupFrom :: [Host] -> HostName -> FilePath -> Property DebianLike
backupsBackedupFrom hosts srchost destdir = Cron.niceJob desc
(Cron.Times "@reboot") (User "joey") "/" cmd
`requires` Ssh.knownHost hosts srchost (User "joey")
@@ -495,9 +499,9 @@ backupsBackedupFrom hosts srchost destdir = Cron.niceJob desc
desc = "backups copied from " ++ srchost ++ " on boot"
cmd = "sleep 30m && rsync -az --bwlimit=300K --partial --delete " ++ srchost ++ ":lib/backup/ " ++ destdir </> srchost
-obnamRepos :: [String] -> Property NoInfo
-obnamRepos rs = propertyList ("obnam repos for " ++ unwords rs)
- (mkbase : map mkrepo rs)
+obnamRepos :: [String] -> Property UnixLike
+obnamRepos rs = propertyList ("obnam repos for " ++ unwords rs) $
+ toProps (mkbase : map mkrepo rs)
where
mkbase = mkdir "/home/joey/lib/backup"
`requires` mkdir "/home/joey/lib"
@@ -505,13 +509,13 @@ obnamRepos rs = propertyList ("obnam repos for " ++ unwords rs)
mkdir d = File.dirExists d
`before` File.ownerGroup d (User "joey") (Group "joey")
-podcatcher :: Property NoInfo
+podcatcher :: Property DebianLike
podcatcher = Cron.niceJob "podcatcher run hourly" (Cron.Times "55 * * * *")
(User "joey") "/home/joey/lib/sound/podcasts"
"xargs git-annex importfeed -c annex.genmetadata=true < feeds; mr --quiet update"
`requires` Apt.installed ["git-annex", "myrepos"]
-kiteMailServer :: Property HasInfo
+kiteMailServer :: Property (HasInfo + DebianLike)
kiteMailServer = propertyList "kitenet.net mail server" $ props
& Postfix.installed
& Apt.installed ["postfix-pcre"]
@@ -710,7 +714,7 @@ kiteMailServer = propertyList "kitenet.net mail server" $ props
-- Configures postfix to relay outgoing mail to kitenet.net, with
-- verification via tls cert.
-postfixClientRelay :: Context -> Property HasInfo
+postfixClientRelay :: Context -> Property (HasInfo + DebianLike)
postfixClientRelay ctx = Postfix.mainCfFile `File.containsLines`
-- Using smtps not smtp because more networks firewall smtp
[ "relayhost = kitenet.net:smtps"
@@ -727,7 +731,7 @@ postfixClientRelay ctx = Postfix.mainCfFile `File.containsLines`
`requires` hasPostfixCert ctx
-- Configures postfix to have the dkim milter, and no other milters.
-dkimMilter :: Property HasInfo
+dkimMilter :: Property (HasInfo + DebianLike)
dkimMilter = Postfix.mainCfFile `File.containsLines`
[ "smtpd_milters = inet:localhost:8891"
, "non_smtpd_milters = inet:localhost:8891"
@@ -740,7 +744,7 @@ dkimMilter = Postfix.mainCfFile `File.containsLines`
-- This does not configure postfix to use the dkim milter,
-- nor does it set up domainkey DNS.
-dkimInstalled :: Property HasInfo
+dkimInstalled :: Property (HasInfo + DebianLike)
dkimInstalled = go `onChange` Service.restarted "opendkim"
where
go = propertyList "opendkim installed" $ props
@@ -763,17 +767,16 @@ dkimInstalled = go `onChange` Service.restarted "opendkim"
domainKey :: (BindDomain, Record)
domainKey = (RelDomain "mail._domainkey", TXT "v=DKIM1; k=rsa; p=MIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKBgQCc+/rfzNdt5DseBBmfB3C6sVM7FgVvf4h1FeCfyfwPpVcmPdW6M2I+NtJsbRkNbEICxiP6QY2UM0uoo9TmPqLgiCCG2vtuiG6XMsS0Y/gGwqKM7ntg/7vT1Go9vcquOFFuLa5PnzpVf8hB9+PMFdS4NPTvWL2c5xxshl/RJzICnQIDAQAB")
-hasJoeyCAChain :: Property HasInfo
+hasJoeyCAChain :: Property (HasInfo + UnixLike)
hasJoeyCAChain = "/etc/ssl/certs/joeyca.pem" `File.hasPrivContentExposed`
Context "joeyca.pem"
-hasPostfixCert :: Context -> Property HasInfo
-hasPostfixCert ctx = combineProperties "postfix tls cert installed"
- [ "/etc/ssl/certs/postfix.pem" `File.hasPrivContentExposed` ctx
- , "/etc/ssl/private/postfix.pem" `File.hasPrivContent` ctx
- ]
+hasPostfixCert :: Context -> Property (HasInfo + UnixLike)
+hasPostfixCert ctx = combineProperties "postfix tls cert installed" $ props
+ & "/etc/ssl/certs/postfix.pem" `File.hasPrivContentExposed` ctx
+ & "/etc/ssl/private/postfix.pem" `File.hasPrivContent` ctx
-kitenetHttps :: Property HasInfo
+kitenetHttps :: Property (HasInfo + DebianLike)
kitenetHttps = propertyList "kitenet.net https certs" $ props
& File.hasPrivContent "/etc/ssl/certs/web.pem" ctx
& File.hasPrivContent "/etc/ssl/private/web.pem" ctx
@@ -784,7 +787,7 @@ kitenetHttps = propertyList "kitenet.net https certs" $ props
-- Legacy static web sites and redirections from kitenet.net to newer
-- sites.
-legacyWebSites :: Property HasInfo
+legacyWebSites :: Property (HasInfo + DebianLike)
legacyWebSites = propertyList "legacy web sites" $ props
& Apt.serviceInstalledRunning "apache2"
& Apache.modEnabled "rewrite"
@@ -944,7 +947,7 @@ legacyWebSites = propertyList "legacy web sites" $ props
, "rewriterule (.*) http://joeyh.name$1 [r]"
]
-userDirHtml :: Property NoInfo
+userDirHtml :: Property DebianLike
userDirHtml = File.fileProperty "apache userdir is html" (map munge) conf
`onChange` Apache.reloaded
`requires` Apache.modEnabled "userdir"
@@ -956,10 +959,9 @@ userDirHtml = File.fileProperty "apache userdir is html" (map munge) conf
-- <http://joeyh.name/blog/entry/a_programmable_alarm_clock_using_systemd/>
--
-- oncalendar example value: "*-*-* 7:30"
-alarmClock :: String -> User -> String -> Property NoInfo
-alarmClock oncalendar (User user) command = combineProperties
- "goodmorning timer installed"
- [ "/etc/systemd/system/goodmorning.timer" `File.hasContent`
+alarmClock :: String -> User -> String -> Property DebianLike
+alarmClock oncalendar (User user) command = combineProperties "goodmorning timer installed" $ props
+ & "/etc/systemd/system/goodmorning.timer" `File.hasContent`
[ "[Unit]"
, "Description=good morning"
, ""
@@ -974,7 +976,7 @@ alarmClock oncalendar (User user) command = combineProperties
]
`onChange` (Systemd.daemonReloaded
`before` Systemd.restarted "goodmorning.timer")
- , "/etc/systemd/system/goodmorning.service" `File.hasContent`
+ & "/etc/systemd/system/goodmorning.service" `File.hasContent`
[ "[Unit]"
, "Description=good morning"
, "RefuseManualStart=true"
@@ -987,8 +989,7 @@ alarmClock oncalendar (User user) command = combineProperties
, "ExecStart=/bin/systemd-inhibit --what=handle-lid-switch --why=goodmorning /bin/su " ++ user ++ " -c \"" ++ command ++ "\""
]
`onChange` Systemd.daemonReloaded
- , Systemd.enabled "goodmorning.timer"
- , Systemd.started "goodmorning.timer"
- , "/etc/systemd/logind.conf" `ConfFile.containsIniSetting`
+ & Systemd.enabled "goodmorning.timer"
+ & Systemd.started "goodmorning.timer"
+ & "/etc/systemd/logind.conf" `ConfFile.containsIniSetting`
("Login", "LidSwitchIgnoreInhibited", "no")
- ]
diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs
index 26cdbeb7..6e1690d2 100644
--- a/src/Propellor/Property/Ssh.hs
+++ b/src/Propellor/Property/Ssh.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveDataTypeable, TypeFamilies #-}
module Propellor.Property.Ssh (
installed,
@@ -47,10 +47,13 @@ import qualified Data.Map as M
import qualified Data.Set as S
import Data.List
-installed :: Property NoInfo
-installed = Apt.installed ["ssh"]
+installed :: Property UnixLike
+installed = "ssh installed" ==> (aptinstall `pickOS` unsupportedOS)
+ where
+ aptinstall :: Property DebianLike
+ aptinstall = Apt.installed ["ssh"]
-restarted :: Property NoInfo
+restarted :: Property DebianLike
restarted = Service.restarted "ssh"
sshBool :: Bool -> String
@@ -62,10 +65,10 @@ sshdConfig = "/etc/ssh/sshd_config"
type ConfigKeyword = String
-setSshdConfigBool :: ConfigKeyword -> Bool -> Property NoInfo
+setSshdConfigBool :: ConfigKeyword -> Bool -> Property DebianLike
setSshdConfigBool setting allowed = setSshdConfig setting (sshBool allowed)
-setSshdConfig :: ConfigKeyword -> String -> Property NoInfo
+setSshdConfig :: ConfigKeyword -> String -> Property DebianLike
setSshdConfig setting val = File.fileProperty desc f sshdConfig
`onChange` restarted
where
@@ -84,19 +87,19 @@ data RootLogin
| WithoutPassword -- ^ disable password authentication for root, while allowing other authentication methods
| ForcedCommandsOnly -- ^ allow root login with public-key authentication, but only if a forced command has been specified for the public key
-permitRootLogin :: RootLogin -> Property NoInfo
+permitRootLogin :: RootLogin -> Property DebianLike
permitRootLogin (RootLogin b) = setSshdConfigBool "PermitRootLogin" b
permitRootLogin WithoutPassword = setSshdConfig "PermitRootLogin" "without-password"
permitRootLogin ForcedCommandsOnly = setSshdConfig "PermitRootLogin" "forced-commands-only"
-passwordAuthentication :: Bool -> Property NoInfo
+passwordAuthentication :: Bool -> Property DebianLike
passwordAuthentication = setSshdConfigBool "PasswordAuthentication"
-- | Configure ssh to not allow password logins.
--
-- To prevent lock-out, this is done only once root's
-- authorized_keys is in place.
-noPasswords :: Property NoInfo
+noPasswords :: Property DebianLike
noPasswords = check (hasAuthorizedKeys (User "root")) $
passwordAuthentication False
@@ -114,7 +117,7 @@ dotFile f user = do
-- ports it is configured to listen on.
--
-- Revert to prevent it listening on a particular port.
-listenPort :: Port -> RevertableProperty NoInfo
+listenPort :: Port -> RevertableProperty DebianLike DebianLike
listenPort port = enable <!> disable
where
portline = "Port " ++ fromPort port
@@ -133,16 +136,17 @@ hasAuthorizedKeys = go <=< dotFile "authorized_keys"
-- | Blows away existing host keys and make new ones.
-- Useful for systems installed from an image that might reuse host keys.
-- A flag file is used to only ever do this once.
-randomHostKeys :: Property NoInfo
+randomHostKeys :: Property DebianLike
randomHostKeys = flagFile prop "/etc/ssh/.unique_host_keys"
`onChange` restarted
where
- prop = property "ssh random host keys" $ do
+ prop :: Property UnixLike
+ prop = property' "ssh random host keys" $ \w -> do
void $ liftIO $ boolSystem "sh"
[ Param "-c"
, Param "rm -f /etc/ssh/ssh_host_*"
]
- ensureProperty $ scriptProperty [ "DPKG_MAINTSCRIPT_NAME=postinst DPKG_MAINTSCRIPT_PACKAGE=openssh-server /var/lib/dpkg/info/openssh-server.postinst configure" ]
+ ensureProperty w $ scriptProperty [ "DPKG_MAINTSCRIPT_NAME=postinst DPKG_MAINTSCRIPT_PACKAGE=openssh-server /var/lib/dpkg/info/openssh-server.postinst configure" ]
`assume` MadeChange
-- | The text of a ssh public key, for example, "ssh-ed25519 AAAAC3NzaC1lZDI1NTE5AAAAIB3BJ2GqZiTR2LEoDXyYFgh/BduWefjdKXAsAtzS9zeI"
@@ -153,43 +157,51 @@ type PubKeyText = String
-- The corresponding private keys come from the privdata.
--
-- Any host keys that are not in the list are removed from the host.
-hostKeys :: IsContext c => c -> [(SshKeyType, PubKeyText)] -> Property HasInfo
-hostKeys ctx l = propertyList desc $ catMaybes $
- map (\(t, pub) -> Just $ hostKey ctx t pub) l ++ [cleanup]
+hostKeys :: IsContext c => c -> [(SshKeyType, PubKeyText)] -> Property (HasInfo + DebianLike)
+hostKeys ctx l = go `before` cleanup
where
desc = "ssh host keys configured " ++ typelist (map fst l)
+ go :: Property (HasInfo + DebianLike)
+ go = propertyList desc $ toProps $ catMaybes $
+ map (\(t, pub) -> Just $ hostKey ctx t pub) l
typelist tl = "(" ++ unwords (map fromKeyType tl) ++ ")"
alltypes = [minBound..maxBound]
staletypes = let have = map fst l in filter (`notElem` have) alltypes
- removestale b = map (File.notPresent . flip keyFile b) staletypes
+ removestale :: Bool -> [Property DebianLike]
+ removestale b = map (tightenTargets . File.notPresent . flip keyFile b) staletypes
+ cleanup :: Property DebianLike
cleanup
- | null staletypes || null l = Nothing
- | otherwise = Just $ toProp $
- property ("any other ssh host keys removed " ++ typelist staletypes) $
- ensureProperty $
- combineProperties desc (removestale True ++ removestale False)
- `onChange` restarted
+ | null staletypes || null l = doNothing
+ | otherwise =
+ combineProperties ("any other ssh host keys removed " ++ typelist staletypes)
+ (toProps $ removestale True ++ removestale False)
+ `onChange` restarted
-- | Installs a single ssh host key of a particular type.
--
-- The public key is provided to this function;
-- the private key comes from the privdata;
-hostKey :: IsContext c => c -> SshKeyType -> PubKeyText -> Property HasInfo
-hostKey context keytype pub = combineProperties desc
- [ hostPubKey keytype pub
- , toProp $ property desc $ install File.hasContent True (lines pub)
- , withPrivData (keysrc "" (SshPrivKey keytype "")) context $ \getkey ->
- property desc $ getkey $
- install File.hasContentProtected False . privDataLines
- ]
- `onChange` restarted
+hostKey :: IsContext c => c -> SshKeyType -> PubKeyText -> Property (HasInfo + DebianLike)
+hostKey context keytype pub = go `onChange` restarted
where
+ go = combineProperties desc $ props
+ & hostPubKey keytype pub
+ & installpub
+ & installpriv
desc = "ssh host key configured (" ++ fromKeyType keytype ++ ")"
- install writer ispub keylines = do
- let f = keyFile keytype ispub
- ensureProperty $ writer f (keyFileContent keylines)
keysrc ext field = PrivDataSourceFileFromCommand field ("sshkey"++ext)
("ssh-keygen -t " ++ sshKeyTypeParam keytype ++ " -f sshkey")
+ installpub :: Property UnixLike
+ installpub = keywriter File.hasContent True (lines pub)
+ installpriv :: Property (HasInfo + UnixLike)
+ installpriv = withPrivData (keysrc "" (SshPrivKey keytype "")) context $ \getkey ->
+ property' desc $ \w -> getkey $
+ ensureProperty w
+ . keywriter File.hasContentProtected False
+ . privDataLines
+ keywriter p ispub keylines = do
+ let f = keyFile keytype ispub
+ p f (keyFileContent keylines)
-- Make sure that there is a newline at the end;
-- ssh requires this for some types of private keys.
@@ -204,7 +216,7 @@ keyFile keytype ispub = "/etc/ssh/ssh_host_" ++ fromKeyType keytype ++ "_key" ++
-- | Indicates the host key that is used by a Host, but does not actually
-- configure the host to use it. Normally this does not need to be used;
-- use 'hostKey' instead.
-hostPubKey :: SshKeyType -> PubKeyText -> Property HasInfo
+hostPubKey :: SshKeyType -> PubKeyText -> Property (HasInfo + UnixLike)
hostPubKey t = pureInfoProperty "ssh pubkey known" . HostKeyInfo . M.singleton t
getHostPubKey :: Propellor (M.Map SshKeyType PubKeyText)
@@ -224,7 +236,7 @@ instance Monoid HostKeyInfo where
-- parameter when there is a duplicate key
HostKeyInfo (new `M.union` old)
-userPubKeys :: User -> [(SshKeyType, PubKeyText)] -> Property HasInfo
+userPubKeys :: User -> [(SshKeyType, PubKeyText)] -> Property (HasInfo + UnixLike)
userPubKeys u@(User n) l = pureInfoProperty ("ssh pubkey for " ++ n) $
UserKeyInfo (M.singleton u (S.fromList l))
@@ -248,8 +260,8 @@ instance Monoid UserKeyInfo where
--
-- The public keys are added to the Info, so other properties like
-- `authorizedKeysFrom` can use them.
-userKeys :: IsContext c => User -> c -> [(SshKeyType, PubKeyText)] -> Property HasInfo
-userKeys user@(User name) context ks = combineProperties desc $
+userKeys :: IsContext c => User -> c -> [(SshKeyType, PubKeyText)] -> Property (HasInfo + UnixLike)
+userKeys user@(User name) context ks = combineProperties desc $ toProps $
userPubKeys user ks : map (userKeyAt Nothing user context) ks
where
desc = unwords
@@ -264,7 +276,7 @@ userKeys user@(User name) context ks = combineProperties desc $
-- A file can be specified to write the key to somewhere other than
-- the default locations. Allows a user to have multiple keys for
-- different roles.
-userKeyAt :: IsContext c => Maybe FilePath -> User -> c -> (SshKeyType, PubKeyText) -> Property HasInfo
+userKeyAt :: IsContext c => Maybe FilePath -> User -> c -> (SshKeyType, PubKeyText) -> Property (HasInfo + UnixLike)
userKeyAt dest user@(User u) context (keytype, pubkeytext) =
combineProperties desc $ props
& pubkey
@@ -276,17 +288,21 @@ userKeyAt dest user@(User u) context (keytype, pubkeytext) =
, dest
, Just $ "(" ++ fromKeyType keytype ++ ")"
]
- pubkey = property desc $ install File.hasContent ".pub" [pubkeytext]
- privkey = withPrivData (SshPrivKey keytype u) context $ \getkey ->
- property desc $ getkey $
- install File.hasContentProtected "" . privDataLines
- install writer ext key = do
+ pubkey :: Property UnixLike
+ pubkey = property' desc $ \w ->
+ ensureProperty w =<< installprop File.hasContent ".pub" [pubkeytext]
+ privkey :: Property (HasInfo + UnixLike)
+ privkey = withPrivData (SshPrivKey keytype u) context privkey'
+ privkey' :: ((PrivData -> Propellor Result) -> Propellor Result) -> Property (HasInfo + UnixLike)
+ privkey' getkey = property' desc $ \w -> getkey $ \k ->
+ ensureProperty w
+ =<< installprop File.hasContentProtected "" (privDataLines k)
+ installprop writer ext key = do
f <- liftIO $ keyfile ext
- ensureProperty $ combineProperties desc
- [ writer f (keyFileContent key)
- , File.ownerGroup f user (userGroup user)
- , File.ownerGroup (takeDirectory f) user (userGroup user)
- ]
+ return $ combineProperties desc $ props
+ & writer f (keyFileContent key)
+ & File.ownerGroup f user (userGroup user)
+ & File.ownerGroup (takeDirectory f) user (userGroup user)
keyfile ext = case dest of
Nothing -> do
home <- homeDirectory <$> getUserEntryForName u
@@ -301,33 +317,34 @@ fromKeyType SshEd25519 = "ed25519"
-- | Puts some host's ssh public key(s), as set using `hostPubKey`
-- or `hostKey` into the known_hosts file for a user.
-knownHost :: [Host] -> HostName -> User -> Property NoInfo
-knownHost hosts hn user@(User u) = property desc $
- go =<< knownHostLines hosts hn
+knownHost :: [Host] -> HostName -> User -> Property UnixLike
+knownHost hosts hn user@(User u) = property' desc $ \w ->
+ go w =<< knownHostLines hosts hn
where
desc = u ++ " knows ssh key for " ++ hn
- go [] = do
+ go _ [] = do
warningMessage $ "no configured ssh host keys for " ++ hn
return FailedChange
- go ls = do
+ go w ls = do
f <- liftIO $ dotFile "known_hosts" user
- modKnownHost user f $
+ ensureProperty w $ modKnownHost user f $
f `File.containsLines` ls
`requires` File.dirExists (takeDirectory f)
-- | Reverts `knownHost`
-unknownHost :: [Host] -> HostName -> User -> Property NoInfo
-unknownHost hosts hn user@(User u) = property desc $
- go =<< knownHostLines hosts hn
+unknownHost :: [Host] -> HostName -> User -> Property UnixLike
+unknownHost hosts hn user@(User u) = property' desc $ \w ->
+ go w =<< knownHostLines hosts hn
where
desc = u ++ " does not know ssh key for " ++ hn
- go [] = return NoChange
- go ls = do
+ go _ [] = return NoChange
+ go w ls = do
f <- liftIO $ dotFile "known_hosts" user
ifM (liftIO $ doesFileExist f)
- ( modKnownHost user f $ f `File.lacksLines` ls
+ ( ensureProperty w $ modKnownHost user f $
+ f `File.lacksLines` ls
, return NoChange
)
@@ -337,8 +354,8 @@ knownHostLines hosts hn = keylines <$> fromHost hosts hn getHostPubKey
keylines (Just m) = map (\k -> hn ++ " " ++ k) (M.elems m)
keylines Nothing = []
-modKnownHost :: User -> FilePath -> Property NoInfo -> Propellor Result
-modKnownHost user f p = ensureProperty $ p
+modKnownHost :: User -> FilePath -> Property UnixLike -> Property UnixLike
+modKnownHost user f p = p
`requires` File.ownerGroup f user (userGroup user)
`requires` File.ownerGroup (takeDirectory f) user (userGroup user)
@@ -348,30 +365,30 @@ modKnownHost user f p = ensureProperty $ p
-- The ssh keys of the remote user can be set using `keysImported`
--
-- Any other lines in the authorized_keys file are preserved as-is.
-authorizedKeysFrom :: User -> (User, Host) -> Property NoInfo
+authorizedKeysFrom :: User -> (User, Host) -> Property UnixLike
localuser@(User ln) `authorizedKeysFrom` (remoteuser@(User rn), remotehost) =
- property desc (go =<< authorizedKeyLines remoteuser remotehost)
+ property' desc (\w -> go w =<< authorizedKeyLines remoteuser remotehost)
where
remote = rn ++ "@" ++ hostName remotehost
desc = ln ++ " authorized_keys from " ++ remote
- go [] = do
+ go _ [] = do
warningMessage $ "no configured ssh user keys for " ++ remote
return FailedChange
- go ls = ensureProperty $ combineProperties desc $
- map (authorizedKey localuser) ls
+ go w ls = ensureProperty w $ combineProperties desc $ toProps $
+ map (setupRevertableProperty . authorizedKey localuser) ls
-- | Reverts `authorizedKeysFrom`
-unauthorizedKeysFrom :: User -> (User, Host) -> Property NoInfo
+unauthorizedKeysFrom :: User -> (User, Host) -> Property UnixLike
localuser@(User ln) `unauthorizedKeysFrom` (remoteuser@(User rn), remotehost) =
- property desc (go =<< authorizedKeyLines remoteuser remotehost)
+ property' desc (\w -> go w =<< authorizedKeyLines remoteuser remotehost)
where
remote = rn ++ "@" ++ hostName remotehost
desc = ln ++ " unauthorized_keys from " ++ remote
- go [] = return NoChange
- go ls = ensureProperty $ combineProperties desc $
- map (revert . authorizedKey localuser) ls
+ go _ [] = return NoChange
+ go w ls = ensureProperty w $ combineProperties desc $ toProps $
+ map (undoRevertableProperty . authorizedKey localuser) ls
authorizedKeyLines :: User -> Host -> Propellor [File.Line]
authorizedKeyLines remoteuser remotehost =
@@ -380,37 +397,37 @@ authorizedKeyLines remoteuser remotehost =
-- | Makes a user have authorized_keys from the PrivData
--
-- This removes any other lines from the file.
-authorizedKeys :: IsContext c => User -> c -> Property HasInfo
+authorizedKeys :: IsContext c => User -> c -> Property (HasInfo + UnixLike)
authorizedKeys user@(User u) context = withPrivData (SshAuthorizedKeys u) context $ \get ->
- property desc $ get $ \v -> do
+ property' desc $ \w -> get $ \v -> do
f <- liftIO $ dotFile "authorized_keys" user
- ensureProperty $ combineProperties desc
- [ File.hasContentProtected f (keyFileContent (privDataLines v))
- , File.ownerGroup f user (userGroup user)
- , File.ownerGroup (takeDirectory f) user (userGroup user)
- ]
+ ensureProperty w $ combineProperties desc $ props
+ & File.hasContentProtected f (keyFileContent (privDataLines v))
+ & File.ownerGroup f user (userGroup user)
+ & File.ownerGroup (takeDirectory f) user (userGroup user)
where
desc = u ++ " has authorized_keys"
-- | Ensures that a user's authorized_keys contains a line.
-- Any other lines in the file are preserved as-is.
-authorizedKey :: User -> String -> RevertableProperty NoInfo
+authorizedKey :: User -> String -> RevertableProperty UnixLike UnixLike
authorizedKey user@(User u) l = add <!> remove
where
- add = property (u ++ " has authorized_keys") $ do
+ add = property' (u ++ " has authorized_keys") $ \w -> do
f <- liftIO $ dotFile "authorized_keys" user
- modAuthorizedKey f user $
+ ensureProperty w $ modAuthorizedKey f user $
f `File.containsLine` l
`requires` File.dirExists (takeDirectory f)
- remove = property (u ++ " lacks authorized_keys") $ do
+ remove = property' (u ++ " lacks authorized_keys") $ \w -> do
f <- liftIO $ dotFile "authorized_keys" user
ifM (liftIO $ doesFileExist f)
- ( modAuthorizedKey f user $ f `File.lacksLine` l
+ ( ensureProperty w $ modAuthorizedKey f user $
+ f `File.lacksLine` l
, return NoChange
)
-modAuthorizedKey :: FilePath -> User -> Property NoInfo -> Propellor Result
-modAuthorizedKey f user p = ensureProperty $ p
+modAuthorizedKey :: FilePath -> User -> Property UnixLike -> Property UnixLike
+modAuthorizedKey f user p = p
`before` File.mode f (combineModes [ownerWriteMode, ownerReadMode])
`before` File.ownerGroup f user (userGroup user)
`before` File.ownerGroup (takeDirectory f) user (userGroup user)
diff --git a/src/Propellor/Property/Sudo.hs b/src/Propellor/Property/Sudo.hs
index ed6ba2d5..45ab8af2 100644
--- a/src/Propellor/Property/Sudo.hs
+++ b/src/Propellor/Property/Sudo.hs
@@ -9,12 +9,13 @@ import Propellor.Property.User
-- | Allows a user to sudo. If the user has a password, sudo is configured
-- to require it. If not, NOPASSWORD is enabled for the user.
-enabledFor :: User -> Property NoInfo
-enabledFor user@(User u) = property desc go `requires` Apt.installed ["sudo"]
+enabledFor :: User -> Property DebianLike
+enabledFor user@(User u) = go `requires` Apt.installed ["sudo"]
where
- go = do
+ go :: Property UnixLike
+ go = property' desc $ \w -> do
locked <- liftIO $ isLockedPassword user
- ensureProperty $
+ ensureProperty w $
fileProperty desc
(modify locked . filter (wanted locked))
"/etc/sudoers"
diff --git a/src/Propellor/Property/Systemd.hs b/src/Propellor/Property/Systemd.hs
index 2234ad5c..e0b7d572 100644
--- a/src/Propellor/Property/Systemd.hs
+++ b/src/Propellor/Property/Systemd.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleInstances, TypeFamilies #-}
module Propellor.Property.Systemd (
-- * Services
@@ -25,6 +25,7 @@ module Propellor.Property.Systemd (
MachineName,
Container,
container,
+ debContainer,
nspawned,
-- * Container configuration
containerCfg,
@@ -43,6 +44,7 @@ module Propellor.Property.Systemd (
import Propellor.Base
import Propellor.Types.Chroot
import Propellor.Types.Container
+import Propellor.Container
import Propellor.Types.Info
import qualified Propellor.Property.Chroot as Chroot
import qualified Propellor.Property.Apt as Apt
@@ -61,23 +63,23 @@ type MachineName = String
data Container = Container MachineName Chroot.Chroot Host
deriving (Show)
-instance PropAccum Container where
- (Container n c h) `addProp` p = Container n c (h `addProp` p)
- (Container n c h) `addPropFront` p = Container n c (h `addPropFront` p)
- getProperties (Container _ _ h) = hostProperties h
+instance IsContainer Container where
+ containerProperties (Container _ _ h) = containerProperties h
+ containerInfo (Container _ _ h) = containerInfo h
+ setContainerProperties (Container n c h) ps = Container n c (setContainerProperties h ps)
-- | Starts a systemd service.
--
-- Note that this does not configure systemd to start the service on boot,
-- it only ensures that the service is currently running.
-started :: ServiceName -> Property NoInfo
-started n = cmdProperty "systemctl" ["start", n]
+started :: ServiceName -> Property Linux
+started n = tightenTargets $ cmdProperty "systemctl" ["start", n]
`assume` NoChange
`describe` ("service " ++ n ++ " started")
-- | Stops a systemd service.
-stopped :: ServiceName -> Property NoInfo
-stopped n = cmdProperty "systemctl" ["stop", n]
+stopped :: ServiceName -> Property Linux
+stopped n = tightenTargets $ cmdProperty "systemctl" ["stop", n]
`assume` NoChange
`describe` ("service " ++ n ++ " stopped")
@@ -85,35 +87,35 @@ stopped n = cmdProperty "systemctl" ["stop", n]
--
-- This does not ensure the service is started, it only configures systemd
-- to start it on boot.
-enabled :: ServiceName -> Property NoInfo
-enabled n = cmdProperty "systemctl" ["enable", n]
+enabled :: ServiceName -> Property Linux
+enabled n = tightenTargets $ cmdProperty "systemctl" ["enable", n]
`assume` NoChange
`describe` ("service " ++ n ++ " enabled")
-- | Disables a systemd service.
-disabled :: ServiceName -> Property NoInfo
-disabled n = cmdProperty "systemctl" ["disable", n]
+disabled :: ServiceName -> Property Linux
+disabled n = tightenTargets $ cmdProperty "systemctl" ["disable", n]
`assume` NoChange
`describe` ("service " ++ n ++ " disabled")
-- | Masks a systemd service.
-masked :: ServiceName -> RevertableProperty NoInfo
+masked :: ServiceName -> RevertableProperty Linux Linux
masked n = systemdMask <!> systemdUnmask
where
- systemdMask = cmdProperty "systemctl" ["mask", n]
+ systemdMask = tightenTargets $ cmdProperty "systemctl" ["mask", n]
`assume` NoChange
`describe` ("service " ++ n ++ " masked")
- systemdUnmask = cmdProperty "systemctl" ["unmask", n]
+ systemdUnmask = tightenTargets $ cmdProperty "systemctl" ["unmask", n]
`assume` NoChange
`describe` ("service " ++ n ++ " unmasked")
-- | Ensures that a service is both enabled and started
-running :: ServiceName -> Property NoInfo
+running :: ServiceName -> Property Linux
running n = started n `requires` enabled n
-- | Restarts a systemd service.
-restarted :: ServiceName -> Property NoInfo
-restarted n = cmdProperty "systemctl" ["restart", n]
+restarted :: ServiceName -> Property Linux
+restarted n = tightenTargets $ cmdProperty "systemctl" ["restart", n]
`assume` NoChange
`describe` ("service " ++ n ++ " restarted")
@@ -126,16 +128,15 @@ journald :: ServiceName
journald = "systemd-journald"
-- | Enables persistent storage of the journal.
-persistentJournal :: Property NoInfo
+persistentJournal :: Property DebianLike
persistentJournal = check (not <$> doesDirectoryExist dir) $
- combineProperties "persistent systemd journal"
- [ cmdProperty "install" ["-d", "-g", "systemd-journal", dir]
+ combineProperties "persistent systemd journal" $ props
+ & cmdProperty "install" ["-d", "-g", "systemd-journal", dir]
`assume` MadeChange
- , cmdProperty "setfacl" ["-R", "-nm", "g:adm:rx,d:g:adm:rx", dir]
+ & Apt.installed ["acl"]
+ & cmdProperty "setfacl" ["-R", "-nm", "g:adm:rx,d:g:adm:rx", dir]
`assume` MadeChange
- , started "systemd-journal-flush"
- ]
- `requires` Apt.installed ["acl"]
+ & started "systemd-journal-flush"
where
dir = "/var/log/journal"
@@ -148,11 +149,10 @@ type Option = String
-- currently the case for files like journald.conf and system.conf.
-- And it assumes the file already exists with
-- the right [Header], so new lines can just be appended to the end.
-configured :: FilePath -> Option -> String -> Property NoInfo
-configured cfgfile option value = combineProperties desc
- [ File.fileProperty desc (mapMaybe removeother) cfgfile
- , File.containsLine cfgfile line
- ]
+configured :: FilePath -> Option -> String -> Property Linux
+configured cfgfile option value = tightenTargets $ combineProperties desc $ props
+ & File.fileProperty desc (mapMaybe removeother) cfgfile
+ & File.containsLine cfgfile line
where
setting = option ++ "="
line = setting ++ value
@@ -162,43 +162,59 @@ configured cfgfile option value = combineProperties desc
| otherwise = Just l
-- | Causes systemd to reload its configuration files.
-daemonReloaded :: Property NoInfo
-daemonReloaded = cmdProperty "systemctl" ["daemon-reload"]
+daemonReloaded :: Property Linux
+daemonReloaded = tightenTargets $ cmdProperty "systemctl" ["daemon-reload"]
`assume` NoChange
-- | Configures journald, restarting it so the changes take effect.
-journaldConfigured :: Option -> String -> Property NoInfo
+journaldConfigured :: Option -> String -> Property Linux
journaldConfigured option value =
configured "/etc/systemd/journald.conf" option value
`onChange` restarted journald
-- | Ensures machined and machinectl are installed
-machined :: Property NoInfo
-machined = withOS "machined installed" $ \o ->
+machined :: Property Linux
+machined = withOS "machined installed" $ \w o ->
case o of
-- Split into separate debian package since systemd 225.
(Just (System (Debian suite) _))
- | not (isStable suite) -> ensureProperty $
+ | not (isStable suite) -> ensureProperty w $
Apt.installed ["systemd-container"]
_ -> noChange
--- | Defines a container with a given machine name, and operating system,
+-- | Defines a container with a given machine name,
-- and how to create its chroot if not already present.
--
--- Properties can be added to configure the Container.
+-- Properties can be added to configure the Container. At a minimum,
+-- add a property such as `osDebian` to specify the operating system
+-- to bootstrap.
--
--- > container "webserver" (System (Debian Unstable) "amd64") (Chroot.debootstrapped mempty)
+-- > container "webserver" $ \d -> Chroot.debootstrapped mempty d $ props
+-- > & osDebian Unstable "amd64"
-- > & Apt.installedRunning "apache2"
-- > & ...
-container :: MachineName -> System -> (FilePath -> Chroot.Chroot) -> Container
-container name system mkchroot = Container name c h
- & os system
- & resolvConfed
- & linkJournal
+container :: MachineName -> (FilePath -> Chroot.Chroot) -> Container
+container name mkchroot =
+ let c = Container name chroot (host name (containerProps chroot))
+ in setContainerProps c $ containerProps c
+ &^ resolvConfed
+ &^ linkJournal
where
- c = mkchroot (containerDir name)
- & os system
- h = Host name [] mempty
+ chroot = mkchroot (containerDir name)
+
+-- | Defines a container with a given machine name, with the chroot
+-- created using debootstrap.
+--
+-- Properties can be added to configure the Container. At a minimum,
+-- add a property such as `osDebian` to specify the operating system
+-- to bootstrap.
+--
+-- > debContainer "webserver" $ props
+-- > & osDebian Unstable "amd64"
+-- > & Apt.installedRunning "apache2"
+-- > & ...
+debContainer :: MachineName -> Props metatypes -> Container
+debContainer name ps = container name $ \d -> Chroot.debootstrapped mempty d ps
-- | Runs a container using systemd-nspawn.
--
@@ -214,13 +230,14 @@ container name system mkchroot = Container name c h
--
-- Reverting this property stops the container, removes the systemd unit,
-- and deletes the chroot and all its contents.
-nspawned :: Container -> RevertableProperty HasInfo
+nspawned :: Container -> RevertableProperty (HasInfo + Linux) Linux
nspawned c@(Container name (Chroot.Chroot loc builder _) h) =
p `describe` ("nspawned " ++ name)
where
+ p :: RevertableProperty (HasInfo + Linux) Linux
p = enterScript c
`before` chrootprovisioned
- `before` nspawnService c (_chrootCfg $ getInfo $ hostInfo h)
+ `before` nspawnService c (_chrootCfg $ fromInfo $ hostInfo h)
`before` containerprovisioned
-- Chroot provisioning is run in systemd-only mode,
@@ -230,8 +247,9 @@ nspawned c@(Container name (Chroot.Chroot loc builder _) h) =
-- Use nsenter to enter container and and run propellor to
-- finish provisioning.
+ containerprovisioned :: RevertableProperty Linux Linux
containerprovisioned =
- Chroot.propellChroot chroot (enterContainerProcess c) False
+ tightenTargets (Chroot.propellChroot chroot (enterContainerProcess c) False)
<!>
doNothing
@@ -239,7 +257,7 @@ nspawned c@(Container name (Chroot.Chroot loc builder _) h) =
-- | Sets up the service file for the container, and then starts
-- it running.
-nspawnService :: Container -> ChrootCfg -> RevertableProperty NoInfo
+nspawnService :: Container -> ChrootCfg -> RevertableProperty Linux Linux
nspawnService (Container name _ _) cfg = setup <!> teardown
where
service = nspawnServiceName name
@@ -264,10 +282,12 @@ nspawnService (Container name _ _) cfg = setup <!> teardown
<$> servicefilecontent
<*> catchDefaultIO "" (readFile servicefile)
+ writeservicefile :: Property Linux
writeservicefile = property servicefile $ makeChange $ do
c <- servicefilecontent
File.viaStableTmp (\t -> writeFile t c) servicefile
+ setupservicefile :: Property Linux
setupservicefile = check (not <$> goodservicefile) $
-- if it's running, it has the wrong configuration,
-- so stop it
@@ -275,8 +295,12 @@ nspawnService (Container name _ _) cfg = setup <!> teardown
`requires` daemonReloaded
`requires` writeservicefile
- setup = started service `requires` setupservicefile `requires` machined
+ setup :: Property Linux
+ setup = started service
+ `requires` setupservicefile
+ `requires` machined
+ teardown :: Property Linux
teardown = check (doesFileExist servicefile) $
disabled service `requires` stopped service
@@ -290,11 +314,12 @@ nspawnServiceParams (SystemdNspawnCfg ps) =
--
-- This uses nsenter to enter the container, by looking up the pid of the
-- container's init process and using its namespace.
-enterScript :: Container -> RevertableProperty NoInfo
-enterScript c@(Container name _ _) = setup <!> teardown
+enterScript :: Container -> RevertableProperty Linux Linux
+enterScript c@(Container name _ _) =
+ tightenTargets setup <!> tightenTargets teardown
where
- setup = combineProperties ("generated " ++ enterScriptFile c)
- [ scriptfile `File.hasContent`
+ setup = combineProperties ("generated " ++ enterScriptFile c) $ props
+ & scriptfile `File.hasContent`
[ "#!/usr/bin/perl"
, "# Generated by propellor"
, "my $pid=`machinectl show " ++ shellEscape name ++ " -p Leader | cut -d= -f2`;"
@@ -309,8 +334,7 @@ enterScript c@(Container name _ _) = setup <!> teardown
, "}"
, "exit(1);"
]
- , scriptfile `File.mode` combineModes (readModes ++ executeModes)
- ]
+ & scriptfile `File.mode` combineModes (readModes ++ executeModes)
teardown = File.notPresent scriptfile
scriptfile = enterScriptFile c
@@ -336,11 +360,14 @@ mungename = replace "/" "_"
-- When there is no leading dash, "--" is prepended to the parameter.
--
-- Reverting the property will remove a parameter, if it's present.
-containerCfg :: String -> RevertableProperty HasInfo
+containerCfg :: String -> RevertableProperty (HasInfo + Linux) (HasInfo + Linux)
containerCfg p = RevertableProperty (mk True) (mk False)
where
- mk b = pureInfoProperty ("container configuration " ++ (if b then "" else "without ") ++ p') $
- mempty { _chrootCfg = SystemdNspawnCfg [(p', b)] }
+ mk b = tightenTargets $
+ pureInfoProperty desc $
+ mempty { _chrootCfg = SystemdNspawnCfg [(p', b)] }
+ where
+ desc = "container configuration " ++ (if b then "" else "without ") ++ p'
p' = case p of
('-':_) -> p
_ -> "--" ++ p
@@ -348,18 +375,18 @@ containerCfg p = RevertableProperty (mk True) (mk False)
-- | Bind mounts </etc/resolv.conf> from the host into the container.
--
-- This property is enabled by default. Revert it to disable it.
-resolvConfed :: RevertableProperty HasInfo
+resolvConfed :: RevertableProperty (HasInfo + Linux) (HasInfo + Linux)
resolvConfed = containerCfg "bind=/etc/resolv.conf"
-- | Link the container's journal to the host's if possible.
-- (Only works if the host has persistent journal enabled.)
--
-- This property is enabled by default. Revert it to disable it.
-linkJournal :: RevertableProperty HasInfo
+linkJournal :: RevertableProperty (HasInfo + Linux) (HasInfo + Linux)
linkJournal = containerCfg "link-journal=try-guest"
-- | Disconnect networking of the container from the host.
-privateNetwork :: RevertableProperty HasInfo
+privateNetwork :: RevertableProperty (HasInfo + Linux) (HasInfo + Linux)
privateNetwork = containerCfg "private-network"
class Publishable a where
@@ -397,7 +424,7 @@ instance Publishable (Proto, Bound Port) where
-- > & Systemd.running Systemd.networkd
-- > & Systemd.publish (Port 80 ->- Port 8080)
-- > & Apt.installedRunning "apache2"
-publish :: Publishable p => p -> RevertableProperty HasInfo
+publish :: Publishable p => p -> RevertableProperty (HasInfo + Linux) (HasInfo + Linux)
publish p = containerCfg $ "--port=" ++ toPublish p
class Bindable a where
@@ -410,9 +437,9 @@ instance Bindable (Bound FilePath) where
toBind v = hostSide v ++ ":" ++ containerSide v
-- | Bind mount a file or directory from the host into the container.
-bind :: Bindable p => p -> RevertableProperty HasInfo
+bind :: Bindable p => p -> RevertableProperty (HasInfo + Linux) (HasInfo + Linux)
bind p = containerCfg $ "--bind=" ++ toBind p
-- | Read-only mind mount.
-bindRo :: Bindable p => p -> RevertableProperty HasInfo
+bindRo :: Bindable p => p -> RevertableProperty (HasInfo + Linux) (HasInfo + Linux)
bindRo p = containerCfg $ "--bind-ro=" ++ toBind p
diff --git a/src/Propellor/Property/Systemd/Core.hs b/src/Propellor/Property/Systemd/Core.hs
index 7842f177..0290bce5 100644
--- a/src/Propellor/Property/Systemd/Core.hs
+++ b/src/Propellor/Property/Systemd/Core.hs
@@ -6,5 +6,5 @@ import qualified Propellor.Property.Apt as Apt
-- dbus is only a Recommends of systemd, but is needed for communication
-- from the systemd inside a container to the one outside, so make sure it
-- gets installed.
-installed :: Property NoInfo
+installed :: Property DebianLike
installed = Apt.installed ["systemd", "dbus"]
diff --git a/src/Propellor/Property/Tor.hs b/src/Propellor/Property/Tor.hs
index 0c040f95..92dbd507 100644
--- a/src/Propellor/Property/Tor.hs
+++ b/src/Propellor/Property/Tor.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE TypeFamilies #-}
+
module Propellor.Property.Tor where
import Propellor.Base
@@ -19,7 +21,7 @@ type NodeName = String
-- | Sets up a tor bridge. (Not a relay or exit node.)
--
-- Uses port 443
-isBridge :: Property NoInfo
+isBridge :: Property DebianLike
isBridge = configured
[ ("BridgeRelay", "1")
, ("Exitpolicy", "reject *:*")
@@ -31,7 +33,7 @@ isBridge = configured
-- | Sets up a tor relay.
--
-- Uses port 443
-isRelay :: Property NoInfo
+isRelay :: Property DebianLike
isRelay = configured
[ ("BridgeRelay", "0")
, ("Exitpolicy", "reject *:*")
@@ -44,21 +46,21 @@ isRelay = configured
--
-- This can be moved to a different IP without needing to wait to
-- accumulate trust.
-named :: NodeName -> Property HasInfo
+named :: NodeName -> Property (HasInfo + DebianLike)
named n = configured [("Nickname", n')]
`describe` ("tor node named " ++ n')
`requires` torPrivKey (Context ("tor " ++ n))
where
n' = saneNickname n
-torPrivKey :: Context -> Property HasInfo
+torPrivKey :: Context -> Property (HasInfo + DebianLike)
torPrivKey context = f `File.hasPrivContent` context
`onChange` File.ownerGroup f user (userGroup user)
`requires` torPrivKeyDirExists
where
f = torPrivKeyDir </> "secret_id_key"
-torPrivKeyDirExists :: Property NoInfo
+torPrivKeyDirExists :: Property DebianLike
torPrivKeyDirExists = File.dirExists torPrivKeyDir
`onChange` setperms
`requires` installed
@@ -71,20 +73,20 @@ torPrivKeyDir = "/var/lib/tor/keys"
-- | A tor server (bridge, relay, or exit)
-- Don't use if you just want to run tor for personal use.
-server :: Property NoInfo
+server :: Property DebianLike
server = configured [("SocksPort", "0")]
`requires` installed
`requires` Apt.installed ["ntp"]
`describe` "tor server"
-installed :: Property NoInfo
+installed :: Property DebianLike
installed = Apt.installed ["tor"]
-- | Specifies configuration settings. Any lines in the config file
-- that set other values for the specified settings will be removed,
-- while other settings are left as-is. Tor is restarted when
-- configuration is changed.
-configured :: [(String, String)] -> Property NoInfo
+configured :: [(String, String)] -> Property DebianLike
configured settings = File.fileProperty "tor configured" go mainConfig
`onChange` restarted
where
@@ -105,19 +107,19 @@ data BwLimit
--
-- For example, PerSecond "30 kibibytes" is the minimum limit
-- for a useful relay.
-bandwidthRate :: BwLimit -> Property NoInfo
+bandwidthRate :: BwLimit -> Property DebianLike
bandwidthRate (PerSecond s) = bandwidthRate' s 1
bandwidthRate (PerDay s) = bandwidthRate' s (24*60*60)
bandwidthRate (PerMonth s) = bandwidthRate' s (31*24*60*60)
-bandwidthRate' :: String -> Integer -> Property NoInfo
+bandwidthRate' :: String -> Integer -> Property DebianLike
bandwidthRate' s divby = case readSize dataUnits s of
Just sz -> let v = show (sz `div` divby) ++ " bytes"
in configured [("BandwidthRate", v)]
`describe` ("tor BandwidthRate " ++ v)
Nothing -> property ("unable to parse " ++ s) noChange
-hiddenServiceAvailable :: HiddenServiceName -> Int -> Property NoInfo
+hiddenServiceAvailable :: HiddenServiceName -> Int -> Property DebianLike
hiddenServiceAvailable hn port = hiddenServiceHostName $ hiddenService hn port
where
hiddenServiceHostName p = adjustPropertySatisfy p $ \satisfy -> do
@@ -126,7 +128,7 @@ hiddenServiceAvailable hn port = hiddenServiceHostName $ hiddenService hn port
warningMessage $ unwords ["hidden service hostname:", h]
return r
-hiddenService :: HiddenServiceName -> Int -> Property NoInfo
+hiddenService :: HiddenServiceName -> Int -> Property DebianLike
hiddenService hn port = ConfFile.adjustSection
(unwords ["hidden service", hn, "available on port", show port])
(== oniondir)
@@ -139,18 +141,18 @@ hiddenService hn port = ConfFile.adjustSection
oniondir = unwords ["HiddenServiceDir", varLib </> hn]
onionport = unwords ["HiddenServicePort", show port, "127.0.0.1:" ++ show port]
-hiddenServiceData :: IsContext c => HiddenServiceName -> c -> Property HasInfo
-hiddenServiceData hn context = combineProperties desc
- [ installonion "hostname"
- , installonion "private_key"
- ]
+hiddenServiceData :: IsContext c => HiddenServiceName -> c -> Property (HasInfo + DebianLike)
+hiddenServiceData hn context = combineProperties desc $ props
+ & installonion "hostname"
+ & installonion "private_key"
where
desc = unwords ["hidden service data available in", varLib </> hn]
+ installonion :: FilePath -> Property (HasInfo + DebianLike)
installonion f = withPrivData (PrivFile $ varLib </> hn </> f) context $ \getcontent ->
- property desc $ getcontent $ install $ varLib </> hn </> f
- install f privcontent = ifM (liftIO $ doesFileExist f)
+ property' desc $ \w -> getcontent $ install w $ varLib </> hn </> f
+ install w f privcontent = ifM (liftIO $ doesFileExist f)
( noChange
- , ensureProperties
+ , ensureProperty w $ propertyList desc $ toProps
[ property desc $ makeChange $ do
createDirectoryIfMissing True (takeDirectory f)
writeFileProtected f (unlines (privDataLines privcontent))
@@ -161,7 +163,7 @@ hiddenServiceData hn context = combineProperties desc
]
)
-restarted :: Property NoInfo
+restarted :: Property DebianLike
restarted = Service.restarted "tor"
mainConfig :: FilePath
diff --git a/src/Propellor/Property/Unbound.hs b/src/Propellor/Property/Unbound.hs
index f1280b0e..23a5b30d 100644
--- a/src/Propellor/Property/Unbound.hs
+++ b/src/Propellor/Property/Unbound.hs
@@ -41,13 +41,13 @@ type UnboundValue = String
type ZoneType = String
-installed :: Property NoInfo
+installed :: Property DebianLike
installed = Apt.installed ["unbound"]
-restarted :: Property NoInfo
+restarted :: Property DebianLike
restarted = Service.restarted "unbound"
-reloaded :: Property NoInfo
+reloaded :: Property DebianLike
reloaded = Service.reloaded "unbound"
dValue :: BindDomain -> String
@@ -90,7 +90,7 @@ config = "/etc/unbound/unbound.conf.d/propellor.conf"
-- > , (AbsDomain "myrouter.example.com", PTR $ reverseIP $ IPv4 "192.168.1.1")
-- > , (AbsDomain "mylaptop.example.com", PTR $ reverseIP $ IPv4 "192.168.1.2")
-- > ]
-cachingDnsServer :: [UnboundSection] -> [UnboundZone] -> [UnboundHost] -> Property NoInfo
+cachingDnsServer :: [UnboundSection] -> [UnboundZone] -> [UnboundHost] -> Property DebianLike
cachingDnsServer sections zones hosts =
config `hasContent` (comment : otherSections ++ serverSection)
`onChange` restarted
diff --git a/src/Propellor/Property/User.hs b/src/Propellor/Property/User.hs
index c9c91a77..76eae647 100644
--- a/src/Propellor/Property/User.hs
+++ b/src/Propellor/Property/User.hs
@@ -7,8 +7,8 @@ import qualified Propellor.Property.File as File
data Eep = YesReallyDeleteHome
-accountFor :: User -> Property NoInfo
-accountFor user@(User u) = check nohomedir go
+accountFor :: User -> Property DebianLike
+accountFor user@(User u) = tightenTargets $ check nohomedir go
`describe` ("account for " ++ u)
where
nohomedir = isNothing <$> catchMaybeIO (homedir user)
@@ -18,11 +18,11 @@ accountFor user@(User u) = check nohomedir go
, u
]
-systemAccountFor :: User -> Property NoInfo
+systemAccountFor :: User -> Property DebianLike
systemAccountFor user@(User u) = systemAccountFor' user Nothing (Just (Group u))
-systemAccountFor' :: User -> Maybe FilePath -> Maybe Group -> Property NoInfo
-systemAccountFor' (User u) mhome mgroup = check nouser go
+systemAccountFor' :: User -> Maybe FilePath -> Maybe Group -> Property DebianLike
+systemAccountFor' (User u) mhome mgroup = tightenTargets $ check nouser go
`describe` ("system account for " ++ u)
where
nouser = isNothing <$> catchMaybeIO (getUserEntryForName u)
@@ -43,8 +43,8 @@ systemAccountFor' (User u) mhome mgroup = check nouser go
]
-- | Removes user home directory!! Use with caution.
-nuked :: User -> Eep -> Property NoInfo
-nuked user@(User u) _ = check hashomedir go
+nuked :: User -> Eep -> Property DebianLike
+nuked user@(User u) _ = tightenTargets $ check hashomedir go
`describe` ("nuked user " ++ u)
where
hashomedir = isJust <$> catchMaybeIO (homedir user)
@@ -55,13 +55,13 @@ nuked user@(User u) _ = check hashomedir go
-- | Only ensures that the user has some password set. It may or may
-- not be a password from the PrivData.
-hasSomePassword :: User -> Property HasInfo
+hasSomePassword :: User -> Property (HasInfo + DebianLike)
hasSomePassword user = hasSomePassword' user hostContext
-- | While hasSomePassword uses the name of the host as context,
-- this allows specifying a different context. This is useful when
-- you want to use the same password on multiple hosts, for example.
-hasSomePassword' :: IsContext c => User -> c -> Property HasInfo
+hasSomePassword' :: IsContext c => User -> c -> Property (HasInfo + DebianLike)
hasSomePassword' user context = check ((/= HasPassword) <$> getPasswordStatus user) $
hasPassword' user context
@@ -71,12 +71,14 @@ hasSomePassword' user context = check ((/= HasPassword) <$> getPasswordStatus us
-- A user's password can be stored in the PrivData in either of two forms;
-- the full cleartext <Password> or a <CryptPassword> hash. The latter
-- is obviously more secure.
-hasPassword :: User -> Property HasInfo
+hasPassword :: User -> Property (HasInfo + DebianLike)
hasPassword user = hasPassword' user hostContext
-hasPassword' :: IsContext c => User -> c -> Property HasInfo
-hasPassword' (User u) context = go `requires` shadowConfig True
+hasPassword' :: IsContext c => User -> c -> Property (HasInfo + DebianLike)
+hasPassword' (User u) context = go
+ `requires` shadowConfig True
where
+ go :: Property (HasInfo + UnixLike)
go = withSomePrivData srcs context $
property (u ++ " has password") . setPassword
srcs =
@@ -94,7 +96,7 @@ setPassword getpassword = getpassword $ go
-- | Makes a user's password be the passed String. Highly insecure:
-- The password is right there in your config file for anyone to see!
-hasInsecurePassword :: User -> String -> Property NoInfo
+hasInsecurePassword :: User -> String -> Property DebianLike
hasInsecurePassword u@(User n) p = property (n ++ " has insecure password") $
chpasswd u p []
@@ -104,9 +106,10 @@ chpasswd (User user) v ps = makeChange $ withHandle StdinHandle createProcessSuc
hPutStrLn h $ user ++ ":" ++ v
hClose h
-lockedPassword :: User -> Property NoInfo
-lockedPassword user@(User u) = check (not <$> isLockedPassword user) go
- `describe` ("locked " ++ u ++ " password")
+lockedPassword :: User -> Property DebianLike
+lockedPassword user@(User u) = tightenTargets $
+ check (not <$> isLockedPassword user) go
+ `describe` ("locked " ++ u ++ " password")
where
go = cmdProperty "passwd"
[ "--lock"
@@ -130,8 +133,8 @@ isLockedPassword user = (== LockedPassword) <$> getPasswordStatus user
homedir :: User -> IO FilePath
homedir (User user) = homeDirectory <$> getUserEntryForName user
-hasGroup :: User -> Group -> Property NoInfo
-hasGroup (User user) (Group group') = check test go
+hasGroup :: User -> Group -> Property DebianLike
+hasGroup (User user) (Group group') = tightenTargets $ check test go
`describe` unwords ["user", user, "in group", group']
where
test = not . elem group' . words <$> readProcess "groups" [user]
@@ -145,12 +148,13 @@ hasGroup (User user) (Group group') = check test go
--
-- Note that some groups may only exit after installation of other
-- software. When a group does not exist yet, the user won't be added to it.
-hasDesktopGroups :: User -> Property NoInfo
-hasDesktopGroups user@(User u) = property desc $ do
+hasDesktopGroups :: User -> Property DebianLike
+hasDesktopGroups user@(User u) = property' desc $ \o -> do
existinggroups <- map (fst . break (== ':')) . lines
<$> liftIO (readFile "/etc/group")
let toadd = filter (`elem` existinggroups) desktopgroups
- ensureProperty $ propertyList desc $ map (hasGroup user . Group) toadd
+ ensureProperty o $ propertyList desc $ toProps $
+ map (hasGroup user . Group) toadd
where
desc = "user " ++ u ++ " is in standard desktop groups"
-- This list comes from user-setup's debconf
@@ -170,11 +174,11 @@ hasDesktopGroups user@(User u) = property desc $ do
]
-- | Controls whether shadow passwords are enabled or not.
-shadowConfig :: Bool -> Property NoInfo
-shadowConfig True = check (not <$> shadowExists)
+shadowConfig :: Bool -> Property DebianLike
+shadowConfig True = tightenTargets $ check (not <$> shadowExists)
(cmdProperty "shadowconfig" ["on"])
`describe` "shadow passwords enabled"
-shadowConfig False = check shadowExists
+shadowConfig False = tightenTargets $ check shadowExists
(cmdProperty "shadowconfig" ["off"])
`describe` "shadow passwords disabled"
@@ -183,11 +187,11 @@ shadowExists = doesFileExist "/etc/shadow"
-- | Ensures that a user has a specified login shell, and that the shell
-- is enabled in /etc/shells.
-hasLoginShell :: User -> FilePath -> Property NoInfo
+hasLoginShell :: User -> FilePath -> Property DebianLike
hasLoginShell user loginshell = shellSetTo user loginshell `requires` shellEnabled loginshell
-shellSetTo :: User -> FilePath -> Property NoInfo
-shellSetTo (User u) loginshell = check needchangeshell
+shellSetTo :: User -> FilePath -> Property DebianLike
+shellSetTo (User u) loginshell = tightenTargets $ check needchangeshell
(cmdProperty "chsh" ["--shell", loginshell, u])
`describe` (u ++ " has login shell " ++ loginshell)
where
@@ -196,5 +200,6 @@ shellSetTo (User u) loginshell = check needchangeshell
return (currshell /= loginshell)
-- | Ensures that /etc/shells contains a shell.
-shellEnabled :: FilePath -> Property NoInfo
-shellEnabled loginshell = "/etc/shells" `File.containsLine` loginshell
+shellEnabled :: FilePath -> Property DebianLike
+shellEnabled loginshell = tightenTargets $
+ "/etc/shells" `File.containsLine` loginshell
diff --git a/src/Propellor/Property/Uwsgi.hs b/src/Propellor/Property/Uwsgi.hs
index f76d6a0f..4eb94103 100644
--- a/src/Propellor/Property/Uwsgi.hs
+++ b/src/Propellor/Property/Uwsgi.hs
@@ -11,7 +11,7 @@ type ConfigFile = [String]
type AppName = String
-appEnabled :: AppName -> ConfigFile -> RevertableProperty NoInfo
+appEnabled :: AppName -> ConfigFile -> RevertableProperty DebianLike DebianLike
appEnabled an cf = enable <!> disable
where
enable = appVal an `File.isSymlinkedTo` appValRelativeCfg an
@@ -24,9 +24,9 @@ appEnabled an cf = enable <!> disable
`requires` installed
`onChange` reloaded
-appAvailable :: AppName -> ConfigFile -> Property NoInfo
+appAvailable :: AppName -> ConfigFile -> Property DebianLike
appAvailable an cf = ("uwsgi app available " ++ an) ==>
- appCfg an `File.hasContent` (comment : cf)
+ tightenTargets (appCfg an `File.hasContent` (comment : cf))
where
comment = "# deployed with propellor, do not modify"
@@ -39,11 +39,11 @@ appVal an = "/etc/uwsgi/apps-enabled/" </> an <.> "ini"
appValRelativeCfg :: AppName -> File.LinkTarget
appValRelativeCfg an = File.LinkTarget $ "../apps-available" </> an <.> "ini"
-installed :: Property NoInfo
+installed :: Property DebianLike
installed = Apt.installed ["uwsgi"]
-restarted :: Property NoInfo
+restarted :: Property DebianLike
restarted = Service.restarted "uwsgi"
-reloaded :: Property NoInfo
+reloaded :: Property DebianLike
reloaded = Service.reloaded "uwsgi"
diff --git a/src/Propellor/Property/ZFS/Properties.hs b/src/Propellor/Property/ZFS/Properties.hs
index 5ceaf9ba..47d5a9d1 100644
--- a/src/Propellor/Property/ZFS/Properties.hs
+++ b/src/Propellor/Property/ZFS/Properties.hs
@@ -3,6 +3,7 @@
-- Functions defining zfs Properties.
module Propellor.Property.ZFS.Properties (
+ ZFSOS,
zfsExists,
zfsSetProperties
) where
@@ -11,9 +12,12 @@ import Propellor.Base
import Data.List (intercalate)
import qualified Propellor.Property.ZFS.Process as ZP
+-- | OS's that support ZFS
+type ZFSOS = Linux + FreeBSD
+
-- | Will ensure that a ZFS volume exists with the specified mount point.
-- This requires the pool to exist as well, but we don't create pools yet.
-zfsExists :: ZFS -> Property NoInfo
+zfsExists :: ZFS -> Property ZFSOS
zfsExists z = check (not <$> ZP.zfsExists z) create
`describe` unwords ["Creating", zfsName z]
where
@@ -21,16 +25,16 @@ zfsExists z = check (not <$> ZP.zfsExists z) create
create = cmdProperty p a
-- | Sets the given properties. Returns True if all were successfully changed, False if not.
-zfsSetProperties :: ZFS -> ZFSProperties -> Property NoInfo
+zfsSetProperties :: ZFS -> ZFSProperties -> Property ZFSOS
zfsSetProperties z setProperties = setall
`requires` zfsExists z
where
spcmd :: String -> String -> (String, [String])
spcmd p v = ZP.zfsCommand "set" [Just (intercalate "=" [p, v]), Nothing] z
- setprop :: (String, String) -> Property NoInfo
+ setprop :: (String, String) -> Property ZFSOS
setprop (p, v) = check (ZP.zfsExists z) $
cmdProperty (fst (spcmd p v)) (snd (spcmd p v))
setall = combineProperties (unwords ["Setting properties on", zfsName z]) $
- map setprop $ toPropertyList setProperties
+ toProps $ map setprop $ toPropertyList setProperties