module B9.VmBuilder
( buildWithVm
)
where
import Control.Eff
import Control.Monad
import Control.Monad.IO.Class
import Data.List
import System.Directory ( canonicalizePath
, createDirectoryIfMissing
)
import Text.Printf ( printf )
import Text.Show.Pretty ( ppShow )
import B9.Artifact.Readable
import B9.B9Config
import B9.B9Logging
import B9.B9Monad
import B9.BuildInfo
import B9.DiskImageBuilder
import B9.DiskImages
import B9.ExecEnv
import qualified B9.LibVirtLXC as LXC
import B9.ShellScript
import B9.Vm
buildWithVm
:: IsB9 e => InstanceId -> [ImageTarget] -> FilePath -> VmScript -> Eff e Bool
buildWithVm iid imageTargets instanceDir vmScript = do
vmBuildSupportedImageTypes <- getVmScriptSupportedImageTypes vmScript
buildImages <- createBuildImages imageTargets vmBuildSupportedImageTypes
success <- runVmScript iid imageTargets buildImages instanceDir vmScript
when success (createDestinationImages buildImages imageTargets)
return success
getVmScriptSupportedImageTypes :: IsB9 e => VmScript -> Eff e [ImageType]
getVmScriptSupportedImageTypes NoVmScript = return [QCow2, Raw, Vmdk]
getVmScriptSupportedImageTypes _ = supportedImageTypes <$> getExecEnvType
supportedImageTypes :: ExecEnvType -> [ImageType]
supportedImageTypes LibVirtLXC = LXC.supportedImageTypes
createBuildImages :: IsB9 e => [ImageTarget] -> [ImageType] -> Eff e [Image]
createBuildImages imageTargets vmBuildSupportedImageTypes = do
dbgL "creating build images"
traceL (ppShow imageTargets)
buildImages <- mapM createBuildImage imageTargets
infoL "CREATED BUILD IMAGES"
traceL (ppShow buildImages)
return buildImages
where
createBuildImage (ImageTarget dest imageSource _mnt) = do
buildDir <- getBuildDir
destTypes <- preferredDestImageTypes imageSource
let buildImgType = head
( destTypes
`intersect` preferredSourceImageTypes dest
`intersect` vmBuildSupportedImageTypes
)
srcImg <- resolveImageSource imageSource
let buildImg =
changeImageFormat buildImgType (changeImageDirectory buildDir srcImg)
buildImgAbsolutePath <- ensureAbsoluteImageDirExists buildImg
materializeImageSource imageSource buildImg
return buildImgAbsolutePath
runVmScript
:: forall e
. IsB9 e
=> InstanceId
-> [ImageTarget]
-> [Image]
-> FilePath
-> VmScript
-> Eff e Bool
runVmScript _ _ _ _ NoVmScript = return True
runVmScript (IID iid) imageTargets buildImages instanceDir vmScript = do
dbgL (printf "starting vm script with instanceDir '%s'" instanceDir)
traceL (ppShow vmScript)
execEnv <- setUpExecEnv
let (VmScript _ _ script) = vmScript
success <- runInEnvironment execEnv script
if success
then infoL "EXECUTED BUILD SCRIPT"
else errorL "BUILD SCRIPT FAILED"
return success
where
setUpExecEnv :: IsB9 e => Eff e ExecEnv
setUpExecEnv = do
let (VmScript cpu shares _) = vmScript
let mountedImages = buildImages `zip` (itImageMountPoint <$> imageTargets)
sharesAbs <- createSharedDirs instanceDir shares
return
(ExecEnv iid mountedImages sharesAbs (Resources AutomaticRamSize 8 cpu))
createSharedDirs
:: IsB9 e => FilePath -> [SharedDirectory] -> Eff e [SharedDirectory]
createSharedDirs instanceDir = mapM createSharedDir
where
createSharedDir (SharedDirectoryRO d m) = do
d' <- createAndCanonicalize d
return $ SharedDirectoryRO d' m
createSharedDir (SharedDirectory d m) = do
d' <- createAndCanonicalize d
return $ SharedDirectory d' m
createSharedDir (SharedSources mp) = do
d' <- createAndCanonicalize instanceDir
return $ SharedDirectoryRO d' mp
createAndCanonicalize d = liftIO $ do
createDirectoryIfMissing True d
canonicalizePath d
createDestinationImages :: IsB9 e => [Image] -> [ImageTarget] -> Eff e ()
createDestinationImages buildImages imageTargets = do
dbgL "converting build- to output images"
let pairsToConvert =
buildImages `zip` (itImageDestination `map` imageTargets)
traceL (ppShow pairsToConvert)
mapM_ (uncurry createDestinationImage) pairsToConvert
infoL "CONVERTED BUILD- TO OUTPUT IMAGES"
runInEnvironment :: IsB9 e => ExecEnv -> Script -> Eff e Bool
runInEnvironment env script = do
t <- getExecEnvType
case t of
LibVirtLXC -> LXC.runInEnvironment env script