{-# LANGUAGE FlexibleInstances, TypeFamilies #-}

module Propellor.Property.Systemd (
	-- * Services
	ServiceName,
	started,
	stopped,
	enabled,
	disabled,
	masked,
	running,
	restarted,
	networkd,
	journald,
	logind,
	escapePath,
	-- * Configuration
	installed,
	Option,
	configured,
	daemonReloaded,
	-- * Journal
	persistentJournal,
	journaldConfigured,
	-- * Logind
	logindConfigured,
	killUserProcesses,
	-- * Containers and machined
	machined,
	MachineName,
	Container,
	container,
	debContainer,
	nspawned,
	-- * Container configuration
	containerCfg,
	resolvConfed,
	linkJournal,
	privateNetwork,
	module Propellor.Types.Container,
	Proto(..),
	Publishable,
	publish,
	Bindable,
	bind,
	bindRo,
) where

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
import qualified Propellor.Property.File as File
import Propellor.Property.Systemd.Core
import Utility.Split

import Data.List
import Data.Char
import qualified Data.Map as M
import Text.Printf

type ServiceName = String

type MachineName = String

data Container = Container MachineName Chroot.Chroot Host
	deriving (Int -> Container -> ShowS
[Container] -> ShowS
Container -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Container] -> ShowS
$cshowList :: [Container] -> ShowS
show :: Container -> String
$cshow :: Container -> String
showsPrec :: Int -> Container -> ShowS
$cshowsPrec :: Int -> Container -> ShowS
Show)

instance IsContainer Container where
	containerProperties :: Container -> [ChildProperty]
containerProperties (Container String
_ Chroot
_ Host
h) = forall c. IsContainer c => c -> [ChildProperty]
containerProperties Host
h
	containerInfo :: Container -> Info
containerInfo (Container String
_ Chroot
_ Host
h) = forall c. IsContainer c => c -> Info
containerInfo Host
h
	setContainerProperties :: Container -> [ChildProperty] -> Container
