propellor/src/Propellor/Property/Chroot.hs

{-# LANGUAGE FlexibleContexts #-}

module Propellor.Property.Chroot (
	Chroot(..),
	BuilderConf(..),
	debootstrapped,
	provisioned,
	-- * Internal use
	provisioned',
	propigateChrootInfo,
	propellChroot,
	chain,
) where

import Propellor
import Propellor.Types.CmdLine
import Propellor.Types.Chroot
import Propellor.Property.Chroot.Util
import qualified Propellor.Property.Debootstrap as Debootstrap
import qualified Propellor.Property.Systemd.Core as Systemd
import qualified Propellor.Shim as Shim
import Utility.SafeCommand

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

data Chroot = Chroot FilePath System BuilderConf Host
	deriving (Show)

data BuilderConf
	= UsingDeboostrap Debootstrap.DebootstrapConfig
	deriving (Show)

instance PropAccum Chroot where
	(Chroot l s c h) & p = Chroot l s c (h & p)
	(Chroot l s c h) &^ p = Chroot l s c (h &^ p)
	getProperties (Chroot _ _ _ h) = hostProperties h

-- | Defines a Chroot at the given location, built with debootstrap.
--
-- Properties can be added to configure the Chroot.
--
-- > debootstrapped (System (Debian Unstable) "amd64") Debootstrap.BuildD "/srv/chroot/ghc-dev"
-- >    & Apt.installed ["ghc", "haskell-platform"]
-- >	& ...
debootstrapped :: System -> Debootstrap.DebootstrapConfig -> FilePath -> Chroot
debootstrapped system conf location = case system of
	(System (Debian _) _) -> mk
	(System (Ubuntu _) _) -> mk
  where
	h = Host location [] mempty
	mk = Chroot location system (UsingDeboostrap conf) h
		& os system

-- | Ensures that the chroot exists and is provisioned according to its
-- properties.
--
-- Reverting this property removes the chroot. Note that it does not ensure
-- that any processes that might be running inside the chroot are stopped.
provisioned :: Chroot -> RevertableProperty
provisioned c = provisioned' (propigateChrootInfo c) c False

provisioned' :: (Property HasInfo -> Property HasInfo) -> Chroot -> Bool -> RevertableProperty
provisioned' propigator c@(Chroot loc system builderconf _) systemdonly =
	(propigator $ go "exists" setup)
		<!>
	(go "removed" teardown)
  where
	go desc a = propertyList (chrootDesc c desc) [a]

	setup = propellChroot c (inChrootProcess c) systemdonly
		`requires` toProp built
	
	built = case (system, builderconf) of
		((System (Debian _) _), UsingDeboostrap cf) -> debootstrap cf
		((System (Ubuntu _) _), UsingDeboostrap cf) -> debootstrap cf

	debootstrap = Debootstrap.built loc system

	teardown = toProp (revert built)

propigateChrootInfo :: (IsProp (Property i)) => Chroot -> Property i -> Property HasInfo
propigateChrootInfo c p = propigateContainer c p'
  where
	p' = infoProperty
		(propertyDesc p)
		(propertySatisfy p)
		(propertyInfo p <> chrootInfo c)
		(propertyChildren p)

chrootInfo :: Chroot -> Info
chrootInfo (Chroot loc _ _ h) =
	mempty { _chrootinfo = mempty { _chroots = M.singleton loc h } }

-- | Propellor is run inside the chroot to provision it.
propellChroot :: Chroot -> ([String] -> CreateProcess) -> Bool -> Property NoInfo
propellChroot c@(Chroot loc _ _ _) mkproc systemdonly = property (chrootDesc c "provisioned") $ do
	let d = localdir </> shimdir c
	let me = localdir </> "propellor"
	shim <- liftIO $ ifM (doesDirectoryExist d)
		( pure (Shim.file me d)
		, Shim.setup me Nothing d
		)
	ifM (liftIO $ bindmount shim)
		( chainprovision shim
		, return FailedChange
		)
  where
	bindmount shim = ifM (doesFileExist (loc ++ shim))
		( return True
		, do
			let mntpnt = loc ++ localdir
			createDirectoryIfMissing True mntpnt
			boolSystem "mount"
				[ Param "--bind"
				, File localdir, File mntpnt
				]
		)
	
	chainprovision shim = do
		parenthost <- asks hostName
		cmd <- liftIO $ toChain parenthost c systemdonly
		pe <- liftIO standardPathEnv
		let p = mkproc
			[ shim
			, "--continue"
			, show cmd
			]
		let p' = p { env = Just pe }
		liftIO $ withHandle StdoutHandle createProcessSuccess p'
			processChainOutput

toChain :: HostName -> Chroot -> Bool -> IO CmdLine
toChain parenthost (Chroot loc _ _ _) systemdonly = do
	onconsole <- isConsole <$> mkMessageHandle
	return $ ChrootChain parenthost loc systemdonly onconsole

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 $ _chrootinfo $ hostInfo parenthost) of
			Nothing -> errorMessage ("cannot find chroot " ++ loc ++ " on host " ++ hn)
			Just h -> go h
  where
	go h = do
		changeWorkingDirectory localdir
		when onconsole forceConsole
		onlyProcess (provisioningLock loc) $ do
			r <- runPropellor h $ ensureProperties $
				if systemdonly
					then [Systemd.installed]
					else map ignoreInfo $
						hostProperties h
			putStrLn $ "\n" ++ show r
chain _ _ = errorMessage "bad chain command"

inChrootProcess :: Chroot -> [String] -> CreateProcess
inChrootProcess (Chroot loc _ _ _) cmd = proc "chroot" (loc:cmd)

provisioningLock :: FilePath -> FilePath
provisioningLock containerloc = "chroot" </> mungeloc containerloc ++ ".lock"

shimdir :: Chroot -> FilePath
shimdir (Chroot loc _ _ _) = "chroot" </> mungeloc loc ++ ".shim"

mungeloc :: FilePath -> String
mungeloc = replace "/" "_"

chrootDesc :: Chroot -> String -> String
chrootDesc (Chroot loc _ _ _) desc = "chroot " ++ loc ++ " " ++ desc