{-# LANGUAGE InstanceSigs #-}
-- | Implementation of an execution environment that uses "libvirt-lxc".
module B9.LibVirtLXC
  ( LibVirtLXC (..),
    module X,
  )
where

import B9.B9Config
  (getConfig,  B9ConfigReader,
    ContainerCapability,
    getB9Config,
    libVirtLXCConfigs,
    keepTempDirs
  )
import B9.B9Config.LibVirtLXC as X
import B9.B9Error
import B9.B9Exec
import B9.B9Logging
import B9.BuildInfo
import B9.Container
import B9.DiskImages
import B9.ExecEnv
import B9.ShellScript
import Control.Eff
import Control.Lens ((^.), view)
import Control.Monad.IO.Class
  ( MonadIO,
    liftIO,
  )
import Control.Monad.Trans.Control
import Data.Char (toLower)
import System.Directory
import System.FilePath
import System.IO.B9Extras
  ( UUID (),
    randomUUID,
  )
import qualified System.IO.Temp as Temp
import qualified System.Posix.Files as Files
import Text.Printf (printf)

newtype LibVirtLXC = LibVirtLXC LibVirtLXCConfig

instance Backend LibVirtLXC where
  getBackendConfig :: proxy LibVirtLXC -> Eff e (Maybe LibVirtLXC)
getBackendConfig proxy LibVirtLXC
_ =
    (LibVirtLXCConfig -> LibVirtLXC)
-> Maybe LibVirtLXCConfig -> Maybe LibVirtLXC
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LibVirtLXCConfig -> LibVirtLXC
LibVirtLXC (Maybe LibVirtLXCConfig -> Maybe LibVirtLXC)
-> (B9Config -> Maybe LibVirtLXCConfig)
-> B9Config
-> Maybe LibVirtLXC
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (Maybe LibVirtLXCConfig) B9Config (Maybe LibVirtLXCConfig)
-> B9Config -> Maybe LibVirtLXCConfig
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Maybe LibVirtLXCConfig) B9Config (Maybe LibVirtLXCConfig)
Lens' B9Config (Maybe LibVirtLXCConfig)
libVirtLXCConfigs (B9Config -> Maybe LibVirtLXC)
-> Eff e B9Config -> Eff e (Maybe LibVirtLXC)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Eff e B9Config
forall (e :: [* -> *]). Member B9ConfigReader e => Eff e B9Config
getB9Config
  supportedImageTypes :: proxy LibVirtLXC -> [ImageType]
supportedImageTypes proxy LibVirtLXC
_ = [ImageType
Raw]
  runInEnvironment ::
    forall e.
    (Member BuildInfoReader e, CommandIO e, Member ExcB9 e) =>
    LibVirtLXC ->
    ExecEnv ->
    Script ->
    Eff e Bool
  runInEnvironment :: LibVirtLXC -> ExecEnv -> Script -> Eff e Bool
runInEnvironment (LibVirtLXC LibVirtLXCConfig
cfgIn) ExecEnv
env Script
scriptIn = do
    ((ExecEnv -> IO ExecEnv) -> IO (StM (Eff e) Bool))
-> IO (StM (Eff e) Bool)
imageFileNamesShortenerMechanism <- Maybe FilePath
-> Eff
     e
     (((ExecEnv -> IO ExecEnv) -> IO (StM (Eff e) Bool))
      -> IO (StM (Eff e) Bool))
forall (e :: [* -> *]) a.
Member B9ConfigReader e =>
Maybe FilePath -> Eff e (((ExecEnv -> IO ExecEnv) -> IO a) -> IO a)
getImageFileNamesShortenerMechanism (LibVirtLXCConfig -> Maybe FilePath
imageFileNameShortenerBasePath LibVirtLXCConfig
cfgIn)
    (RunInBase (Eff e) IO -> IO (StM (Eff e) Bool)) -> Eff e Bool
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(RunInBase m b -> b (StM m a)) -> m a
control ((RunInBase (Eff e) IO -> IO (StM (Eff e) Bool)) -> Eff e Bool)
-> (RunInBase (Eff e) IO -> IO (StM (Eff e) Bool)) -> Eff e Bool
forall a b. (a -> b) -> a -> b
$ \RunInBase (Eff e) IO
runInIO -> do
      ((ExecEnv -> IO ExecEnv) -> IO (StM (Eff e) Bool))
