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 b :: 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 = "propellor bootstrapped with " Desc -> Desc -> Desc
forall a. [a] -> [a] -> [a]
++ case Bootstrapper
b of
Robustly Stack -> "stack"
Robustly Cabal -> "cabal"
OSOnly -> "OS packages only"
data RepoSource
= GitRepoUrl String
| GitRepoOutsideChroot
bootstrappedFrom :: RepoSource -> Property Linux
bootstrappedFrom :: RepoSource -> Property Linux
bootstrappedFrom reposource :: 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 "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
<$> 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
[ "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
]
clonedFrom :: RepoSource -> Property Linux
clonedFrom :: RepoSource -> Property Linux
clonedFrom reposource :: RepoSource
reposource = case RepoSource
reposource of
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
_ -> 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 ("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]
++ ".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
$ \sysdir :: Desc
sysdir -> do
let originloc :: Desc
originloc = case RepoSource
reposource of
GitRepoUrl s :: Desc
s -> Desc
s
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
, "rm -rf " Desc -> Desc -> Desc
forall a. [a] -> [a] -> [a]
++ Desc
tmpclone
, "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
forall a. [a] -> [a] -> [a]
++ Desc
tmpclone
, "mkdir -p " Desc -> Desc -> Desc
forall a. [a] -> [a] -> [a]
++ Desc
localdir
, "(cd " Desc -> Desc -> Desc
forall a. [a] -> [a] -> [a]
++ Desc
tmpclone Desc -> Desc -> Desc
forall a. [a] -> [a] -> [a]
++ " && tar c .) | (cd " Desc -> Desc -> Desc
forall a. [a] -> [a] -> [a]
++ Desc
localdir Desc -> Desc -> Desc
forall a. [a] -> [a] -> [a]
++ " && tar x)"
, "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
[ "cd " Desc -> Desc -> Desc
forall a. [a] -> [a] -> [a]
++ Desc
localdir
, "git pull"
]
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 ("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
</> ".git" 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 ("test ! -d " Desc -> Desc -> Desc
forall a. [a] -> [a] -> [a]
++ Desc
localdir Desc -> Desc -> Desc
forall a. [a] -> [a] -> [a]
++ "/.git")
sourcedesc :: Desc
sourcedesc = case RepoSource
reposource of
GitRepoUrl s :: Desc
s -> Desc
s
GitRepoOutsideChroot -> Desc
localdir Desc -> Desc -> Desc
forall a. [a] -> [a] -> [a]
++ " outside the chroot"
assumeChange :: Propellor Bool -> Propellor Result
assumeChange :: Propellor Bool -> Propellor Result
assumeChange a :: 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
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Desc -> Desc) -> [Desc] -> [Desc]
forall a b. (a -> b) -> [a] -> [b]
map (\c :: Desc
c -> "(" Desc -> Desc -> Desc
forall a. [a] -> [a] -> [a]
++ Desc
c Desc -> Desc -> Desc
forall a. [a] -> [a] -> [a]
++ ")")
runShellCommand :: String -> Propellor Bool
runShellCommand :: Desc -> Propellor Bool
runShellCommand s :: 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 "sh" [ Desc -> CommandParam
Param "-c", Desc -> CommandParam
Param Desc
s]