{-# LANGUAGE FlexibleContexts, GADTs, DeriveDataTypeable #-}

module Propellor.Property.Chroot (
	debootstrapped,
	bootstrapped,
	provisioned,
	hostChroot,
	Chroot(..),
	ChrootBootstrapper(..),
	Debootstrapped(..),
	ChrootTarball(..),
	exposeTrueLocaldir,
	useHostProxy,
	-- * Internal use
	provisioned',
	propagateChrootInfo,
	propellChroot,
	chain,
	chrootSystem,
) where

import Propellor.Base
import Propellor.Container
import Propellor.Types.CmdLine
import Propellor.Types.Chroot
import Propellor.Types.Container
import Propellor.Types.Info
import Propellor.Types.Core
import Propellor.Property.Chroot.Util
import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.Debootstrap as Debootstrap
import qualified Propellor.Property.Systemd.Core as Systemd
import qualified Propellor.Property.File as File
import qualified Propellor.Shim as Shim
import Propellor.Property.Mount
import Utility.Split

import qualified Data.Map as M
import System.Posix.Directory

-- | Specification of a chroot. Normally you'll use `debootstrapped` or
-- `bootstrapped` or `hostChroot` to construct a Chroot value.
data Chroot where
	Chroot :: ChrootBootstrapper b => FilePath -> b -> InfoPropagator -> Host -> Chroot

instance IsContainer Chroot where
	containerProperties :: Chroot -> [ChildProperty]
containerProperties (Chroot FilePath
_ b
_ InfoPropagator
_ Host
h) = forall c. IsContainer c => c -> [ChildProperty]
containerProperties Host
h
	containerInfo :: Chroot -> Info
containerInfo (Chroot FilePath
_ b
_ InfoPropagator
_ Host
h) = forall c. IsContainer c => c -> Info
containerInfo Host
h
	setContainerProperties :: Chroot -> [ChildProperty] -> Chroot
setContainerProperties (Chroot FilePath
loc b
b InfoPropagator
p Host
h) [ChildProperty]
ps =
		let h' :: Host
h' = forall c. IsContainer c => c -> [ChildProperty] -> c
setContainerProperties Host
h [ChildProperty]
ps
		in forall b.
ChrootBootstrapper b =>
FilePath -> b -> InfoPropagator -> Host -> Chroot
Chroot FilePath
loc b
b InfoPropagator
p Host
h'

chrootSystem :: Chroot -> Maybe System
chrootSystem :: Chroot -> Maybe System
chrootSystem = forall v. InfoVal v -> Maybe v
fromInfoVal forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. IsInfo v => Info -> v
fromInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. IsContainer c => c -> Info
containerInfo

instance Show Chroot where
	show :: Chroot -> FilePath
show c :: Chroot
c@(Chroot FilePath
loc b
_ InfoPropagator
_ Host
_) = FilePath
"Chroot " forall a. [a] -> [a] -> [a]
++ FilePath
loc forall a. [a] -> [a] -> [a]
++ FilePath
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show (Chroot -> Maybe System
chrootSystem Chroot
c)

-- | 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
		-> Info -- ^ info of the Properties of the chroot
		-> FilePath -- ^ where to bootstrap the chroot
		-> Either String (Property Linux)

-- | Use this to bootstrap a chroot by extracting a tarball.
--
-- The tarball is expected to contain a root directory (no top-level
-- directory, also known as a "tarbomb").
-- It may be optionally compressed with any format `tar` knows how to
-- detect automatically.
data ChrootTarball = ChrootTarball FilePath

instance ChrootBootstrapper ChrootTarball where
	buildchroot :: ChrootTarball
-> Info -> FilePath -> Either FilePath (Property Linux)
buildchroot (ChrootTarball FilePath
tb) Info
_ FilePath
loc = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> 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
$ FilePath -> FilePath -> Property UnixLike
extractTarball FilePath
loc FilePath
tb

extractTarball :: FilePath -> FilePath -> Property UnixLike
extractTarball :: FilePath -> FilePath -> Property UnixLike
extractTarball FilePath
target FilePath
src = forall (p :: * -> *) i (m :: * -> *).
(Checkable p i, LiftPropellor m) =>
m Bool -> p i -> Property i
check (FilePath -> IO Bool
isUnpopulated FilePath
target) forall a b. (a -> b) -> a -> b
$
	FilePath -> [FilePath] -> UncheckedProperty UnixLike
cmdProperty FilePath
"tar" [FilePath]
params
		forall (p :: * -> *) i.
Checkable p i =>
p i -> Result -> Property i
`assume` Result
MadeChange
		forall x y. Combines x y => x -> y -> CombinedType x y
`requires` FilePath -> Property UnixLike
File.dirExists FilePath
target
  where
	params :: [FilePath]
params =
		[ FilePath
"-C"
		, FilePath
target
		, FilePath
"-xf"
		, FilePath
src
		]

-- | Use this to bootstrap a chroot with debootstrap.
data Debootstrapped = Debootstrapped Debootstrap.DebootstrapConfig

instance ChrootBootstrapper Debootstrapped where
	buildchroot :: Debootstrapped
-> Info -> FilePath -> Either FilePath (Property Linux)
buildchroot (Debootstrapped DebootstrapConfig
cf) Info
info FilePath
loc = case Maybe System
system of
		(Just s :: System
s@(System (Debian DebianKernel
_ DebianSuite
_) Architecture
_)) -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ System -> Property Linux
debootstrap System
s
		(Just s :: System
s@(System (Buntish FilePath
_) Architecture
_)) -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ System -> Property Linux
debootstrap System
s
		(Just (System Distribution
ArchLinux Architecture
_)) -> forall a b. a -> Either a b
Left FilePath
"Arch Linux not supported by debootstrap."
		(Just (System (FreeBSD FreeBSDRelease
_) Architecture
_)) -> forall a b. a -> Either a b
Left FilePath
"FreeBSD not supported by debootstrap."
		Maybe System
Nothing -> forall a b. a -> Either a b
Left FilePath
"Cannot debootstrap; OS not specified"
	  where
		debootstrap :: System -> Property Linux
debootstrap System
s = FilePath -> System -> DebootstrapConfig -> Property Linux
Debootstrap.built FilePath
loc System
s
			(DebootstrapConfig
cf forall a. Semigroup a => a -> a -> a
<> DebootstrapConfig
proxyConf forall a. Semigroup a => a -> a -> a
<> DebootstrapConfig
mirrorConf)
		system :: Maybe System
system = forall v. InfoVal v -> Maybe v
fromInfoVal (forall v. IsInfo v => Info -> v
fromInfo Info
info)
		-- If the chroot has a configured apt proxy and/or mirror, pass
		-- these on to debootstrap.  Note that Debootstrap.built does
		-- not get passed the Chroot, so the info inspection has to
		-- happen here, not there
		proxyConf :: DebootstrapConfig
proxyConf = case (forall v. InfoVal v -> Maybe v
fromInfoVal forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. IsInfo v => Info -> v
fromInfo) Info
info of
			Just (Apt.HostAptProxy FilePath
u) ->
				FilePath -> DebootstrapConfig
Debootstrap.DebootstrapProxy FilePath
u
			Maybe HostAptProxy
Nothing -> forall a. Monoid a => a
mempty
		mirrorConf :: DebootstrapConfig
mirrorConf = case (forall v. InfoVal v -> Maybe v
fromInfoVal forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. IsInfo v => Info -> v
fromInfo) Info
info of
			Just (Apt.HostMirror FilePath
u) ->
				FilePath -> DebootstrapConfig
Debootstrap.DebootstrapMirror FilePath
u
			Maybe HostMirror
Nothing -> forall a. Monoid a => a
mempty

-- | Defines a Chroot at the given location, built with debootstrap.
--
-- Properties can be added to configure the Chroot. At a minimum,
-- add a property such as `osDebian` to specify the operating system
-- to bootstrap.
--
-- If the 'Debootstrap.DebootstrapConfig' does not include a 
-- 'Debootstrap.DebootstrapMirror',
-- any 'Apt.mirror' property of the chroot will configure debootstrap.
-- Same for 'Debootstrap.DebootstrapProxy' and 'Apt.proxy'.
--
-- > debootstrapped Debootstrap.BuildD "/srv/chroot/ghc-dev" $ props
-- >	& osDebian Unstable X86_64
-- >	& Apt.installed ["ghc", "haskell-platform"]
-- >	& ...
debootstrapped :: Debootstrap.DebootstrapConfig -> FilePath -> Props metatypes -> Chroot
debootstrapped :: forall metatypes.
DebootstrapConfig -> FilePath -> Props metatypes -> Chroot
debootstrapped DebootstrapConfig
conf = forall b metatypes.
ChrootBootstrapper b =>
b -> FilePath -> Props metatypes -> Chroot
bootstrapped (DebootstrapConfig -> Debootstrapped
Debootstrapped DebootstrapConfig
conf)

-- | Defines a Chroot at the given location, bootstrapped with the
-- specified ChrootBootstrapper.
--
-- Like 'Chroot.debootstrapped', if the 'ChrootBootstrapper' is
-- 'Debootstrapped', this property respects the Chroot's
-- 'Apt.proxy' and 'Apt.mirror' properties.
bootstrapped :: ChrootBootstrapper b => b -> FilePath -> Props metatypes -> Chroot
bootstrapped :: forall b metatypes.
ChrootBootstrapper b =>
b -> FilePath -> Props metatypes -> Chroot
bootstrapped b
bootstrapper FilePath
location Props metatypes
ps = Chroot
c
  where
	c :: Chroot
c = forall b.
ChrootBootstrapper b =>
FilePath -> b -> InfoPropagator -> Host -> Chroot
Chroot FilePath
location b
bootstrapper InfoPropagator
propagateChrootInfo (forall metatypes. FilePath -> Props metatypes -> Host
host FilePath
location Props metatypes
ps)

-- | Ensures that the chroot exists and is provisioned according to its
-- properties.
--
-- 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 + Linux) Linux
provisioned :: Chroot -> RevertableProperty (HasInfo + Linux) Linux
provisioned Chroot
c = Chroot
-> Bool
-> [ContainerCapability]
-> RevertableProperty (HasInfo + Linux) Linux
provisioned' Chroot
c Bool
False [ContainerCapability
FilesystemContained]