-> IO (StM (Eff e) Bool)
imageFileNamesShortenerMechanism (((ExecEnv -> IO ExecEnv) -> IO (StM (Eff e) Bool))
 -> IO (StM (Eff e) Bool))
-> ((ExecEnv -> IO ExecEnv) -> IO (StM (Eff e) Bool))
-> IO (StM (Eff e) Bool)
forall a b. (a -> b) -> a -> b
$ \ExecEnv -> IO ExecEnv
shortenImageFileNamesInEnvAction ->
        Eff e Bool -> IO (StM (Eff e) Bool)
RunInBase (Eff e) IO
runInIO (if Script -> Bool
emptyScript Script
scriptIn
          then Bool -> Eff e Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
          else (ExecEnv -> IO ExecEnv) -> Eff e Context
setUp ExecEnv -> IO ExecEnv
shortenImageFileNamesInEnvAction Eff e Context -> (Context -> Eff e Bool) -> Eff e Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Context -> Eff e Bool
forall (e :: [* -> *]).
(Member ExcB9 e, CommandIO e, Member BuildInfoReader e,
 Member B9ConfigReader e) =>
Context -> Eff e Bool
execute)
    where
      setUp :: (ExecEnv -> IO ExecEnv) -> Eff e Context
setUp ExecEnv -> IO ExecEnv
shortenImageFileNamesInEnvAction = do
        FilePath
buildId <- Eff e FilePath
forall (e :: [* -> *]). Member BuildInfoReader e => Eff e FilePath
getBuildId
        FilePath
buildBaseDir <- Eff e FilePath
forall (e :: [* -> *]). Member BuildInfoReader e => Eff e FilePath
getBuildDir
        UUID
uuid <- Eff e UUID
forall (m :: * -> *). MonadIO m => m UUID
randomUUID
        let scriptDirHost :: FilePath
scriptDirHost = FilePath
buildDir FilePath -> FilePath -> FilePath
</> FilePath
"init-script"
            scriptDirGuest :: FilePath
scriptDirGuest = FilePath
"/" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
buildId
            domainFile :: FilePath
domainFile = FilePath
buildBaseDir FilePath -> FilePath -> FilePath
</> FilePath
uuid' FilePath -> FilePath -> FilePath
<.> FilePath
domainConfig
            mkDomain :: ExecEnv -> IO FilePath
mkDomain ExecEnv
envToUse =
              LibVirtLXCConfig
-> ExecEnv
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> IO FilePath
forall (m :: * -> *).
MonadIO m =>
LibVirtLXCConfig
-> ExecEnv
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> m FilePath
createDomain LibVirtLXCConfig
cfgIn ExecEnv
envToUse FilePath
buildId FilePath
uuid' FilePath
scriptDirHost FilePath
scriptDirGuest
            uuid' :: FilePath
uuid' = FilePath -> UUID -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"%U" UUID
uuid
            setupEnv :: Script
setupEnv =
              [Script] -> Script
Begin
                [ FilePath -> [FilePath] -> Script
Run FilePath
"export" [FilePath
"HOME=/root"],
                  FilePath -> [FilePath] -> Script
Run FilePath
"export" [FilePath
"USER=root"],
                  FilePath -> [FilePath] -> Script
Run FilePath
"source" [FilePath
"/etc/profile"]
                ]
            script :: Script
script = [Script] -> Script
Begin [Script
setupEnv, Script
scriptIn, FilePath -> Script
successMarkerCmd FilePath
scriptDirGuest]
            buildDir :: FilePath
