-- | 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 = Desc -> InfoVal Bootstrapper -> Property (HasInfo + UnixLike)
forall v. IsInfo v => Desc -> v -> Property (HasInfo + UnixLike)
pureInfoProperty Desc
desc (Bootstrapper -> InfoVal Bootstrapper
forall v. v -> InfoVal v
InfoVal Bootstrapper
b)
  where
	desc :: Desc
desc = Desc
"propellor bootstrapped with " Desc -> Desc -> Desc
forall a. [a] -> [a] -> [a]
++ case Bootstrapper
b of
		Robustly Builder
Stack -> Desc
"stack"
		Robustly Builder
Cabal -> Desc
"cabal"
		Bootstrapper
OSOnly -> Desc
"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 = Propellor Bool -> Property Linux -> Property Linux
forall (p :: * -> *) i (m :: * -> *).
(Checkable p i, LiftPropellor m) =>
m Bool -> p i -> Property i
check (ContainerCapability -> Propellor Bool
hasContainerCapability ContainerCapability
FilesystemContained) (Property Linux -> Property Linux)
-> Property Linux -> Property Linux
forall a b. (a -> b) -> a -> b
$
	Property Linux
go Property Linux
-> Property Linux -> CombinedType (Property Linux) (Property Linux)
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 = Desc -> Propellor Result -> Property Linux
forall k (metatypes :: k).
SingI metatypes =>
Desc -> Propellor Result -> Property (MetaTypes metatypes)
property Desc
"Propellor bootstrapped" (Propellor Result -> Property Linux)
-> Propellor Result -> Property Linux
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 <- Propellor Host
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 <- IO PrivMap -> Propellor PrivMap
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO PrivMap -> Propellor PrivMap)
-> IO PrivMap -> Propellor PrivMap
forall a b. (a -> b) -> a -> b
$ Host -> PrivMap -> PrivMap
filterPrivData Host
chroothost
			(PrivMap -> PrivMap) -> IO PrivMap -> IO PrivMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Desc -> IO PrivMap
readPrivDataFile Desc
privDataLocal
		Bootstrapper
bootstrapper <- Propellor Bootstrapper
getBootstrapper
		Propellor Bool -> Propellor Result
assumeChange (Propellor Bool -> Propellor Result)
-> Propellor Bool -> Propellor Result
forall a b. (a -> b) -> a -> b
$ (Desc -> Propellor Bool) -> Propellor Bool
forall a. (Desc -> Propellor a) -> Propellor a
exposeTrueLocaldir ((Desc -> Propellor Bool) -> Propellor Bool)
-> (Desc -> Propellor Bool) -> Propellor Bool
forall a b. (a -> b) -> a -> b
$ Propellor Bool -> Desc -> Propellor Bool
forall a b. a -> b -> a
const (Propellor Bool -> Desc -> Propellor Bool)
-> Propellor Bool -> Desc -> Propellor Bool
forall a b. (a -> b) -> a -> b
$ do
			IO () -> Propellor ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Propellor ()) -> IO () -> Propellor ()
forall a b. (a -> b) -> a -> b
$ Bool -> Desc -> IO ()
createDirectoryIfMissing Bool
True (Desc -> IO ()) -> Desc -> IO ()
forall a b. (a -> b) -> a -> b
$
				Desc -> Desc
takeDirectory Desc
privDataLocal
			IO () -> Propellor ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Propellor ()) -> IO () -> Propellor ()
forall a b. (a -> b) -> a -> b
$ Desc -> Desc -> IO ()
writeFileProtected Desc
privDataLocal (Desc -> IO ()) -> Desc -> IO ()
forall a b. (a -> b) -> a -> b
$
				PrivMap -> Desc
forall a. Show a => a -> Desc
show PrivMap
privdata
			Desc -> Propellor Bool