provisioned'
	:: Chroot
	-> Bool
	-> [ContainerCapability]
	-> RevertableProperty (HasInfo + Linux) Linux
provisioned' :: Chroot
-> Bool
-> [ContainerCapability]
-> RevertableProperty (HasInfo + Linux) Linux
provisioned' c :: Chroot
c@(Chroot FilePath
loc b
bootstrapper InfoPropagator
infopropigator Host
_) Bool
systemdonly [ContainerCapability]
caps =
	(InfoPropagator
infopropigator Chroot
c PropagateInfo -> Bool
normalContainerInfo forall a b. (a -> b) -> a -> b
$ Property Linux
setup forall p. IsProp p => p -> FilePath -> p
`describe` Chroot -> ShowS
chrootDesc Chroot
c FilePath
"exists")
		forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
<!>
	(Property Linux
teardown forall p. IsProp p => p -> FilePath -> p
`describe` Chroot -> ShowS
chrootDesc Chroot
c FilePath
"removed")
  where
	setup :: Property Linux
	setup :: Property Linux
setup = Chroot
-> ([FilePath] -> IO (CreateProcess, IO ()))
-> Bool
-> [ContainerCapability]
-> Property UnixLike
propellChroot Chroot
c (Bool -> Chroot -> [FilePath] -> IO (CreateProcess, IO ())
inChrootProcess (Bool -> Bool
not Bool
systemdonly) Chroot
c) Bool
systemdonly [ContainerCapability]
caps
		forall x y. Combines x y => x -> y -> CombinedType x y
