{-| Implementation of an execution environment that uses "libvirt-lxc". -}
module B9.LibVirtLXC ( runInEnvironment
, supportedImageTypes
, logLibVirtLXCConfig
, module X
) where
import Control.Monad.IO.Class ( liftIO )
import System.Directory
import System.FilePath
import Text.Printf ( printf )
import Data.Char (toLower)
import Control.Lens (view)
import B9.ShellScript
import B9.B9Monad
import B9.B9Config (libVirtLXCConfigs)
import B9.DiskImages
import B9.ExecEnv
import B9.B9Config.LibVirtLXC as X
import Data.ConfigFile.B9Extras
logLibVirtLXCConfig :: LibVirtLXCConfig -> B9 ()
logLibVirtLXCConfig c = traceL $ printf "USING LibVirtLXCConfig: %s" (show c)
supportedImageTypes :: [ImageType]
supportedImageTypes = [Raw]
runInEnvironment :: ExecEnv -> Script -> B9 Bool
runInEnvironment env scriptIn = if emptyScript scriptIn
then return True
else setUp >>= execute
where
setUp = do
mcfg <- view libVirtLXCConfigs <$> getConfig
cfg <- maybe (fail "No LibVirtLXC Configuration!") return mcfg
buildId <- getBuildId
buildBaseDir <- getBuildDir
uuid <- randomUUID
let
scriptDirHost = buildDir > "init-script"
scriptDirGuest = "/" ++ buildId
domainFile = buildBaseDir > uuid' <.> domainConfig
domain = createDomain cfg env buildId uuid' scriptDirHost scriptDirGuest
uuid' = printf "%U" uuid
setupEnv = Begin
[ Run "export" ["HOME=/root"]
, Run "export" ["USER=root"]
, Run "source" ["/etc/profile"]
]
script = Begin [setupEnv, scriptIn, successMarkerCmd scriptDirGuest]
buildDir = buildBaseDir > uuid'
liftIO $ do
createDirectoryIfMissing True scriptDirHost
writeSh (scriptDirHost > initScript) script
writeFile domainFile domain
return $ Context scriptDirHost uuid domainFile cfg
successMarkerCmd scriptDirGuest =
In scriptDirGuest [Run "touch" [successMarkerFile]]
execute (Context scriptDirHost _uuid domainFile cfg) = do
let virsh = virshCommand cfg
cmd $ printf "%s create '%s' --console --autodestroy" virsh domainFile
-- cmd $ printf "%s console %U" virsh uuid
liftIO (doesFileExist $ scriptDirHost > successMarkerFile)
successMarkerFile = "SUCCESS"
virshCommand :: LibVirtLXCConfig -> String
virshCommand cfg = printf "%s%s -c %s" useSudo' virshPath' virshURI'
where
useSudo' = if useSudo cfg then "sudo " else ""
virshPath' = virshPath cfg
virshURI' = virshURI cfg
data Context = Context FilePath UUID FilePath LibVirtLXCConfig
initScript :: String
initScript = "init.sh"
domainConfig :: String
domainConfig = "domain.xml"
createDomain
:: LibVirtLXCConfig
-> ExecEnv
-> String
-> String
-> FilePath
-> FilePath
-> String
createDomain cfg e buildId uuid scriptDirHost scriptDirGuest =
"\n "
++ buildId
++ "\n "
++ uuid
++ "\n "
++ memoryAmount cfg e
++ "\n "
++ memoryAmount cfg e
++ "\n "
++ cpuCountStr e
++ "\n \n \n "
++ renderGuestCapabilityEntries cfg
++ "\n \n \n \n exe\n "
++ scriptDirGuest
> initScript
++ "\n \n \n destroy\n restart\n destroy\n \n "
++ emulator cfg
++ "\n"
++ unlines
( libVirtNetwork (networkId cfg)
++ (fsImage <$> envImageMounts e)
++ (fsSharedDir <$> envSharedDirectories e)
)
++ "\n"
++ " \n \n \n \n \n \n \n \n\n"
renderGuestCapabilityEntries :: LibVirtLXCConfig -> String
renderGuestCapabilityEntries = unlines . map render . guestCapabilities
where
render :: LXCGuestCapability -> String
render cap =
let capStr = toLower <$> drop (length "CAP_") (show cap)
in printf "<%s state='on'/>" capStr
osArch :: ExecEnv -> String
osArch e = case cpuArch (envResources e) of
X86_64 -> "x86_64"
I386 -> "i686"
libVirtNetwork :: Maybe String -> [String]
libVirtNetwork Nothing = []
libVirtNetwork (Just n) =
[ ""
, " "
, ""
]
fsImage :: (Image, MountPoint) -> String
fsImage (img, mnt) = case fsTarget mnt of
Just mntXml ->
"\n "
++ fsImgDriver img
++ "\n "
++ fsImgSource img
++ "\n "
++ mntXml
++ "\n"
Nothing -> ""
where
fsImgDriver (Image _img fmt _fs) = printf "" driver fmt'
where
(driver, fmt') = case fmt of
Raw -> ("type='loop'", "format='raw'")
QCow2 -> ("type='nbd'", "format='qcow2'")
Vmdk -> ("type='nbd'", "format='vmdk'")
fsImgSource (Image src _fmt _fs) = ""
fsSharedDir :: SharedDirectory -> String
fsSharedDir (SharedDirectory hostDir mnt) = case fsTarget mnt of
Just mntXml ->
"\n "
++ ""
++ "\n "
++ mntXml
++ "\n"
Nothing -> ""
fsSharedDir (SharedDirectoryRO hostDir mnt) = case fsTarget mnt of
Just mntXml ->
"\n "
++ ""
++ "\n "
++ mntXml
++ "\n \n"
Nothing -> ""
fsSharedDir (SharedSources _) = error "Unreachable code reached!"
fsTarget :: MountPoint -> Maybe String
fsTarget (MountPoint dir) = Just $ ""
fsTarget _ = Nothing
memoryUnit :: LibVirtLXCConfig -> ExecEnv -> String
memoryUnit cfg = toUnit . maxMemory . envResources
where
toUnit AutomaticRamSize = toUnit (guestRamSize cfg)
toUnit (RamSize _ u) = case u of
GB -> "GiB"
MB -> "MiB"
KB -> "KiB"
B -> "B"
memoryAmount :: LibVirtLXCConfig -> ExecEnv -> String
memoryAmount cfg = show . toAmount . maxMemory . envResources
where
toAmount AutomaticRamSize = toAmount (guestRamSize cfg)
toAmount (RamSize n _) = n
cpuCountStr :: ExecEnv -> String
cpuCountStr = show . cpuCount . envResources