runShellCommand (Desc -> Propellor Bool) -> Desc -> Propellor Bool
forall a b. (a -> b) -> a -> b
$ [Desc] -> Desc
buildShellCommand
				[ Desc
"cd " Desc -> Desc -> Desc
forall a. [a] -> [a] -> [a]
++ Desc
localdir
				, Bootstrapper -> Maybe System -> Desc
checkDepsCommand Bootstrapper
bootstrapper Maybe System
system
				, Bootstrapper -> Desc
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 Property Linux
-> Property Linux -> CombinedType (Property Linux) (Property Linux)
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 = Desc -> Propellor Result -> Property Linux
forall k (metatypes :: k).
SingI metatypes =>
Desc -> Propellor Result -> Property (MetaTypes metatypes)
property (Desc
"Propellor repo cloned from " Desc -> Desc -> Desc
forall a. [a] -> [a] -> [a]
++ Desc
sourcedesc) (Propellor Result -> Property Linux)
-> Propellor Result -> Property Linux
forall a b. (a -> b) -> a -> b
$
		Propellor Bool
-> (Propellor Result, Propellor Result) -> Propellor Result
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 :: Desc
tmpclone = Desc
localdir Desc -> Desc -> Desc
forall a. [a] -> [a] -> [a]
++ Desc
".tmpclone"
		Maybe System
system <- Propellor (Maybe System)
getOS
		Propellor Bool -> Propellor Result
assumeChange (Propellor Bool -> Propellor Result)
-> Propellor Bool -> Propellor Result
forall a b. (a -> b) -> a -> b
$ (Desc -> Propellor Bool) -> Propellor Bool
forall a. (Desc -> Propellor a) -> Propellor a
exposeTrueLocaldir ((Desc -> Propellor Bool) -> Propellor Bool)
-> (Desc -> Propellor Bool) -> Propellor Bool
forall a b. (a -> b) -> a -> b
$ \Desc
sysdir -> do
			let originloc :: Desc
originloc = case RepoSource
reposource of
				GitRepoUrl Desc
s -> Desc
s
				RepoSource
GitRepoOutsideChroot -> Desc
sysdir
			Desc -> Propellor Bool
runShellCommand (Desc -> Propellor Bool) -> Desc -> Propellor Bool
forall a b. (a -> b) -> a -> b
$ [Desc] -> Desc
buildShellCommand
				[ Maybe System -> Desc
installGitCommand Maybe System
system
				, Desc
"rm -rf " Desc -> Desc -> Desc
forall a. [a] -> [a] -> [a]
++ Desc
tmpclone
				, Desc
"git clone " Desc -> Desc -> Desc
forall a. [a] -> [a] -> [a]
++ Desc -> Desc
shellEscape Desc
originloc Desc -> Desc -> Desc
forall a. [a] -> [a] -> [a]
++ Desc
" " Desc -> Desc -> Desc
forall a. [a] -> [a] -> [a]
++ Desc
tmpclone
				, Desc
"mkdir -p " Desc -> Desc -> Desc
forall a. [a] -> [a] -> [a]
++ Desc
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.
				, Desc
"(cd " Desc -> Desc -> Desc
forall a. [a] -> [a] -> [a]
++ Desc
tmpclone Desc -> Desc -> Desc
forall a. [a] -> [a] -> [a]
++ Desc
" && tar c .) | (cd " Desc -> Desc -> Desc
forall a. [a] -> [a] -> [a]
++ Desc
localdir Desc -> Desc -> Desc
forall a. [a] -> [a] -> [a]
++ Desc
" && tar x)"
				, Desc
"rm -rf " Desc -> Desc -> Desc
forall a. [a] -> [a] -> [a]
++ Desc
tmpclone
				]
	
	updateclone :: Propellor Result
updateclone = Propellor Bool -> Propellor Result
assumeChange (Propellor Bool -> Propellor Result)
-> Propellor Bool -> Propellor Result
forall a b. (a -> b) -> a -> b
$ (Desc -> Propellor Bool) -> Propellor Bool
forall a. (Desc -> Propellor a) -> Propellor a
exposeTrueLocaldir ((Desc -> Propellor Bool) -> Propellor Bool)
-> (Desc -> Propellor Bool) -> Propellor Bool
forall a b. (a -> b) -> a -> b
$ Propellor Bool -> Desc -> Propellor Bool
forall a b. a -> b -> a
const (Propellor Bool -> Desc -> Propellor Bool)
-> Propellor Bool -> Desc -> Propellor Bool
forall a b. (a -> b) -> a -> b
$
		Desc -> Propellor Bool
runShellCommand (Desc -> Propellor Bool) -> Desc -> Propellor Bool
forall a b. (a -> b) -> a -> b
$ [Desc] -> Desc
buildShellCommand
			[ Desc
"cd " Desc -> Desc -> Desc
forall a. [a] -> [a] -> [a]
++ Desc
localdir
			, Desc
"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 = Desc -> Propellor Result -> Property Linux
forall k (metatypes :: k).
SingI metatypes =>
Desc -> Propellor Result -> Property (MetaTypes metatypes)
property (Desc
"Propellor repo git config copied from outside the chroot") (Propellor Result -> Property Linux)
-> Propellor Result -> Property Linux
forall a b. (a -> b) -> a -> b
$ do
		let gitconfig :: Desc
gitconfig = Desc
localdir Desc -> Desc -> Desc
</> Desc
".git" Desc -> Desc -> Desc
</> Desc
"config"
		ByteString
cfg <- IO ByteString -> Propellor ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> Propellor ByteString)
-> IO ByteString -> Propellor ByteString
forall a b. (a -> b) -> a -> b
$ Desc -> IO ByteString
B.readFile Desc
gitconfig
		(Desc -> Propellor ()) -> Propellor ()
forall a. (Desc -> Propellor a) -> Propellor a
exposeTrueLocaldir ((Desc -> Propellor ()) -> Propellor ())
-> (Desc -> Propellor ()) -> Propellor ()
forall a b. (a -> b) -> a -> b
$ Propellor () -> Desc -> Propellor ()
forall a b. a -> b -> a
const (Propellor () -> Desc -> Propellor ())
-> Propellor () -> Desc -> Propellor ()
forall a b. (a -> b) -> a -> b
$
			IO () -> Propellor ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Propellor ()) -> IO () -> Propellor ()
forall a b. (a -> b) -> a -> b
$ Desc -> ByteString -> IO ()
B.writeFile Desc
gitconfig ByteString
cfg
		Result -> Propellor Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
MadeChange

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

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

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

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

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