setContainerProperties (Container String
n Chroot
c Host
h) [ChildProperty]
ps = String -> Chroot -> Host -> Container
Container String
n Chroot
c (forall c. IsContainer c => c -> [ChildProperty] -> c
setContainerProperties Host
h [ChildProperty]
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 Linux
started :: String -> Property Linux
started String
n = forall (p :: * -> *) (untightened :: [MetaType])
       (tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
 SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets forall a b. (a -> b) -> a -> b
$ String -> [String] -> UncheckedProperty UnixLike
cmdProperty String
"systemctl" [String
"start", String
n]
	forall (p :: * -> *) i.
Checkable p i =>
p i -> Result -> Property i
`assume` Result
NoChange
	forall p. IsProp p => p -> String -> p
`describe` (String
"service " forall a. [a] -> [a] -> [a]
++ String
n forall a. [a] -> [a] -> [a]
++ String
" started")

-- | Stops a systemd service.
stopped :: ServiceName -> Property Linux
stopped :: String -> Property Linux
stopped String
n = forall (p :: * -> *) (untightened :: [MetaType])
       (tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
 SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets forall a b. (a -> b) -> a -> b
$ String -> [String] -> UncheckedProperty UnixLike
cmdProperty String
"systemctl" [String
"stop", String
n]
	forall (p :: * -> *) i.
Checkable p i =>
p i -> Result -> Property i
`assume` Result
NoChange
	forall p. IsProp p => p -> String -> p
`describe` (String
"service " forall a. [a] -> [a] -> [a]
++ String
n forall a. [a] -> [a] -> [a]
++ String
" stopped")

-- | Enables a systemd service.
--
-- This does not ensure the service is started, it only configures systemd
-- to start it on boot.
enabled :: ServiceName -> Property Linux
enabled :: String -> Property Linux
enabled String
n = forall (p :: * -> *) (untightened :: [MetaType])
       (tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
 SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets forall a b. (a -> b) -> a -> b
$ String -> [String] -> UncheckedProperty UnixLike
cmdProperty String
"systemctl" [String
"enable", String
n]
	forall (p :: * -> *) i.
Checkable p i =>
p i -> Result -> Property i
`assume` Result
NoChange
	forall p. IsProp p => p -> String -> p
`describe` (String
"service " forall a. [a] -> [a] -> [a]
++ String
n forall a. [a] -> [a] -> [a]
++ String
" enabled")

-- | Disables a systemd service.
disabled :: ServiceName -> Property Linux
disabled :: String -> Property Linux
disabled String
n = forall (p :: * -> *) (untightened :: [MetaType])
       (tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
 SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets forall a b. (a -> b) -> a -> b
$ String -> [String] -> UncheckedProperty UnixLike
cmdProperty String
"systemctl" [String
"disable", String
n]
	forall (p :: * -> *) i.
Checkable p i =>
p i -> Result -> Property i
`assume` Result
NoChange
	forall p. IsProp p => p -> String -> p
`describe` (String
"service " forall a. [a] -> [a] -> [a]
++ String
n forall a. [a] -> [a] -> [a]
++ String
" disabled")

-- | Masks a systemd service.
masked :: ServiceName -> RevertableProperty Linux Linux
masked :: String -> RevertableProperty Linux Linux
masked String
n = Property Linux
systemdMask forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
<!> Property Linux
systemdUnmask
  where
	systemdMask :: Property Linux
systemdMask = forall (p :: * -> *) (untightened :: [MetaType])
       (tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
 SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets forall a b. (a -> b) -> a -> b
$ String -> [String] -> UncheckedProperty UnixLike
cmdProperty String
"systemctl" [String
"mask", String
n]
		forall (p :: * -> *) i.
Checkable p i =>
p i -> Result -> Property i
`assume` Result
NoChange
		forall p. IsProp p => p -> String -> p
`describe` (String
"service " forall a. [a] -> [a] -> [a]
++ String
n forall a. [a] -> [a] -> [a]
++ String
" masked")
	systemdUnmask :: Property Linux
systemdUnmask = forall (p :: * -> *) (untightened :: [MetaType])
       (tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
 SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets forall a b. (a -> b) -> a -> b
$ String -> [String] -> UncheckedProperty UnixLike
cmdProperty String
"systemctl" [String
"unmask", String
n]
		forall (p :: * -> *) i.
Checkable p i =>
p i -> Result -> Property i
`assume` Result
NoChange
		forall p. IsProp p => p -> String -> p
`describe` (String
"service " forall a. [a] -> [a] -> [a]
++ String
n forall a. [a] -> [a] -> [a]
++ String
" unmasked")

-- | Ensures that a service is both enabled and started
running :: ServiceName -> Property Linux
running :: String -> Property Linux
running String
n = String -> Property Linux
started String
n forall x y. Combines x y => x -> y -> CombinedType x y
`requires` String -> Property Linux
enabled String
n

-- | Restarts a systemd service.
restarted :: ServiceName -> Property Linux
restarted :: String -> Property Linux
restarted String
n = forall (p :: * -> *) (untightened :: [MetaType])
       (tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
 SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets forall a b. (a -> b) -> a -> b
$ String -> [String] -> UncheckedProperty UnixLike
cmdProperty String
"systemctl" [String
"restart", String
n]
	forall (p :: * -> *) i.
Checkable p i =>
p i -> Result -> Property i
`assume` Result
NoChange
	forall p. IsProp p => p -> String -> p
`describe` (String
"service " forall a. [a] -> [a] -> [a]
++ String
n forall a. [a] -> [a] -> [a]
++ String
" restarted")

-- | The systemd-networkd service.
networkd :: ServiceName
networkd :: String
networkd = String
"systemd-networkd"

-- | The systemd-journald service.
journald :: ServiceName
journald :: String
journald = String
"systemd-journald"

-- | The systemd-logind service.
logind :: ServiceName
logind :: String
logind = String
"systemd-logind"

-- | Enables persistent storage of the journal.
persistentJournal :: Property DebianLike
persistentJournal :: Property DebianLike
persistentJournal = forall (p :: * -> *) i (m :: * -> *).
(Checkable p i, LiftPropellor m) =>
m Bool -> p i -> Property i
check (Bool -> Bool
not forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO Bool
doesDirectoryExist String
dir) forall a b. (a -> b) -> a -> b
$
	forall {k} (metatypes :: k).
SingI metatypes =>
String
-> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes)
combineProperties String
"persistent systemd journal" forall a b. (a -> b) -> a -> b
$ Props UnixLike
props
		forall {a} p (y :: [a]) (x :: [a]).
(IsProp p, MetaTypes y ~ GetMetaTypes p,
 CheckCombinableNote x y (NoteFor ('Text "&"))) =>
Props (MetaTypes x) -> p -> Props (MetaTypes (Combine x y))
& String -> [String] -> UncheckedProperty UnixLike
cmdProperty String
"install" [String
"-d", String
"-g", String
"systemd-journal", String
dir]
			forall (p :: * -> *) i.
Checkable p i =>
p i -> Result -> Property i
`assume` Result
MadeChange
		forall {a} p (y :: [a]) (x :: [a]).
(IsProp p, MetaTypes y ~ GetMetaTypes p,
 CheckCombinableNote x y (NoteFor ('Text "&"))) =>
Props (MetaTypes x) -> p -> Props (MetaTypes (Combine x y))
& [String] -> Property DebianLike
Apt.installed [String
"acl"]
		forall {a} p (y :: [a]) (x :: [a]).
(IsProp p, MetaTypes y ~ GetMetaTypes p,
 CheckCombinableNote x y (NoteFor ('Text "&"))) =>
Props (MetaTypes x) -> p -> Props (MetaTypes (Combine x y))
& String -> [String] -> UncheckedProperty UnixLike
cmdProperty String
"setfacl" [String
"-R", String
"-nm", String
"g:adm:rx,d:g:adm:rx", String
dir]
			forall (p :: * -> *) i.
Checkable p i =>
p i -> Result -> Property i
`assume` Result
MadeChange
		forall {a} p (y :: [a]) (x :: [a]).
(IsProp p, MetaTypes y ~ GetMetaTypes p,
 CheckCombinableNote x y (NoteFor ('Text "&"))) =>
Props (MetaTypes x) -> p -> Props (MetaTypes (Combine x y))
& String -> Property Linux
started String
"systemd-journal-flush"
  where
	dir :: String
dir = String
"/var/log/journal"

type Option = String

-- | Ensures that an option is configured in one of systemd's config files.
-- Does not ensure that the relevant daemon notices the change immediately.
--
-- This assumes that there is only one [Header] per file, which is
-- currently the case 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 Linux
configured :: String -> String -> String -> Property Linux
configured String
cfgfile String
option String
value = forall (p :: * -> *) (untightened :: [MetaType])
       (tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
 SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets forall a b. (a -> b) -> a -> b
$ forall {k} (metatypes :: k).
SingI metatypes =>
String
-> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes)
combineProperties String
desc forall a b. (a -> b) -> a -> b
$ Props UnixLike
props
	forall {a} p (y :: [a]) (x :: [a]).
(IsProp p, MetaTypes y ~ GetMetaTypes p,
 CheckCombinableNote x y (NoteFor ('Text "&"))) =>
Props (MetaTypes x) -> p -> Props (MetaTypes (Combine x y))
& forall c.
(FileContent c, Eq c) =>
String -> (c -> c) -> String -> Property UnixLike
File.fileProperty String
desc (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe String -> Maybe String
removeother) String
cfgfile
	forall {a} p (y :: [a]) (x :: [a]).
(IsProp p, MetaTypes y ~ GetMetaTypes p,
 CheckCombinableNote x y (NoteFor ('Text "&"))) =>
Props (MetaTypes x) -> p -> Props (MetaTypes (Combine x y))
& String -> String -> Property UnixLike
File.containsLine String
cfgfile String
line
  where
	setting :: String
setting = String
option forall a. [a] -> [a] -> [a]
++ String
"="
	line :: String
line = String
setting forall a. [a] -> [a] -> [a]
++ String
value
	desc :: String
desc = String
cfgfile forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String
line
	removeother :: String -> Maybe String
removeother String
l
		| String
setting forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
l Bool -> Bool -> Bool
&& String
l forall a. Eq a => a -> a -> Bool
/= String
line = forall a. Maybe a
Nothing
		| Bool
otherwise = forall a. a -> Maybe a
Just String
l

-- | Causes systemd to reload its configuration files.
daemonReloaded :: Property Linux
daemonReloaded :: Property Linux
daemonReloaded = forall (p :: * -> *) (untightened :: [MetaType])
       (tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
 SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets forall a b. (a -> b) -> a -> b
$ String -> [String] -> UncheckedProperty UnixLike
cmdProperty String
"systemctl" [String
"daemon-reload"]
	forall (p :: * -> *) i.
Checkable p i =>
p i -> Result -> Property i
`assume` Result
NoChange

-- | Configures journald, restarting it so the changes take effect.
journaldConfigured :: Option -> String -> Property Linux
journaldConfigured :: String -> String -> Property Linux
journaldConfigured String
option String
value =
	String -> String -> String -> Property Linux
configured String
"/etc/systemd/journald.conf" String
option String
value
		forall x y. Combines x y => x -> y -> CombinedType x y
`onChange` String -> Property Linux
restarted String
journald

-- | Configures logind, restarting it so the changes take effect.
logindConfigured :: Option -> String -> Property Linux
logindConfigured :: String -> String -> Property Linux
logindConfigured String
option String
value =
	String -> String -> String -> Property Linux
configured String
"/etc/systemd/logind.conf" String
option String
value
		forall x y. Combines x y => x -> y -> CombinedType x y
`onChange` String -> Property Linux
restarted String
logind

-- | Configures whether leftover processes started from the
-- user's login session are killed after the user logs out.
--
-- The default configuration varies depending on the version of systemd.
--
-- Revert the property to ensure that screen sessions etc keep running:
--
-- >	! killUserProcesses
killUserProcesses :: RevertableProperty Linux Linux
killUserProcesses :: RevertableProperty Linux Linux
killUserProcesses = String -> Property Linux
set String
"yes" forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
<!> String -> Property Linux
set String
"no"
  where
	set :: String -> Property Linux
set = String -> String -> Property Linux
logindConfigured String
"KillUserProcesses"

-- | Ensures machined and machinectl are installed
machined :: Property Linux
machined :: Property Linux
machined = Property DebianLike
installeddebian forall {k} ka kb (c :: k) (a :: ka) (b :: kb).
(HasCallStack, SingKind 'KProxy, SingKind 'KProxy,
 DemoteRep 'KProxy ~ [MetaType], DemoteRep 'KProxy ~ [MetaType],
 SingI c) =>
Property (MetaTypes a)
-> Property (MetaTypes b) -> Property (MetaTypes c)
`pickOS` Property Linux
assumeinstalled
  where
	installeddebian :: Property DebianLike
	installeddebian :: Property DebianLike
installeddebian = forall {k} (metatypes :: k).
SingI metatypes =>
String
-> (OuterMetaTypesWitness metatypes
    -> Maybe System -> Propellor Result)
-> Property (MetaTypes metatypes)
withOS String
"machined installed" forall a b. (a -> b) -> a -> b
$ \OuterMetaTypesWitness
  '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
w Maybe System
o ->
		case Maybe System
o of
			-- Split into separate debian package since systemd 225.
			(Just (System (Debian DebianKernel
_ DebianSuite
suite) Architecture
_))
				| Bool -> Bool
not (DebianSuite -> Bool
isStable DebianSuite
suite) Bool -> Bool -> Bool
|| DebianSuite
suite forall a. Eq a => a -> a -> Bool
/= (String -> DebianSuite
Stable String
"jessie") ->
					forall (inner :: [MetaType]) (outer :: [MetaType]).
EnsurePropertyAllowed inner outer =>
OuterMetaTypesWitness outer
-> Property (MetaTypes inner) -> Propellor Result
ensureProperty OuterMetaTypesWitness
  '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
w forall a b. (a -> b) -> a -> b
$ [String] -> Property DebianLike
Apt.installed [String
"systemd-container"]
			Maybe System
_ -> Propellor Result
noChange
	assumeinstalled :: Property Linux
	assumeinstalled :: Property Linux
assumeinstalled = forall {k} (t :: k). SingI t => Property (MetaTypes t)
doNothing

-- | 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. At a minimum,
-- add a property such as `osDebian` to specify the operating system
-- to bootstrap.
--
-- > container "webserver" $ \d -> Chroot.debootstrapped mempty d $ props
-- >    & osDebian Unstable X86_64
-- >    & Apt.installedRunning "apache2"
-- >    & ...
container :: MachineName -> (FilePath -> Chroot.Chroot) -> Container
container :: String -> (String -> Chroot) -> Container
container String
name String -> Chroot
mkchroot =
	let c :: Container
c = String -> Chroot -> Host -> Container
Container String
name Chroot
chroot Host
h
	in forall c metatypes. IsContainer c => c -> Props metatypes -> c
setContainerProps Container
c forall a b. (a -> b) -> a -> b
$ forall c. IsContainer c => c -> Props UnixLike
containerProps Container
c
		forall {a} p (y :: [a]) (x :: [a]).
(IsProp p, MetaTypes y ~ GetMetaTypes p,
 CheckCombinableNote x y (NoteFor ('Text "&^"))) =>
Props (MetaTypes x) -> p -> Props (MetaTypes (Combine x y))
&^ RevertableProperty (HasInfo + Linux) (HasInfo + Linux)
linkJournal
  where
	chroot :: Chroot
chroot = String -> Chroot
mkchroot (ShowS
containerDir String
name)
	h :: Host
h = String -> [ChildProperty] -> Info -> Host
Host String
name (forall c. IsContainer c => c -> [ChildProperty]
containerProperties Chroot
chroot) (forall c. IsContainer c => c -> Info
containerInfo Chroot
chroot)

-- | 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 X86_64
-- >    & Apt.installedRunning "apache2"
-- >    & ...
debContainer :: MachineName -> Props metatypes -> Container
debContainer :: forall metatypes. String -> Props metatypes -> Container
debContainer String
name Props metatypes
ps = String -> (String -> Chroot) -> Container
container String
name forall a b. (a -> b) -> a -> b
$ \String
d -> forall metatypes.
DebootstrapConfig -> String -> Props metatypes -> Chroot
Chroot.debootstrapped forall a. Monoid a => a
mempty String
d Props metatypes
ps

-- | Runs a container using systemd-nspawn.
--
-- A systemd unit is set up for the container, so it will automatically
-- be started on boot.
--
-- Systemd is automatically installed inside the container, and will
-- communicate with the host's systemd. This allows systemctl to be used to
-- examine the status of services running inside the container.
--
-- When the host system has persistentJournal enabled, journactl can be
-- used to examine logs forwarded from the container.
--
-- Reverting this property stops the container, removes the systemd unit,
-- and deletes the chroot and all its contents.
nspawned :: Container -> RevertableProperty (HasInfo + Linux) Linux
nspawned :: Container -> RevertableProperty (HasInfo + Linux) Linux
nspawned c :: Container
c@(Container String
name (Chroot.Chroot String
loc b
builder InfoPropagator
_ Host
_) Host
h) =
	RevertableProperty (HasInfo + Linux) Linux
p forall p. IsProp p => p -> String -> p
`describe` (String
"nspawned " forall a. [a] -> [a] -> [a]
++ String
name)
  where
	p :: RevertableProperty (HasInfo + Linux) Linux
	p :: RevertableProperty (HasInfo + Linux) Linux
p = Container -> RevertableProperty Linux Linux
enterScript Container
c
		forall x y. Combines x y => x -> y -> CombinedType x y
`before` RevertableProperty (HasInfo + Linux) Linux
chrootprovisioned
		forall x y. Combines x y => x -> y -> CombinedType x y
`before` Container -> ChrootCfg -> RevertableProperty Linux Linux
nspawnService Container
c (ChrootInfo -> ChrootCfg
_chrootCfg forall a b. (a -> b) -> a -> b
$ forall v. IsInfo v => Info -> v
fromInfo forall a b. (a -> b) -> a -> b
$ Host -> Info
hostInfo Host
h)
		forall x y. Combines x y => x -> y -> CombinedType x y
`before` RevertableProperty Linux Linux
containerprovisioned

	-- Chroot provisioning is run in systemd-only mode,
	-- which sets up the chroot and ensures systemd and dbus are
	-- installed, but does not handle the other properties.
	chrootprovisioned :: RevertableProperty (HasInfo + Linux) Linux
chrootprovisioned = Chroot
-> Bool
-> [ContainerCapability]
-> RevertableProperty (HasInfo + Linux) Linux
Chroot.provisioned' Chroot
chroot Bool
True [ContainerCapability
FilesystemContained]

	-- Use nsenter to enter container and and run propellor to
	-- finish provisioning.
	containerprovisioned :: RevertableProperty Linux Linux
	containerprovisioned :: RevertableProperty Linux Linux
containerprovisioned =
		forall (p :: * -> *) (untightened :: [MetaType])
       (tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
 SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets (Chroot
-> ([String] -> IO (CreateProcess, IO ()))
-> Bool
-> [ContainerCapability]
-> Property UnixLike
Chroot.propellChroot Chroot
chroot (Container -> [String] -> IO (CreateProcess, IO ())
enterContainerProcess Container
c) Bool
False [ContainerCapability]
containercaps)
			forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
<!>
		forall {k} (t :: k). SingI t => Property (MetaTypes t)
doNothing

	containercaps :: [ContainerCapability]
containercaps = 
		[ ContainerCapability
FilesystemContained
		, ContainerCapability
HostnameContained
		]

	chroot :: Chroot
chroot = forall b.
ChrootBootstrapper b =>
String -> b -> InfoPropagator -> Host -> Chroot
Chroot.Chroot String
loc b
builder InfoPropagator
Chroot.propagateChrootInfo Host
h

-- | Sets up the service files for the container, using the
-- systemd-nspawn@.service template, and starts it running.
nspawnService :: Container -> ChrootCfg -> RevertableProperty Linux Linux
nspawnService :: Container -> ChrootCfg -> RevertableProperty Linux Linux
nspawnService (Container String
name Chroot
_ Host
_) ChrootCfg
cfg = Property Linux
setup forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
<!> Property Linux
teardown
  where
	service :: String
service = ShowS
nspawnServiceName String
name
	overridedir :: String
overridedir = String
"/etc/systemd/system" String -> ShowS
</> ShowS
nspawnServiceName String
name forall a. [a] -> [a] -> [a]
++ String
".d"
	overridefile :: String
overridefile = String
overridedir String -> ShowS
</> String
"local.conf"
	overridecontent :: [String]
overridecontent = 
		[ String
"[Service]"
		, String
"# Reset ExecStart from the template"
		, String
"ExecStart="
		, String
"ExecStart=/usr/bin/systemd-nspawn " forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
nspawnparams
		]
	nspawnparams :: [String]
nspawnparams = 
		[ String
"--quiet"
		, String
"--keep-unit"
		, String
"--boot"
		, String
"--directory=" forall a. [a] -> [a] -> [a]
++ ShowS
containerDir String
name
		, String
"--machine=" forall a. [a] -> [a] -> [a]
++ String
name
		] forall a. [a] -> [a] -> [a]
++ ChrootCfg -> [String]
nspawnServiceParams ChrootCfg
cfg

	overrideconfigured :: CombinedType (Property Linux) (Property UnixLike)
overrideconfigured = String -> [String] -> Property UnixLike
File.hasContent String
overridefile [String]
overridecontent
		forall x y. Combines x y => x -> y -> CombinedType x y
`onChange` Property Linux
daemonReloaded
		forall x y. Combines x y => x -> y -> CombinedType x y
`requires` String -> Property UnixLike
File.dirExists String
overridedir

	setup :: Property Linux
	setup :: Property Linux
setup = String -> Property Linux
started String
service
		forall x y. Combines x y => x -> y -> CombinedType x y
`requires` String -> Property Linux
enabled String
service
		forall x y. Combines x y => x -> y -> CombinedType x y
`requires` CombinedType (Property Linux) (Property UnixLike)
overrideconfigured
		forall x y. Combines x y => x -> y -> CombinedType x y
`requires` Property Linux
machined

	teardown :: Property Linux
	teardown :: Property Linux
teardown = String -> Property Linux
stopped String
service
		forall x y. Combines x y => x -> y -> CombinedType x y
`before` String -> Property Linux
disabled String
service
		forall x y. Combines x y => x -> y -> CombinedType x y
`before` String -> Property UnixLike
File.notPresent String
overridefile

nspawnServiceParams :: ChrootCfg -> [String]
nspawnServiceParams :: ChrootCfg -> [String]
nspawnServiceParams ChrootCfg
NoChrootCfg = []
nspawnServiceParams (SystemdNspawnCfg [(String, Bool)]
ps) =
	forall k a. Map k a -> [k]
M.keys forall a b. (a -> b) -> a -> b
$ forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(String, Bool)]
ps

-- | Installs a "enter-machinename" script that root can use to run a
-- command inside the container.
--
-- 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 Linux Linux
enterScript :: Container -> RevertableProperty Linux Linux
enterScript c :: Container
c@(Container String
name Chroot
_ Host
_) =
	forall (p :: * -> *) (untightened :: [MetaType])
       (tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
 SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets Property
  (MetaTypes
     (Combine
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD]
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD]))
setup forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
<!> forall (p :: * -> *) (untightened :: [MetaType])
       (tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
 SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets Property UnixLike
teardown
  where
	setup :: Property
  (MetaTypes
     (Combine
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD]
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD]))
setup = forall {k} (metatypes :: k).
SingI metatypes =>
String
-> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes)
combineProperties (String
"generated " forall a. [a] -> [a] -> [a]
++ Container -> String
enterScriptFile Container
c) forall a b. (a -> b) -> a -> b
$ Props UnixLike
props
		forall {a} p (y :: [a]) (x :: [a]).
(IsProp p, MetaTypes y ~ GetMetaTypes p,
 CheckCombinableNote x y (NoteFor ('Text "&"))) =>
Props (MetaTypes x) -> p -> Props (MetaTypes (Combine x y))
& String
scriptfile String -> [String] -> Property UnixLike
`File.hasContent`
			[ String
"#!/usr/bin/perl"
			, String
"# Generated by propellor"
			, String
"my $pid=`machinectl show " forall a. [a] -> [a] -> [a]
++ ShowS
shellEscape String
name forall a. [a] -> [a] -> [a]
++ String
" -p Leader | cut -d= -f2`;"
			, String
"chomp $pid;"
			, String
"if (length $pid) {"
			, String
"\tforeach my $var (keys %ENV) {"
			, String
"\t\tdelete $ENV{$var} unless $var eq 'PATH' || $var eq 'TERM';"
			, String
"\t}"
			, String
"\texec('nsenter', '-p', '-u', '-n', '-i', '-m', '-t', $pid, @ARGV);"
			, String
"} else {"
			, String
"\tdie 'container not running';"
			, String
"}"
			, String
"exit(1);"
			]
		forall {a} p (y :: [a]) (x :: [a]).
(IsProp p, MetaTypes y ~ GetMetaTypes p,
 CheckCombinableNote x y (NoteFor ('Text "&"))) =>
Props (MetaTypes x) -> p -> Props (MetaTypes (Combine x y))
& String
scriptfile String -> FileMode -> Property UnixLike
`File.mode` [FileMode] -> FileMode
combineModes ([FileMode]
readModes forall a. [a] -> [a] -> [a]
++ [FileMode]
executeModes)
	teardown :: Property UnixLike
teardown = String -> Property UnixLike
File.notPresent String
scriptfile
	scriptfile :: String
scriptfile = Container -> String
enterScriptFile Container
c

enterScriptFile :: Container -> FilePath
enterScriptFile :: Container -> String
enterScriptFile (Container String
name Chroot
_ Host
_ ) = String
"/usr/local/bin/enter-" forall a. [a] -> [a] -> [a]
++ ShowS
mungename String
name

enterContainerProcess :: Container -> [String] -> IO (CreateProcess, IO ())
enterContainerProcess :: Container -> [String] -> IO (CreateProcess, IO ())
enterContainerProcess Container
c [String]
ps = forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> [String] -> CreateProcess
proc (Container -> String
enterScriptFile Container
c) [String]
ps, forall (m :: * -> *). Monad m => m ()
noop)

nspawnServiceName :: MachineName -> ServiceName
nspawnServiceName :: ShowS
nspawnServiceName String
name = String
"systemd-nspawn@" forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
".service"

containerDir :: MachineName -> FilePath
containerDir :: ShowS
containerDir String
name = String
"/var/lib/container" String -> ShowS
</> ShowS
mungename String
name

mungename :: MachineName -> String
mungename :: ShowS
mungename = forall a. Eq a => [a] -> [a] -> [a] -> [a]
replace String
"/" String
"_"

-- | This configures how systemd-nspawn(1) starts the container,
-- by specifying a parameter, such as "--private-network", or
-- "--link-journal=guest"
--
-- 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 + Linux) (HasInfo + Linux)
containerCfg :: String -> RevertableProperty (HasInfo + Linux) (HasInfo + Linux)
containerCfg String
p = forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
RevertableProperty (Bool -> Property (HasInfo + Linux)
mk Bool
True) (Bool -> Property (HasInfo + Linux)
mk Bool
False)
  where
	mk :: Bool -> Property (HasInfo + Linux)
	mk :: Bool -> Property (HasInfo + Linux)
mk Bool
b = forall (p :: * -> *) (untightened :: [MetaType])
       (tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
 SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets forall a b. (a -> b) -> a -> b
$
		forall v. IsInfo v => String -> v -> Property (HasInfo + UnixLike)
pureInfoProperty String
desc forall a b. (a -> b) -> a -> b
$
			forall a. Monoid a => a
mempty { _chrootCfg :: ChrootCfg
_chrootCfg = [(String, Bool)] -> ChrootCfg
SystemdNspawnCfg [(String
p', Bool
b)] }
	  where
		desc :: String
desc = String
"container configuration " forall a. [a] -> [a] -> [a]
++ (if Bool
b then String
"" else String
"without ") forall a. [a] -> [a] -> [a]
++ String
p'
	p' :: String
p' = case String
p of
		(Char
'-':String
_) -> String
p
		String
_ -> String
"--" forall a. [a] -> [a] -> [a]
++ String
p

-- | Bind mounts </etc/resolv.conf> from the host into the container.
--
-- This is not necessary when systemd configures the container's
-- resolv.conf on its own. This used to be enabled by default, but when
-- systemd did also configure the container's resolv.conf, that could
-- modify the host's resolv.conf.
resolvConfed :: RevertableProperty (HasInfo + Linux) (HasInfo + Linux)
resolvConfed :: RevertableProperty (HasInfo + Linux) (HasInfo + Linux)
resolvConfed = String -> RevertableProperty (HasInfo + Linux) (HasInfo + Linux)
containerCfg String
"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 + Linux) (HasInfo + Linux)
linkJournal :: RevertableProperty (HasInfo + Linux) (HasInfo + Linux)
linkJournal = String -> RevertableProperty (HasInfo + Linux) (HasInfo + Linux)
containerCfg String
"link-journal=try-guest"

-- | Disconnect networking of the container from the host.
privateNetwork :: RevertableProperty (HasInfo + Linux) (HasInfo + Linux)
privateNetwork :: RevertableProperty (HasInfo + Linux) (HasInfo + Linux)
privateNetwork = String -> RevertableProperty (HasInfo + Linux) (HasInfo + Linux)
containerCfg String
"private-network"

class Publishable a where
	toPublish :: a -> String

instance Publishable Port where
	toPublish :: Port -> String
toPublish Port
port = forall t. ConfigurableValue t => t -> String
val Port
port

instance Publishable (Bound Port) where
	toPublish :: Bound Port -> String
toPublish Bound Port
v = forall a. Publishable a => a -> String
toPublish (forall v. Bound v -> v
hostSide Bound Port
v) forall a. [a] -> [a] -> [a]
++ String
":" forall a. [a] -> [a] -> [a]
++ forall a. Publishable a => a -> String
toPublish (forall v. Bound v -> v
containerSide Bound Port
v)

data Proto = TCP | UDP

instance Publishable (Proto, Bound Port) where
	toPublish :: (Proto, Bound Port) -> String
toPublish (Proto
TCP, Bound Port
fp) = String
"tcp:" forall a. [a] -> [a] -> [a]
++ forall a. Publishable a => a -> String
toPublish Bound Port
fp
	toPublish (Proto
UDP, Bound Port
fp) = String
"udp:" forall a. [a] -> [a] -> [a]
++ forall a. Publishable a => a -> String
toPublish Bound Port
fp

-- | Publish a port from the container to the host.
--
-- This feature was first added in systemd version 220.
--
-- This property is only needed (and will only work) if the container
-- is configured to use private networking. Also, networkd should be enabled
-- both inside the container, and on the host. For example:
--
-- > foo :: Host
-- > foo = host "foo.example.com"
-- >	& Systemd.nspawned webserver
-- > 		`requires` Systemd.running Systemd.networkd
-- >
-- > webserver :: Systemd.container
-- > webserver = Systemd.container "webserver" (Chroot.debootstrapped mempty)
-- >	& os (System (Debian Testing) X86_64)
-- >	& Systemd.privateNetwork
-- >	& Systemd.running Systemd.networkd
-- >	& Systemd.publish (Port 80 ->- Port 8080)
-- >	& Apt.installedRunning "apache2"
publish :: Publishable p => p -> RevertableProperty (HasInfo + Linux) (HasInfo + Linux)
publish :: forall p.
Publishable p =>
p -> RevertableProperty (HasInfo + Linux) (HasInfo + Linux)
publish p
p = String -> RevertableProperty (HasInfo + Linux) (HasInfo + Linux)
containerCfg forall a b. (a -> b) -> a -> b
$ String
"--port=" forall a. [a] -> [a] -> [a]
++ forall a. Publishable a => a -> String
toPublish p
p

class Bindable a where
	toBind :: a -> String

instance Bindable FilePath where
	toBind :: ShowS
toBind String
f = String
f

instance Bindable (Bound FilePath) where
	toBind :: Bound String -> String
toBind Bound String
v = forall v. Bound v -> v
hostSide Bound String
v forall a. [a] -> [a] -> [a]
++ String
":" forall a. [a] -> [a] -> [a]
++ forall v. Bound v -> v
containerSide Bound String
v

-- | Bind mount a file or directory from the host into the container.
bind :: Bindable p => p -> RevertableProperty (HasInfo + Linux) (HasInfo + Linux)
bind :: forall p.
Bindable p =>
p -> RevertableProperty (HasInfo + Linux) (HasInfo + Linux)
bind p
p = String -> RevertableProperty (HasInfo + Linux) (HasInfo + Linux)
containerCfg forall a b. (a -> b) -> a -> b
$ String
"--bind=" forall a. [a] -> [a] -> [a]
++ forall a. Bindable a => a -> String
toBind p
p

-- | Read-only mind mount.
bindRo :: Bindable p => p -> RevertableProperty (HasInfo + Linux) (HasInfo + Linux)
bindRo :: forall p.
Bindable p =>
p -> RevertableProperty (HasInfo + Linux) (HasInfo + Linux)
bindRo p
p = String -> RevertableProperty (HasInfo + Linux) (HasInfo + Linux)
containerCfg forall a b. (a -> b) -> a -> b
$ String
"--bind-ro=" forall a. [a] -> [a] -> [a]
++ forall a. Bindable a => a -> String
toBind p
p

-- | Escapes a path for inclusion in a systemd unit name,
-- the same as systemd-escape does.
escapePath :: FilePath -> String
escapePath :: ShowS
escapePath = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> String
escape 
	forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
== Char
'/')
	forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
== Char
'/') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse
  where
	escape :: Char -> String
escape Char
'/' = String
"-"
	escape Char
c
		| ((Char -> Bool
isAscii Char
c Bool -> Bool -> Bool
&& Char -> Bool
isAlphaNum Char
c) Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'_') = [Char
c]
		| Bool
otherwise = Char
'\\' forall a. a -> [a] -> [a]
: Char
'x' forall a. a -> [a] -> [a]
: forall r. PrintfType r => String -> r
printf String
"%x" Char
c