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
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 =
"<domain type='lxc'>\n <name>" ++
buildId ++
"</name>\n <uuid>" ++
uuid ++
"</uuid>\n <memory unit='" ++
memoryUnit cfg e ++
"'>" ++
memoryAmount cfg e ++
"</memory>\n <currentMemory unit='" ++
memoryUnit cfg e ++
"'>" ++
memoryAmount cfg e ++
"</currentMemory>\n <vcpu placement='static'>" ++
cpuCountStr e ++
"</vcpu>\n <features>\n <capabilities policy='default'>\n " ++
renderGuestCapabilityEntries cfg ++
"\n </capabilities>\n </features>\n <os>\n <type arch='" ++
osArch e ++
"'>exe</type>\n <init>" ++
scriptDirGuest </> initScript ++
"</init>\n </os>\n <clock offset='utc'/>\n <on_poweroff>destroy</on_poweroff>\n <on_reboot>restart</on_reboot>\n <on_crash>destroy</on_crash>\n <devices>\n <emulator>" ++
emulator cfg ++
"</emulator>\n" ++
unlines
(libVirtNetwork (_networkId cfg) ++ (fsImage <$> envImageMounts e) ++ (fsSharedDir <$> envSharedDirectories e)) ++
"\n" ++
" <filesystem type='mount'>\n <source dir='" ++
scriptDirHost ++
"'/>\n <target dir='" ++
scriptDirGuest ++
"'/>\n </filesystem>\n <console>\n <target type='lxc' port='0'/>\n </console>\n </devices>\n</domain>\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) = ["<interface type='network'>", " <source network='" ++ n ++ "'/>", "</interface>"]
fsImage :: (Image, MountPoint) -> String
fsImage (img, mnt) =
case fsTarget mnt of
Just mntXml ->
"<filesystem type='file' accessmode='passthrough'>\n " ++
fsImgDriver img ++ "\n " ++ fsImgSource img ++ "\n " ++ mntXml ++ "\n</filesystem>"
Nothing -> ""
where
fsImgDriver (Image _img fmt _fs) = printf "<driver %s %s/>" 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) = "<source file='" ++ src ++ "'/>"
fsSharedDir :: SharedDirectory -> String
fsSharedDir (SharedDirectory hostDir mnt) =
case fsTarget mnt of
Just mntXml ->
"<filesystem type='mount'>\n " ++ "<source dir='" ++ hostDir ++ "'/>" ++ "\n " ++ mntXml ++ "\n</filesystem>"
Nothing -> ""
fsSharedDir (SharedDirectoryRO hostDir mnt) =
case fsTarget mnt of
Just mntXml ->
"<filesystem type='mount'>\n " ++
"<source dir='" ++ hostDir ++ "'/>" ++ "\n " ++ mntXml ++ "\n <readonly />\n</filesystem>"
Nothing -> ""
fsSharedDir (SharedSources _) = error "Unreachable code reached!"
fsTarget :: MountPoint -> Maybe String
fsTarget (MountPoint dir) = Just $ "<target dir='" ++ dir ++ "'/>"
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