buildDir = FilePath
buildBaseDir FilePath -> FilePath -> FilePath
</> FilePath
uuid'
        IO () -> Eff e ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Eff e ()) -> IO () -> Eff e ()
forall a b. (a -> b) -> a -> b
$ do
          Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
scriptDirHost
          FilePath -> Script -> IO ()
writeSh (FilePath
scriptDirHost FilePath -> FilePath -> FilePath
</> FilePath
initScript) Script
script
          ExecEnv
envToUse <- ExecEnv -> IO ExecEnv
shortenImageFileNamesInEnvAction ExecEnv
env
          FilePath
domain <- ExecEnv -> IO FilePath
mkDomain ExecEnv
envToUse
          FilePath -> FilePath -> IO ()
writeFile FilePath
domainFile FilePath
domain
        Context -> Eff e Context
forall (m :: * -> *) a. Monad m => a -> m a
return (Context -> Eff e Context) -> Context -> Eff e Context
forall a b. (a -> b) -> a -> b
$ FilePath -> UUID -> FilePath -> LibVirtLXCConfig -> Context
Context FilePath
scriptDirHost UUID
uuid FilePath
domainFile LibVirtLXCConfig
cfgIn

imageFileNamesShortenerTemplate :: String
imageFileNamesShortenerTemplate :: FilePath
imageFileNamesShortenerTemplate = FilePath
".t"

shortenImageFileNamesInEnv :: FilePath -> ExecEnv -> IO ExecEnv
shortenImageFileNamesInEnv :: FilePath -> ExecEnv -> IO ExecEnv
shortenImageFileNamesInEnv FilePath
tmpDir ExecEnv
origEnv = do
  let images :: [Mounted Image]
images = ExecEnv -> [Mounted Image]
envImageMounts ExecEnv
origEnv
  [Mounted Image]
newImages <- ((Integer, Mounted Image) -> IO (Mounted Image))
-> [(Integer, Mounted Image)] -> IO [Mounted Image]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Integer, Mounted Image) -> IO (Mounted Image)
shortenImageFileName ([Integer] -> [Mounted Image] -> [(Integer, Mounted Image)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
0..] [Mounted Image]
images)
  ExecEnv -> IO ExecEnv
forall (m :: * -> *) a. Monad m => a -> m a
return ExecEnv
origEnv { envImageMounts :: [Mounted Image]
envImageMounts = [Mounted Image]
newImages }
  where
    shortenImageFileName :: (Integer, Mounted Image) -> IO (Mounted Image)
    shortenImageFileName :: (Integer, Mounted Image) -> IO (Mounted Image)
shortenImageFileName (Integer
num, (Image FilePath
fp ImageType
it FileSystem
fs, MountPoint
mp)) = do
      let newFp :: FilePath
newFp = FilePath
tmpDir FilePath -> FilePath -> FilePath
</> (Integer -> FilePath
forall a. Show a => a -> FilePath
show Integer
num) FilePath -> FilePath -> FilePath
<.> FilePath -> FilePath
takeExtension FilePath
fp
      FilePath -> FilePath -> IO ()
Files.createLink FilePath
fp FilePath
newFp
      Mounted Image -> IO (Mounted Image)
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> ImageType -> FileSystem -> Image
Image FilePath
newFp ImageType
it FileSystem
fs, MountPoint
mp)

getImageFileNamesShortenerMechanism :: Member B9ConfigReader e => Maybe FilePath -> Eff e (((ExecEnv -> IO ExecEnv) -> IO a) -> IO a)
getImageFileNamesShortenerMechanism :: Maybe FilePath -> Eff e (((ExecEnv -> IO ExecEnv) -> IO a) -> IO a)
getImageFileNamesShortenerMechanism Maybe FilePath
maybeShortImageLinkDir = case Maybe FilePath
maybeShortImageLinkDir of
  Maybe FilePath
