-- | This module contains properties that configure how Propellor
-- bootstraps to run itself on a Host.

module Propellor.Property.Bootstrap (
	Bootstrapper(..),
	Builder(..),
	bootstrapWith,
	RepoSource(..),
	bootstrappedFrom,
	clonedFrom
) where

import Propellor.Base
import Propellor.Bootstrap
import Propellor.Types.Info
import Propellor.Types.Container
import Propellor.Property.Chroot
import Propellor.PrivData.Paths

import Data.List
import qualified Data.ByteString as B

-- | This property can be used to configure the `Bootstrapper` that is used
-- to bootstrap propellor on a Host. For example, if you want to use
-- stack:
--
-- > host "example.com" $ props
-- > 	& bootstrapWith (Robustly Stack)
--
-- When `bootstrappedFrom` is used in a `Chroot` or other `Container`, 
-- this property can also be added to the chroot to configure it.
bootstrapWith :: Bootstrapper -> Property (HasInfo + UnixLike)
bootstrapWith :: Bootstrapper -> Property (HasInfo + UnixLike)
bootstrapWith Bootstrapper
b = forall v. IsInfo v => [Char] -> v -> Property (HasInfo + UnixLike)
pureInfoProperty [Char]
desc (forall v. v -> InfoVal v
InfoVal Bootstrapper
b)
  where
	desc :: [Char]
desc = [Char]
"propellor bootstrapped with " forall a. [a] -> [a] -> [a]
++ case Bootstrapper
b of
		Robustly Builder
Stack -> [Char]
"stack"
		Robustly Builder
Cabal -> [Char]
"cabal"
		Bootstrapper
OSOnly -> [Char]
"OS packages only"

-- | Where a propellor repository should be bootstrapped from.
data RepoSource
	= GitRepoUrl String
	| GitRepoOutsideChroot
	-- ^ When used in a chroot, this copies the git repository from
	-- outside the chroot, including its configuration.

-- | Bootstraps a propellor installation into
-- /usr/local/propellor/
--
-- Normally, propellor is bootstrapped by eg, using propellor --spin,
-- and so this property is not generally needed.
--
-- This property only does anything when used inside a Chroot or other
-- Container. This is particularly useful inside a chroot used to build a
-- disk image, to make the disk image have propellor installed.
--
-- The git repository is cloned (or pulled to update if it already exists).
--
-- All build dependencies are installed, using distribution packages
-- or falling back to using cabal or stack.
bootstrappedFrom :: RepoSource -> Property Linux
bootstrappedFrom :: RepoSource -> Property Linux
bootstrappedFrom RepoSource
reposource = forall (p :: * -> *) i (m :: * -> *).
(Checkable p i, LiftPropellor m) =>
m Bool -> p i -> Property i
check (ContainerCapability -> Propellor Bool
hasContainerCapability ContainerCapability
FilesystemContained) forall a b. (a -> b) -> a -> b
$
	Property Linux
go forall x y. Combines x y => x -> y -> CombinedType x y
`requires` RepoSource -> Property Linux
clonedFrom RepoSource
reposource
  where
	go :: Property Linux
	go :: Property Linux
go = forall {k} (metatypes :: k).
SingI metatypes =>
[Char] -> Propellor Result -> Property (MetaTypes metatypes)
property [Char]
"Propellor bootstrapped" forall a b. (a -> b) -> a -> b
$ do
		Maybe System
system <- Propellor (Maybe System)
getOS
		-- gets Host value representing the chroot this is run in
		Host
chroothost <- forall r (m :: * -> *). MonadReader r m => m r
ask
		-- load privdata from outside the chroot, and filter
		-- to only the privdata needed inside the chroot.
		PrivMap
privdata <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Host -> PrivMap -> PrivMap
filterPrivData Host
chroothost
			forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO PrivMap
readPrivDataFile [Char]
privDataLocal
		Bootstrapper
bootstrapper <- Propellor Bootstrapper
getBootstrapper
		Propellor Bool -> Propellor Result
assumeChange forall a b. (a -> b) -> a -> b
$ forall a. ([Char] -> Propellor a) -> Propellor a
exposeTrueLocaldir forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ do
			forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True forall a b. (a -> b) -> a -> b
$
				[Char] -> [Char]
takeDirectory [Char]
privDataLocal
			forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
writeFileProtected [Char]
privDataLocal forall a b. (a -> b) -> a -> b
$
				forall a. Show a => a -> [Char]
show PrivMap
privdata
			[Char] -> Propellor Bool
runShellCommand forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
buildShellCommand
				[ [Char]
"cd " forall a. [a] -> [a] -> [a]
++ [Char]
localdir
				, Bootstrapper -> Maybe System -> [Char]
checkDepsCommand Bootstrapper
bootstrapper Maybe System
system
				, Bootstrapper -> [Char]
buildCommand Bootstrapper
bootstrapper
				]

-- | Clones the propellor repository into /usr/local/propellor/
--
-- If the propellor repo has already been cloned, pulls to get it
-- up-to-date.
clonedFrom :: RepoSource -> Property Linux
clonedFrom :: RepoSource -> Property Linux
clonedFrom RepoSource
reposource = case RepoSource
reposource of
	RepoSource
GitRepoOutsideChroot -> Property Linux
go forall x y. Combines x y => x -> y -> CombinedType x y
`onChange` Property Linux
copygitconfig
	RepoSource
_ -> Property Linux
go
  where
	go :: Property Linux
	go :: Property Linux
go = forall {k} (metatypes :: k).
SingI metatypes =>
[Char] -> Propellor Result -> Property (MetaTypes metatypes)
property ([Char]
"Propellor repo cloned from " forall a. [a] -> [a] -> [a]
++ [Char]
sourcedesc) forall a b. (a -> b) -> a -> b
$
		forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
