summaryrefslogtreecommitdiff
path: root/src/Propellor/Property/Systemd.hs
diff options
context:
space:
mode:
authorJoey Hess2016-03-28 05:53:38 -0400
committerJoey Hess2016-03-28 05:55:48 -0400
commita1655d24bbb1db9caccdf93eae8110d746389ae2 (patch)
tree66b6890d852c19daec2306920fecf9108e055273 /src/Propellor/Property/Systemd.hs
parentebf30061d8f8a251330070e69c2710fe4a8fd9da (diff)
type safe targets for properties
* Property types have been improved to indicate what systems they target. This prevents using eg, Property FreeBSD on a Debian system. Transition guide for this sweeping API change: - Change "host name & foo & bar" to "host name $ props & foo & bar" - Similarly, `propertyList` and `combineProperties` need `props` to be used to combine together properties; they no longer accept lists of properties. (If you have such a list, use `toProps`.) - And similarly, Chroot, Docker, and Systemd container need `props` to be used to combine together the properies used inside them. - The `os` property is removed. Instead use `osDebian`, `osBuntish`, or `osFreeBSD`. These tell the type checker the target OS of a host. - Change "Property NoInfo" to "Property UnixLike" - Change "Property HasInfo" to "Property (HasInfo + UnixLike)" - Change "RevertableProperty NoInfo" to "RevertableProperty UnixLike UnixLike" - Change "RevertableProperty HasInfo" to "RevertableProperty (HasInfo + UnixLike) UnixLike" - GHC needs {-# LANGUAGE TypeOperators #-} to use these fancy types. This is enabled by default for all modules in propellor.cabal. But if you are using propellor as a library, you may need to enable it manually. - If you know a property only works on a particular OS, like Debian or FreeBSD, use that instead of "UnixLike". For example: "Property Debian" - It's also possible make a property support a set of OS's, for example: "Property (Debian + FreeBSD)" - Removed `infoProperty` and `simpleProperty` constructors, instead use `property` to construct a Property. - Due to the polymorphic type returned by `property`, additional type signatures tend to be needed when using it. For example, this will fail to type check, because the type checker cannot guess what type you intend the intermediate property "go" to have: foo :: Property UnixLike foo = go `requires` bar where go = property "foo" (return NoChange) To fix, specify the type of go: go :: Property UnixLike - `ensureProperty` now needs to be passed a witness to the type of the property it's used in. change this: foo = property desc $ ... ensureProperty bar to this: foo = property' desc $ \w -> ... ensureProperty w bar - General purpose properties like cmdProperty have type "Property UnixLike". When using that to run a command only available on Debian, you can tighten the type to only the OS that your more specific property works on. For example: upgraded :: Property Debian upgraded = tightenTargets (cmdProperty "apt-get" ["upgrade"]) - Several utility functions have been renamed: getInfo to fromInfo propertyInfo to getInfo propertyDesc to getDesc propertyChildren to getChildren * The new `pickOS` property combinator can be used to combine different properties, supporting different OS's, into one Property that chooses which to use based on the Host's OS. * Re-enabled -O0 in propellor.cabal to reign in ghc's memory use handling these complex new types. * Added dependency on concurrent-output; removed embedded copy.
Diffstat (limited to 'src/Propellor/Property/Systemd.hs')
-rw-r--r--src/Propellor/Property/Systemd.hs163
1 files changed, 95 insertions, 68 deletions
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