Nothing -> (((ExecEnv -> IO ExecEnv) -> IO a) -> IO a)
-> Eff e (((ExecEnv -> IO ExecEnv) -> IO a) -> IO a)
forall (m :: * -> *) a. Monad m => a -> m a
return (\(ExecEnv -> IO ExecEnv) -> IO a
action -> (ExecEnv -> IO ExecEnv) -> IO a
action ExecEnv -> IO ExecEnv
forall (m :: * -> *) a. Monad m => a -> m a
return)
  Just FilePath
parent -> do
      B9Config
b9config <- Eff e B9Config
forall (e :: [* -> *]). Member B9ConfigReader e => Eff e B9Config
getConfig
      let tempDirCreator :: FilePath -> (FilePath -> IO a) -> IO a
tempDirCreator = if B9Config
b9config B9Config -> Getting Bool B9Config Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool B9Config Bool
Lens' B9Config Bool
keepTempDirs
                                     then \FilePath
t -> (FilePath -> FilePath -> IO FilePath
Temp.createTempDirectory FilePath
parent FilePath
t IO FilePath -> (FilePath -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=)
                                     else FilePath -> FilePath -> (FilePath -> IO a) -> IO a
forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
FilePath -> FilePath -> (FilePath -> m a) -> m a
Temp.withTempDirectory FilePath
parent
      (((ExecEnv -> IO ExecEnv) -> IO a) -> IO a)
-> Eff e (((ExecEnv -> IO ExecEnv) -> IO a) -> IO a)
forall (m :: * -> *) a. Monad m => a -> m a
return (\(ExecEnv -> IO ExecEnv) -> IO a
action -> FilePath -> (FilePath -> IO a) -> IO a
tempDirCreator FilePath
imageFileNamesShortenerTemplate ((FilePath -> IO a) -> IO a) -> (FilePath -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \FilePath
fp -> (ExecEnv -> IO ExecEnv) -> IO a
action (FilePath -> ExecEnv -> IO ExecEnv
shortenImageFileNamesInEnv FilePath
fp))

successMarkerCmd :: FilePath -> Script
successMarkerCmd :: FilePath -> Script
successMarkerCmd FilePath
scriptDirGuest =
  FilePath -> [Script] -> Script
In FilePath
scriptDirGuest [FilePath -> [FilePath] -> Script
Run FilePath
"touch" [FilePath
successMarkerFile]]

successMarkerFile :: [Char]
successMarkerFile :: FilePath
successMarkerFile = FilePath
"SUCCESS"

execute :: (Member ExcB9 e, CommandIO e, Member BuildInfoReader e, Member B9ConfigReader e) => Context -> Eff e Bool
execute :: Context -> Eff e Bool
execute (Context FilePath
scriptDirHost UUID
_uuid FilePath
domainFile LibVirtLXCConfig
cfg) = do
  let (FilePath
prog, [FilePath]
args) = (FilePath, [FilePath])
virshCommand 
  Maybe Timeout -> FilePath -> [FilePath] -> Eff e ()
forall (e :: [* -> *]).
(HasCallStack, Member ExcB9 e, Member BuildInfoReader e,
 CommandIO e) =>
Maybe Timeout -> FilePath -> [FilePath] -> Eff e ()
ptyCmdInteractive Maybe Timeout
forall a. Maybe a
Nothing FilePath
prog ([FilePath]
args [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath
"create", FilePath
domainFile, FilePath
"--console", FilePath
"--autodestroy"])
  -- cmd $ printf "%s console %U" virsh uuid
  IO Bool -> Eff e Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (FilePath -> IO Bool
doesFileExist (FilePath -> IO Bool) -> FilePath -> IO Bool
forall a b. (a -> b) -> a -> b
$ FilePath
scriptDirHost FilePath -> FilePath -> FilePath
</> FilePath
successMarkerFile)
  where
    virshCommand :: (String, [String])
    virshCommand :: (FilePath, [FilePath])
virshCommand = 
      if LibVirtLXCConfig -> Bool
useSudo LibVirtLXCConfig
cfg then 
        (FilePath
"sudo", [FilePath
"virsh", FilePath
"-c", LibVirtLXCConfig -> FilePath
virshURI LibVirtLXCConfig
cfg])
      else 
        (FilePath
"virsh", [FilePath
"-c", LibVirtLXCConfig -> FilePath
virshURI LibVirtLXCConfig
cfg])

data Context
  = Context
      FilePath
      UUID
      FilePath
      LibVirtLXCConfig

initScript :: String
initScript :: FilePath
initScript = FilePath
"init.sh"

domainConfig :: String
domainConfig :: FilePath
domainConfig = FilePath
"domain.xml"

createDomain ::
  MonadIO m =>
  LibVirtLXCConfig ->
  ExecEnv ->
  String ->
  String ->
  FilePath ->
  FilePath ->
  m String
createDomain :: LibVirtLXCConfig
-> ExecEnv
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> m FilePath
createDomain LibVirtLXCConfig
cfg ExecEnv
e FilePath
buildId FilePath
uuid FilePath
scriptDirHost FilePath
scriptDirGuest = do
  FilePath
emulatorPath <- LibVirtLXCConfig -> m FilePath
forall (m :: * -> *). MonadIO m => LibVirtLXCConfig -> m FilePath
getEmulatorPath LibVirtLXCConfig
cfg
  FilePath -> m FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( FilePath
"<domain type='lxc'>\n  <name>"
        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
buildId
        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"</name>\n  <uuid>"
        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
uuid
        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"</uuid>\n  <memory unit='"
        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ LibVirtLXCConfig -> ExecEnv -> FilePath
memoryUnit LibVirtLXCConfig
cfg ExecEnv
e
        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"'>"
        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ LibVirtLXCConfig -> ExecEnv -> FilePath
memoryAmount LibVirtLXCConfig
cfg ExecEnv
e
        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"</memory>\n  <currentMemory unit='"
        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ LibVirtLXCConfig -> ExecEnv -> FilePath
memoryUnit LibVirtLXCConfig
cfg ExecEnv
e
        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"'>"
        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ LibVirtLXCConfig -> ExecEnv -> FilePath
memoryAmount LibVirtLXCConfig
cfg ExecEnv
e
        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"</currentMemory>\n  <vcpu placement='static'>"
        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ExecEnv -> FilePath
cpuCountStr ExecEnv
e
        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"</vcpu>\n  <features>\n   <capabilities policy='default'>\n     "
        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ LibVirtLXCConfig -> FilePath
renderGuestCapabilityEntries LibVirtLXCConfig
cfg
        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\n   </capabilities>\n  </features>\n  <os>\n    <type arch='"
        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ExecEnv -> FilePath
osArch ExecEnv
e
        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"'>exe</type>\n    <init>"
        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
scriptDirGuest
        FilePath -> FilePath -> FilePath
</> FilePath
initScript
        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"</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>"
        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
emulatorPath
        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"</emulator>\n"
        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
unlines
          ( Maybe FilePath -> [FilePath]
libVirtNetwork (LibVirtLXCConfig -> Maybe FilePath
_networkId LibVirtLXCConfig
cfg)
              [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ (Mounted Image -> FilePath
fsImage (Mounted Image -> FilePath) -> [Mounted Image] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExecEnv -> [Mounted Image]
envImageMounts ExecEnv
e)
              [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ (SharedDirectory -> FilePath
fsSharedDir (SharedDirectory -> FilePath) -> [SharedDirectory] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExecEnv -> [SharedDirectory]
envSharedDirectories ExecEnv
e)
          )
        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\n"
        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"    <filesystem type='mount'>\n      <source dir='"
        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
scriptDirHost
        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"'/>\n      <target dir='"
        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
scriptDirGuest
        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"'/>\n    </filesystem>\n    <console>\n      <target type='lxc' port='0'/>\n    </console>\n  </devices>\n</domain>\n"
    )

renderGuestCapabilityEntries :: LibVirtLXCConfig -> String
renderGuestCapabilityEntries :: LibVirtLXCConfig -> FilePath
renderGuestCapabilityEntries = [FilePath] -> FilePath
unlines ([FilePath] -> FilePath)
-> (LibVirtLXCConfig -> [FilePath]) -> LibVirtLXCConfig -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ContainerCapability -> FilePath)
-> [ContainerCapability] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map ContainerCapability -> FilePath
render ([ContainerCapability] -> [FilePath])
-> (LibVirtLXCConfig -> [ContainerCapability])
-> LibVirtLXCConfig
-> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LibVirtLXCConfig -> [ContainerCapability]
guestCapabilities
  where
    render :: ContainerCapability -> String
    render :: ContainerCapability -> FilePath
render ContainerCapability
cap =
      let capStr :: FilePath
capStr = Char -> Char
toLower (Char -> Char) -> FilePath -> FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
drop (FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
"CAP_") (ContainerCapability -> FilePath
forall a. Show a => a -> FilePath
show ContainerCapability
cap)
       in FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"<%s state='on'/>" FilePath
capStr

osArch :: ExecEnv -> String
osArch :: ExecEnv -> FilePath
osArch ExecEnv
e = case Resources -> CPUArch
cpuArch (ExecEnv -> Resources
envResources ExecEnv
e) of
  CPUArch
X86_64 -> FilePath
"x86_64"
  CPUArch
I386 -> FilePath
"i686"

libVirtNetwork :: Maybe String -> [String]
libVirtNetwork :: Maybe FilePath -> [FilePath]
libVirtNetwork Maybe FilePath
Nothing = []
libVirtNetwork (Just FilePath
n) =
  [ FilePath
"<interface type='network'>",
    FilePath
"  <source network='" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
n FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"'/>",
    FilePath
"</interface>"
  ]

fsImage :: (Image, MountPoint) -> String
fsImage :: Mounted Image -> FilePath
fsImage (Image
img, MountPoint
mnt) = case MountPoint -> Maybe FilePath
fsTarget MountPoint
mnt of
  Just FilePath
mntXml ->
    FilePath
"<filesystem type='file' accessmode='passthrough'>\n  "
      FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Image -> FilePath
forall t. PrintfType t => Image -> t
fsImgDriver Image
img
      FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\n  "
      FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Image -> FilePath
fsImgSource Image
img
      FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\n  "
      FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
mntXml
      FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\n</filesystem>"
  Maybe FilePath
Nothing -> FilePath
""
  where
    fsImgDriver :: Image -> t
fsImgDriver (Image FilePath
_img ImageType
fmt FileSystem
_fs) = FilePath -> FilePath -> FilePath -> t
forall r. PrintfType r => FilePath -> r
printf FilePath
"<driver %s %s/>" FilePath
driver FilePath
fmt'
      where
        (FilePath
driver, FilePath
fmt') = case ImageType
fmt of
          ImageType
Raw -> (FilePath
"type='loop'", FilePath
"format='raw'")
          ImageType
QCow2 -> (FilePath
"type='nbd'", FilePath
"format='qcow2'")
          ImageType
Vmdk -> (FilePath
"type='nbd'", FilePath
"format='vmdk'")
    fsImgSource :: Image -> FilePath
fsImgSource (Image FilePath
src ImageType
_fmt FileSystem
_fs) = FilePath
"<source file='" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
src FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"'/>"

fsSharedDir :: SharedDirectory -> String
fsSharedDir :: SharedDirectory -> FilePath
fsSharedDir (SharedDirectory FilePath
hostDir MountPoint
mnt) = case MountPoint -> Maybe FilePath
fsTarget MountPoint
mnt of
  Just FilePath
mntXml ->
    FilePath
"<filesystem type='mount'>\n  "
      FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"<source dir='"
      FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
hostDir
      FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"'/>"
      FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\n  "
      FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
mntXml
      FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\n</filesystem>"
  Maybe FilePath
Nothing -> FilePath
""
fsSharedDir (SharedDirectoryRO FilePath
hostDir MountPoint
mnt) = case MountPoint -> Maybe FilePath
fsTarget MountPoint
mnt of
  Just FilePath
mntXml ->
    FilePath
"<filesystem type='mount'>\n  "
      FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"<source dir='"
      FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
hostDir
      FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"'/>"
      FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\n  "
      FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
mntXml
      FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\n  <readonly />\n</filesystem>"
  Maybe FilePath
Nothing -> FilePath
""
fsSharedDir (SharedSources MountPoint
_) = FilePath -> FilePath
forall a. HasCallStack => FilePath -> a
error FilePath
"Unreachable code reached!"

fsTarget :: MountPoint -> Maybe String
fsTarget :: MountPoint -> Maybe FilePath
fsTarget (MountPoint FilePath
dir) = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath -> Maybe FilePath) -> FilePath -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
"<target dir='" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
dir FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"'/>"
fsTarget MountPoint
_ = Maybe FilePath
forall a. Maybe a
Nothing

memoryUnit :: LibVirtLXCConfig -> ExecEnv -> String
memoryUnit :: LibVirtLXCConfig -> ExecEnv -> FilePath
memoryUnit LibVirtLXCConfig
cfg = RamSize -> FilePath
toUnit (RamSize -> FilePath)
-> (ExecEnv -> RamSize) -> ExecEnv -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Resources -> RamSize
maxMemory (Resources -> RamSize)
-> (ExecEnv -> Resources) -> ExecEnv -> RamSize
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExecEnv -> Resources
envResources
  where
    toUnit :: RamSize -> FilePath
toUnit RamSize
AutomaticRamSize = RamSize -> FilePath
toUnit (LibVirtLXCConfig -> RamSize
guestRamSize LibVirtLXCConfig
cfg)
    toUnit (RamSize Int
_ SizeUnit
u) = case SizeUnit
u of
      SizeUnit
GB -> FilePath
"GiB"
      SizeUnit
MB -> FilePath
"MiB"
      SizeUnit
KB -> FilePath
"KiB"

memoryAmount :: LibVirtLXCConfig -> ExecEnv -> String
memoryAmount :: LibVirtLXCConfig -> ExecEnv -> FilePath
memoryAmount LibVirtLXCConfig
cfg = Int -> FilePath
forall a. Show a => a -> FilePath
show (Int -> FilePath) -> (ExecEnv -> Int) -> ExecEnv -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RamSize -> Int
toAmount (RamSize -> Int) -> (ExecEnv -> RamSize) -> ExecEnv -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Resources -> RamSize
maxMemory (Resources -> RamSize)
-> (ExecEnv -> Resources) -> ExecEnv -> RamSize
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExecEnv -> Resources
envResources
  where
    toAmount :: RamSize -> Int
toAmount RamSize
AutomaticRamSize = RamSize -> Int
toAmount (LibVirtLXCConfig -> RamSize
guestRamSize LibVirtLXCConfig
cfg)
    toAmount (RamSize Int
n SizeUnit
_) = Int
n

cpuCountStr :: ExecEnv -> String
cpuCountStr :: ExecEnv -> FilePath
cpuCountStr = Int -> FilePath
forall a. Show a => a -> FilePath
show (Int -> FilePath) -> (ExecEnv -> Int) -> ExecEnv -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Resources -> Int
cpuCount (Resources -> Int) -> (ExecEnv -> Resources) -> ExecEnv -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExecEnv -> Resources
envResources