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 = [Char] -> InfoVal Bootstrapper -> Property (HasInfo + UnixLike)
forall v. IsInfo v => [Char] -> v -> Property (HasInfo + UnixLike)
pureInfoProperty [Char]
desc (Bootstrapper -> InfoVal Bootstrapper
forall v. v -> InfoVal v
InfoVal Bootstrapper
b)
where
desc :: [Char]
desc = [Char]
"propellor bootstrapped with " [Char] -> [Char] -> [Char]
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 = 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 = [Char] -> Propellor Result -> Property Linux
forall {k} (metatypes :: k).
SingI metatypes =>
[Char] -> Propellor Result -> Property (MetaTypes metatypes)
property [Char]
"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
Host
chroothost <- Propellor Host
forall r (m :: * -> *). MonadReader r m => m r
ask
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
<$> [Char] -> IO PrivMap
readPrivDataFile [Char]
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
$ ([Char] -> Propellor Bool) -> Propellor Bool
forall a. ([Char] -> Propellor a) -> Propellor a
exposeTrueLocaldir (([Char] -> Propellor Bool) -> Propellor Bool)
-> ([Char] -> Propellor Bool) -> Propellor Bool
forall a b. (a -> b) -> a -> b
$ Propellor Bool -> [Char] -> Propellor Bool
forall a b. a -> b -> a
const (Propellor Bool -> [Char] -> Propellor Bool)
-> Propellor Bool -> [Char] -> 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 -> [Char] -> IO ()
createDirectoryIfMissing Bool
True ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
[Char] -> [Char]
takeDirectory [Char]
privDataLocal
IO () -> Propellor ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Propellor ()) -> IO () -> Propellor ()
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
writeFileProtected [Char]
privDataLocal ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
PrivMap -> [Char]
forall a. Show a => a -> [Char]
show PrivMap
privdata
[Char] -> Propellor Bool
runShellCommand ([Char] -> Propellor Bool) -> [Char] -> Propellor Bool
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
buildShellCommand
[ [Char]
"cd " [Char] -> [Char] -> [Char]
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 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 = [Char] -> Propellor Result -> Property Linux
forall {k} (metatypes :: k).
SingI metatypes =>
[Char] -> Propellor Result -> Property (MetaTypes metatypes)
property ([Char]
"Propellor repo cloned from " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
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 :: [Char]
tmpclone = [Char]
localdir [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
".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
$ ([Char] -> Propellor Bool) -> Propellor Bool
forall a. ([Char] -> Propellor a) -> Propellor a
exposeTrueLocaldir (([Char] -> Propellor Bool) -> Propellor Bool)
-> ([Char] -> Propellor Bool) -> Propellor Bool
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 ([Char] -> Propellor Bool) -> [Char] -> Propellor Bool
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
buildShellCommand
[ Maybe System -> [Char]
installGitCommand Maybe System
system
, [Char]
"rm -rf " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
tmpclone
, [Char]
"git clone " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
shellEscape [Char]
originloc [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
tmpclone
, [Char]
"mkdir -p " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
localdir
, [Char]
"(cd " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
tmpclone [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" && tar c .) | (cd " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
localdir [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" && tar x)"
, [Char]
"rm -rf " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
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
$ ([Char] -> Propellor Bool) -> Propellor Bool
forall a. ([Char] -> Propellor a) -> Propellor a
exposeTrueLocaldir (([Char] -> Propellor Bool) -> Propellor Bool)
-> ([Char] -> Propellor Bool) -> Propellor Bool
forall a b. (a -> b) -> a -> b
$ Propellor Bool -> [Char] -> Propellor Bool
forall a b. a -> b -> a
const (Propellor Bool -> [Char] -> Propellor Bool)
-> Propellor Bool -> [Char] -> Propellor Bool
forall a b. (a -> b) -> a -> b
$
[Char] -> Propellor Bool
runShellCommand ([Char] -> Propellor Bool) -> [Char] -> Propellor Bool
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
buildShellCommand
[ [Char]
"cd " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
localdir
, [Char]
"git pull"
]
copygitconfig :: Property Linux
copygitconfig :: Property Linux
copygitconfig = [Char] -> Propellor Result -> Property Linux
forall {k} (metatypes :: k).
SingI metatypes =>
[Char] -> Propellor Result -> Property (MetaTypes metatypes)
property ([Char]
"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 :: [Char]
gitconfig = [Char]
localdir [Char] -> [Char] -> [Char]
</> [Char]
".git" [Char] -> [Char] -> [Char]
</> [Char]
"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
$ [Char] -> IO ByteString
B.readFile [Char]
gitconfig
([Char] -> Propellor ()) -> Propellor ()
forall a. ([Char] -> Propellor a) -> Propellor a
exposeTrueLocaldir (([Char] -> Propellor ()) -> Propellor ())
-> ([Char] -> Propellor ()) -> Propellor ()
forall a b. (a -> b) -> a -> b
$ Propellor () -> [Char] -> Propellor ()
forall a b. a -> b -> a
const (Propellor () -> [Char] -> Propellor ())
-> Propellor () -> [Char] -> 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
$ [Char] -> ByteString -> IO ()
B.writeFile [Char]
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
<$> [Char] -> IO Bool
doesDirectoryExist [Char]
localdir))
truelocaldirisempty :: Propellor Bool
truelocaldirisempty = ([Char] -> Propellor Bool) -> Propellor Bool
forall a. ([Char] -> Propellor a) -> Propellor a
exposeTrueLocaldir (([Char] -> Propellor Bool) -> Propellor Bool)
-> ([Char] -> Propellor Bool) -> Propellor Bool
forall a b. (a -> b) -> a -> b
$ Propellor Bool -> [Char] -> Propellor Bool
forall a b. a -> b -> a
const (Propellor Bool -> [Char] -> Propellor Bool)
-> Propellor Bool -> [Char] -> Propellor Bool
forall a b. (a -> b) -> a -> b
$
[Char] -> Propellor Bool
runShellCommand ([Char]
"test ! -d " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
localdir [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"/.git")
sourcedesc :: [Char]
sourcedesc = case RepoSource
reposource of
GitRepoUrl [Char]
s -> [Char]
s
RepoSource
GitRepoOutsideChroot -> [Char]
localdir [Char] -> [Char] -> [Char]
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
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 :: [[Char]] -> [Char]
buildShellCommand = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"&&" ([[Char]] -> [Char])
-> ([[Char]] -> [[Char]]) -> [[Char]] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (\[Char]
c -> [Char]
"(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
c [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")")
runShellCommand :: String -> Propellor Bool
runShellCommand :: [Char] -> Propellor Bool
runShellCommand [Char]
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
$ [Char] -> [CommandParam] -> IO Bool
boolSystem [Char]
"sh" [ [Char] -> CommandParam
Param [Char]
"-c", [Char] -> CommandParam
Param [Char]
s]