`requires` Property Linux
built

	built :: Property Linux
built = case forall b.
ChrootBootstrapper b =>
b -> Info -> FilePath -> Either FilePath (Property Linux)
buildchroot b
bootstrapper (forall c. IsContainer c => c -> Info
containerInfo Chroot
c) FilePath
loc of
		Right Property Linux
p -> Property Linux
p
		Left FilePath
e -> FilePath -> Property Linux
cantbuild FilePath
e

	cantbuild :: FilePath -> Property Linux
cantbuild FilePath
e = forall {k} (metatypes :: k).
SingI metatypes =>
FilePath -> Propellor Result -> Property (MetaTypes metatypes)
property (Chroot -> ShowS
chrootDesc Chroot
c FilePath
"built") (forall a. HasCallStack => FilePath -> a
error FilePath
e)

	teardown :: Property Linux
	teardown :: Property Linux
teardown = 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
<$> FilePath -> IO Bool
isUnpopulated FilePath
loc) forall a b. (a -> b) -> a -> b
$
		forall {k} (metatypes :: k).
SingI metatypes =>
FilePath -> Propellor Result -> Property (MetaTypes metatypes)
property (FilePath
"removed " forall a. [a] -> [a] -> [a]
++ FilePath
loc) forall a b. (a -> b) -> a -> b
$
			IO () -> Propellor Result
