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
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"
data RepoSource
= GitRepoUrl String
| GitRepoOutsideChroot
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
Host
chroothost <- forall r (m :: * -> *). MonadReader r m => m r
ask
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
]
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
, [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"
]
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]