ifM Propellor Bool
needclone (Propellor Result
makeclone, Propellor Result
updateclone)
	
	makeclone :: Propellor Result
makeclone = do
		let tmpclone :: [Char]
tmpclone = [Char]
localdir forall a. [a] -> [a] -> [a]
++ [Char]
".tmpclone"
		Maybe System
system <- Propellor (Maybe System)
getOS
		Propellor Bool -> Propellor Result
assumeChange forall a b. (a -> b) -> a -> b
$ forall a. ([Char] -> Propellor a) -> Propellor a
exposeTrueLocaldir forall a b. (a -> b) -> a -> b
$ \[Char]
sysdir -> do
			let originloc :: [Char]
originloc = case RepoSource
reposource of
				GitRepoUrl [Char]
s -> [Char]
s
				RepoSource
GitRepoOutsideChroot -> [Char]
sysdir
			[Char] -> Propellor Bool
runShellCommand forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
buildShellCommand
				[ Maybe System -> [Char]
installGitCommand Maybe System
system
				, [Char]
"rm -rf " forall a. [a] -> [a] -> [a]
++ [Char]
tmpclone
				, [Char]
"git clone " forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
shellEscape [Char]
originloc forall a. [a] -> [a] -> [a]
++ [Char]
" " forall a. [a] -> [a] -> [a]
++ [Char]
tmpclone
				, [Char]
"mkdir -p " forall a. [a] -> [a] -> [a]
++ [Char]
localdir
				-- This is done rather than deleting
				-- the old localdir, because if it is bound
				-- mounted from outside the chroot, deleting
				-- it after unmounting in unshare will remove
				-- the bind mount outside the unshare.
				, [Char]
"(cd " forall a. [a] -> [a] -> [a]
++ [Char]
tmpclone forall a. [a] -> [a] -> [a]
++ [Char]
" && tar c .) | (cd " forall a. [a] -> [a] -> [a]
++ [Char]
localdir forall a. [a] -> [a] -> [a]
++ [Char]
" && tar x)"
				, [Char]
"rm -rf " forall a. [a] -> [a] -> [a]
++ [Char]
tmpclone
				]
	
	updateclone :: Propellor Result
updateclone = Propellor Bool -> Propellor Result
assumeChange forall a b. (a -> b) -> a -> b
$ forall a. ([Char] -> Propellor a) -> Propellor a
exposeTrueLocaldir forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$
		[Char] -> Propellor Bool
runShellCommand forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
buildShellCommand
			[ [Char]
"cd " forall a. [a] -> [a] -> [a]
++ [Char]
localdir
			, [Char]
"git pull"
			]
	
	-- Copy the git config of the repo outside the chroot into the
	-- chroot. This way it has the same remote urls, and other git
	-- configuration.
	copygitconfig :: Property Linux
	copygitconfig :: Property Linux
copygitconfig = forall {k} (metatypes :: k).
SingI metatypes =>
[Char] -> Propellor Result -> Property (MetaTypes metatypes)
property ([Char]
"Propellor repo git config copied from outside the chroot") forall a b. (a -> b) -> a -> b
$ do
		let gitconfig :: [Char]
gitconfig = [Char]
localdir [Char] -> [Char] -> [Char]
</> [Char]
".git" [Char] -> [Char] -> [Char]
</> [Char]
"config"
		ByteString
cfg <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO ByteString
B.readFile [Char]
gitconfig
		forall a. ([Char] -> Propellor a) -> Propellor a
exposeTrueLocaldir forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$
			forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString -> IO ()
B.writeFile [Char]
gitconfig ByteString
cfg
		forall (m :: * -> *) a. Monad m => a -> m a
return Result
MadeChange

	needclone :: Propellor Bool
needclone = (ContainerCapability -> Propellor Bool
hasContainerCapability ContainerCapability
FilesystemContained forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
<&&> Propellor Bool
truelocaldirisempty)
		forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
<||> (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Bool -> Bool
not forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO Bool
doesDirectoryExist [Char]
localdir))
	
	truelocaldirisempty :: Propellor Bool
truelocaldirisempty = forall a. ([Char] -> Propellor a) -> Propellor a
exposeTrueLocaldir forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$
		[Char] -> Propellor Bool
runShellCommand ([Char]
"test ! -d " forall a. [a] -> [a] -> [a]
++ [Char]
localdir forall a. [a] -> [a] -> [a]
++ [Char]
"/.git")

	sourcedesc :: [Char]
sourcedesc = case RepoSource
reposource of
		GitRepoUrl [Char]
s -> [Char]
s
		RepoSource
GitRepoOutsideChroot -> [Char]
localdir forall a. [a] -> [a] -> [a]
++ [Char]
" outside the chroot"

assumeChange :: Propellor Bool -> Propellor Result
assumeChange :: Propellor Bool -> Propellor Result
assumeChange Propellor Bool
a = do
	Bool
ok <- Propellor Bool
a
	forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Result
cmdResult Bool
ok forall a. Semigroup a => a -> a -> a
<> Result
MadeChange)

buildShellCommand :: [String] -> String
buildShellCommand :: [[Char]] -> [Char]
buildShellCommand = forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"&&" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\[Char]
c -> [Char]
"(" forall a. [a] -> [a] -> [a]
++ [Char]
c forall a. [a] -> [a] -> [a]
++ [Char]
")")

runShellCommand :: String -> Propellor Bool
runShellCommand :: [Char] -> Propellor Bool
runShellCommand [Char]
s = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> [CommandParam] -> IO Bool
boolSystem [Char]
"sh" [ [Char] -> CommandParam
Param [Char]
"-c", [Char] -> CommandParam
Param [Char]
s]