{-| Implementation of an execution environment that uses "libvirt-lxc". -}
module B9.LibVirtLXC
( runInEnvironment
, supportedImageTypes
, logLibVirtLXCConfig
, module X
) where
import B9.B9Config (getB9Config, libVirtLXCConfigs)
import B9.B9Config.LibVirtLXC as X
import B9.B9Exec
import B9.B9Logging
import B9.BuildInfo
import B9.DiskImages
import B9.ExecEnv
import B9.ShellScript
import Control.Eff
import Control.Lens (view)
import Control.Monad.IO.Class (liftIO)
import Data.Char (toLower)
import System.Directory
import System.FilePath
import System.IO.B9Extras (UUID(), randomUUID)
import Text.Printf (printf)
logLibVirtLXCConfig :: CommandIO e => LibVirtLXCConfig -> Eff e ()
logLibVirtLXCConfig c = traceL $ printf "USING LibVirtLXCConfig: %s" (show c)
supportedImageTypes :: [ImageType]
supportedImageTypes = [Raw]
runInEnvironment ::
forall e. (Member BuildInfoReader e, CommandIO e)
=> ExecEnv
-> Script
-> Eff e Bool
runInEnvironment env scriptIn =
if emptyScript scriptIn
then return True
else setUp >>= execute
where
setUp = do
mcfg <- view libVirtLXCConfigs <$> getB9Config
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 -> Eff e Bool
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