makeChange (FilePath -> IO ()
removeChroot FilePath
loc)

type InfoPropagator = Chroot -> (PropagateInfo -> Bool) -> Property Linux -> Property (HasInfo + Linux)

propagateChrootInfo :: InfoPropagator
propagateChrootInfo :: InfoPropagator
propagateChrootInfo c :: Chroot
c@(Chroot FilePath
location b
_ InfoPropagator
_ Host
_) PropagateInfo -> Bool
pinfo Property Linux
p =
	forall metatypes c.
(IncludesInfo metatypes ~ 'True, IsContainer c) =>
FilePath
-> c
-> (PropagateInfo -> Bool)
-> Property metatypes
-> Property metatypes
propagateContainer FilePath
location Chroot
c PropagateInfo -> Bool
pinfo forall a b. (a -> b) -> a -> b
$
		Property Linux
p forall {k} (metatypes' :: k) metatypes.
(MetaTypes metatypes' ~ (HasInfo + metatypes), SingI metatypes') =>
Property metatypes -> Info -> Property (MetaTypes metatypes')
`setInfoProperty` Chroot -> Info
chrootInfo Chroot
c

chrootInfo :: Chroot -> Info
chrootInfo :: Chroot -> Info
chrootInfo (Chroot FilePath
loc b
_ InfoPropagator
_ Host
h) = forall a. Monoid a => a
mempty forall v. IsInfo v => Info -> v -> Info
`addInfo`
	forall a. Monoid a => a
mempty { _chroots :: Map FilePath Host
_chroots = forall k a. k -> a -> Map k a
M.singleton FilePath
loc Host
h }

-- | Propellor is run inside the chroot to provision it.
propellChroot :: Chroot -> ([String] -> IO (CreateProcess, IO ())) -> Bool -> [ContainerCapability] -> Property UnixLike
propellChroot :: Chroot
-> ([FilePath] -> IO (CreateProcess, IO ()))
-> Bool
-> [ContainerCapability]
-> Property UnixLike
propellChroot c :: Chroot
c@(Chroot FilePath
loc b
_ InfoPropagator
_ Host
_) [FilePath] -> IO (CreateProcess, IO ())
mkproc Bool
systemdonly [ContainerCapability]
caps = forall {k} (metatypes :: k).
SingI metatypes =>
FilePath -> Propellor Result -> Property (MetaTypes metatypes)
property (Chroot -> ShowS
chrootDesc Chroot
c FilePath
"provisioned") forall a b. (a -> b) -> a -> b
$ do
	let d :: FilePath
d = FilePath
localdir FilePath -> ShowS
</> Chroot -> FilePath
shimdir Chroot
c
	let me :: FilePath
me = FilePath
localdir FilePath -> ShowS
</> FilePath
"propellor"
	FilePath
shim <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe FilePath -> FilePath -> IO FilePath
Shim.setup FilePath
me forall a. Maybe a
Nothing FilePath
d
	forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
ifM (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
bindmount FilePath
shim)
		( FilePath -> Propellor Result
chainprovision FilePath
shim
		, forall (m :: * -> *) a. Monad m => a -> m a
return Result
FailedChange
		)
  where
	bindmount :: FilePath -> IO Bool
bindmount FilePath
shim = forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
ifM (FilePath -> IO Bool
doesFileExist (FilePath
loc forall a. [a] -> [a] -> [a]
++ FilePath
shim))
		( forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
		, do
			let mntpnt :: FilePath
mntpnt = FilePath
loc forall a. [a] -> [a] -> [a]
++ FilePath
localdir
			Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
mntpnt
			FilePath -> [CommandParam] -> IO Bool
boolSystem FilePath
"mount"
				[ FilePath -> CommandParam
Param FilePath
"--bind"
				, FilePath -> CommandParam
File FilePath
localdir, FilePath -> CommandParam
File FilePath
mntpnt
				]
		)

	chainprovision :: FilePath -> Propellor Result
chainprovision FilePath
shim = do
		FilePath
parenthost <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Host -> FilePath
hostName
		CmdLine
cmd <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> Chroot -> Bool -> [ContainerCapability] -> IO CmdLine
toChain FilePath
parenthost Chroot
c Bool
systemdonly [ContainerCapability]
caps
		[(FilePath, FilePath)]
pe <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [(FilePath, FilePath)]
standardPathEnv
		(CreateProcess
p, IO ()
cleanup) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [FilePath] -> IO (CreateProcess, IO ())
mkproc
			[ FilePath
shim
			, FilePath
"--continue"
			, forall a. Show a => a -> FilePath
show CmdLine
cmd
			]
		Result
r <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ CreateProcess -> IO Result
chainPropellor (CreateProcess
p { env :: Maybe [(FilePath, FilePath)]
env = forall a. a -> Maybe a
Just [(FilePath, FilePath)]
pe })
		forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
cleanup
		forall (m :: * -> *) a. Monad m => a -> m a
return Result
r

toChain :: HostName -> Chroot -> Bool -> [ContainerCapability] -> IO CmdLine
toChain :: FilePath -> Chroot -> Bool -> [ContainerCapability] -> IO CmdLine
toChain FilePath
parenthost (Chroot FilePath
loc b
_ InfoPropagator
_ Host
_) Bool
systemdonly [ContainerCapability]
caps = do
	Bool
onconsole <- MessageHandle -> Bool
isConsole forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO MessageHandle
getMessageHandle
	forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ FilePath
-> FilePath -> Bool -> Bool -> [ContainerCapability] -> CmdLine
ChrootChain FilePath
parenthost FilePath
loc Bool
systemdonly Bool
onconsole [ContainerCapability]
caps

chain :: [Host] -> CmdLine -> IO ()
chain :: [Host] -> CmdLine -> IO ()
chain [Host]
hostlist (ChrootChain FilePath
hn FilePath
loc Bool
systemdonly Bool
onconsole [ContainerCapability]
caps) =
	case [Host] -> FilePath -> Maybe Host
findHostNoAlias [Host]
hostlist FilePath
hn of
		Maybe Host
Nothing -> forall (m :: * -> *) a. MonadIO m => FilePath -> m a
errorMessage (FilePath
"cannot find host " forall a. [a] -> [a] -> [a]
++ FilePath
hn)
		Just Host
parenthost -> case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup FilePath
loc (ChrootInfo -> Map FilePath Host
_chroots 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
parenthost) of
			Maybe Host
Nothing -> forall (m :: * -> *) a. MonadIO m => FilePath -> m a
errorMessage (FilePath
"cannot find chroot " forall a. [a] -> [a] -> [a]
++ FilePath
loc forall a. [a] -> [a] -> [a]
++ FilePath
" on host " forall a. [a] -> [a] -> [a]
++ FilePath
hn)
			Just Host
h -> Host -> IO ()
go Host
h
  where
	go :: Host -> IO ()
go Host
h = do
		FilePath -> IO ()
changeWorkingDirectory FilePath
localdir
		forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
onconsole IO ()
forceConsole
		forall a. FilePath -> IO a -> IO a
onlyProcess (ShowS
provisioningLock FilePath
loc) forall a b. (a -> b) -> a -> b
$
			Host -> Propellor Result -> IO ()
runChainPropellor (Host -> Host
setcaps Host
h) forall a b. (a -> b) -> a -> b
$
				[ChildProperty] -> Propellor Result
ensureChildProperties forall a b. (a -> b) -> a -> b
$
					if Bool
systemdonly
						then [forall p. IsProp p => p -> ChildProperty
toChildProperty Property DebianLike
Systemd.installed]
						else Host -> [ChildProperty]
hostProperties Host
h
	setcaps :: Host -> Host
setcaps Host
h = Host
h { hostInfo :: Info
hostInfo = Host -> Info
hostInfo Host
h forall v. IsInfo v => Info -> v -> Info
`addInfo` [ContainerCapability]
caps }
chain [Host]
_ CmdLine
_ = forall (m :: * -> *) a. MonadIO m => FilePath -> m a
errorMessage FilePath
"bad chain command"

inChrootProcess :: Bool -> Chroot -> [String] -> IO (CreateProcess, IO ())
inChrootProcess :: Bool -> Chroot -> [FilePath] -> IO (CreateProcess, IO ())
inChrootProcess Bool
keepprocmounted (Chroot FilePath
loc b
_ InfoPropagator
_ Host
_) [FilePath]
cmd = do
	IO ()
mountproc
	forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> [FilePath] -> CreateProcess
proc FilePath
"chroot" (FilePath
locforall a. a -> [a] -> [a]
:[FilePath]
cmd), IO ()
cleanup)
  where
	-- /proc needs to be mounted in the chroot for the linker to use
	-- /proc/self/exe which is necessary for some commands to work
	mountproc :: IO ()
mountproc = forall {m :: * -> *}. Monad m => m Bool -> m () -> m ()
unlessM (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem FilePath
procloc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO [FilePath]
mountPointsBelow FilePath
loc) forall a b. (a -> b) -> a -> b
$
		forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> FilePath -> MountOpts -> IO Bool
mount FilePath
"proc" FilePath
"proc" FilePath
procloc forall a. Monoid a => a
mempty

	procloc :: FilePath
procloc = FilePath
loc FilePath -> ShowS
</> FilePath
"proc"

	cleanup :: IO ()
cleanup
		| Bool
keepprocmounted = forall (m :: * -> *). Monad m => m ()
noop
		| Bool
otherwise = forall {m :: * -> *}. Monad m => m Bool -> m () -> m ()
whenM (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem FilePath
procloc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO [FilePath]
mountPointsBelow FilePath
loc) forall a b. (a -> b) -> a -> b
$
			FilePath -> IO ()
umountLazy FilePath
procloc

provisioningLock :: FilePath -> FilePath
provisioningLock :: ShowS
provisioningLock FilePath
containerloc = FilePath
"chroot" FilePath -> ShowS
</> ShowS
mungeloc FilePath
containerloc forall a. [a] -> [a] -> [a]
++ FilePath
".lock"

shimdir :: Chroot -> FilePath
shimdir :: Chroot -> FilePath
shimdir (Chroot FilePath
loc b
_ InfoPropagator
_ Host
_) = FilePath
"chroot" FilePath -> ShowS
</> ShowS
mungeloc FilePath
loc forall a. [a] -> [a] -> [a]
++ FilePath
".shim"

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

chrootDesc :: Chroot -> String -> String
chrootDesc :: Chroot -> ShowS
chrootDesc (Chroot FilePath
loc b
_ InfoPropagator
_ Host
_) FilePath
desc = FilePath
"chroot " forall a. [a] -> [a] -> [a]
++ FilePath
loc forall a. [a] -> [a] -> [a]
++ FilePath
" " forall a. [a] -> [a] -> [a]
++ FilePath
desc

-- | Runs an action with the true localdir exposed,
-- not the one bind-mounted into a chroot. The action is passed the
-- path containing the contents of the localdir outside the chroot.
--
-- In a chroot, this is accomplished by temporily bind mounting the localdir
-- to a temp directory, to preserve access to the original bind mount. Then
-- we unmount the localdir to expose the true localdir. Finally, to cleanup,
-- the temp directory is bind mounted back to the localdir.
exposeTrueLocaldir :: (FilePath -> Propellor a) -> Propellor a
exposeTrueLocaldir :: forall a. (FilePath -> Propellor a) -> Propellor a
exposeTrueLocaldir FilePath -> Propellor a
a = forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
ifM (ContainerCapability -> Propellor Bool
hasContainerCapability ContainerCapability
FilesystemContained)
	( forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
FilePath -> FilePath -> (FilePath -> m a) -> m a
withTmpDirIn (ShowS
takeDirectory FilePath
localdir) FilePath
"propellor.tmp" forall a b. (a -> b) -> a -> b
$ \FilePath
tmpdir ->
		forall (m :: * -> *) a c b. MonadMask m => m a -> m c -> m b -> m b
bracket_
			(forall {m :: * -> *}. MonadIO m => FilePath -> FilePath -> m ()
movebindmount FilePath
localdir FilePath
tmpdir)
			(forall {m :: * -> *}. MonadIO m => FilePath -> FilePath -> m ()
movebindmount FilePath
tmpdir FilePath
localdir)
			(FilePath -> Propellor a
a FilePath
tmpdir)
	, FilePath -> Propellor a
a FilePath
localdir
	)
  where
	movebindmount :: FilePath -> FilePath -> m ()
movebindmount FilePath
from FilePath
to = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
		FilePath -> [CommandParam] -> IO ()
run FilePath
"mount" [FilePath -> CommandParam
Param FilePath
"--bind", FilePath -> CommandParam
File FilePath
from, FilePath -> CommandParam
File FilePath
to]
		-- Have to lazy unmount, because the propellor process
		-- is running in the localdir that it's unmounting..
		FilePath -> [CommandParam] -> IO ()
run FilePath
"umount" [FilePath -> CommandParam
Param FilePath
"-l", FilePath -> CommandParam
File FilePath
from]
		-- We were in the old localdir; move to the new one after
		-- flipping the bind mounts. Otherwise, commands that try
		-- to access the cwd will fail because it got umounted out
		-- from under.
		FilePath -> IO ()
changeWorkingDirectory FilePath
"/"
		FilePath -> IO ()
changeWorkingDirectory FilePath
localdir
	run :: FilePath -> [CommandParam] -> IO ()
run FilePath
cmd [CommandParam]
ps = forall {m :: * -> *}. Monad m => m Bool -> m () -> m ()
unlessM (FilePath -> [CommandParam] -> IO Bool
boolSystem FilePath
cmd [CommandParam]
ps) forall a b. (a -> b) -> a -> b
$
		forall a. HasCallStack => FilePath -> a
error forall a b. (a -> b) -> a -> b
$ FilePath
"exposeTrueLocaldir failed to run " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show (FilePath
cmd, [CommandParam]
ps)

-- | Generates a Chroot that has all the properties of a Host.
-- 
-- Note that it's possible to create loops using this, where a host
-- contains a Chroot containing itself etc. Such loops will be detected at
-- runtime.
hostChroot :: ChrootBootstrapper bootstrapper => Host -> bootstrapper -> FilePath -> Chroot
hostChroot :: forall bootstrapper.
ChrootBootstrapper bootstrapper =>
Host -> bootstrapper -> FilePath -> Chroot
hostChroot Host
h bootstrapper
bootstrapper FilePath
d = Chroot
chroot
  where
	chroot :: Chroot
chroot = forall b.
ChrootBootstrapper b =>
FilePath -> b -> InfoPropagator -> Host -> Chroot
Chroot FilePath
d bootstrapper
bootstrapper InfoPropagator
pinfo Host
h
	pinfo :: InfoPropagator
pinfo = Host -> InfoPropagator
propagateHostChrootInfo Host
h

-- This is different than propagateChrootInfo in that Info using
-- HostContext is not made to use the name of the chroot as its context,
-- but instead uses the hostname of the Host.
propagateHostChrootInfo :: Host -> InfoPropagator
propagateHostChrootInfo :: Host -> InfoPropagator
propagateHostChrootInfo Host
h Chroot
c PropagateInfo -> Bool
pinfo Property Linux
p =
	forall metatypes c.
(IncludesInfo metatypes ~ 'True, IsContainer c) =>
FilePath
-> c
-> (PropagateInfo -> Bool)
-> Property metatypes
-> Property metatypes
propagateContainer (Host -> FilePath
hostName Host
h) Chroot
c PropagateInfo -> Bool
pinfo forall a b. (a -> b) -> a -> b
$
		Property Linux
p forall {k} (metatypes' :: k) metatypes.
(MetaTypes metatypes' ~ (HasInfo + metatypes), SingI metatypes') =>
Property metatypes -> Info -> Property (MetaTypes metatypes')
`setInfoProperty` Chroot -> Info
chrootInfo Chroot
c

-- | Ensure that a chroot uses the host's Apt proxy.
--
-- This property is often used for 'Sbuild.built' chroots, when the host has
-- 'Apt.useLocalCacher'.
useHostProxy :: Host -> Property DebianLike
useHostProxy :: Host -> Property DebianLike
useHostProxy Host
h = forall {k} (metatypes :: k).
SingI metatypes =>
FilePath
-> (OuterMetaTypesWitness metatypes -> Propellor Result)
-> Property (MetaTypes metatypes)
property' FilePath
"use host's apt proxy" forall a b. (a -> b) -> a -> b
$ \OuterMetaTypesWitness
  '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
w ->
	-- Note that we can't look at getProxyInfo outside the property,
	-- as that would loop, but it's ok to look at it inside the
	-- property. Thus the slightly strange construction here.
	case Host -> Maybe HostAptProxy
getProxyInfo Host
h of
		Just (Apt.HostAptProxy FilePath
u) -> forall (inner :: [MetaType]) (outer :: [MetaType]).
EnsurePropertyAllowed inner outer =>
OuterMetaTypesWitness outer
-> Property (MetaTypes inner) -> Propellor Result
ensureProperty OuterMetaTypesWitness
  '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
w (FilePath -> Property DebianLike
Apt.proxy' FilePath
u)
		Maybe HostAptProxy
Nothing -> Propellor Result
noChange
  where
	getProxyInfo :: Host -> Maybe HostAptProxy
getProxyInfo = forall v. InfoVal v -> Maybe v
fromInfoVal forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. IsInfo v => Info -> v
fromInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. Host -> Info
hostInfo