-- | Effectful functions to execute and build virtual machine images using
--    an execution environment like e.g. libvirt-lxc.
module B9.VmBuilder
  ( buildWithVm,
  )
where

import B9.Artifact.Readable
import B9.B9Error
import B9.B9Logging
import B9.B9Monad
import B9.BuildInfo
import B9.Container
import B9.DiskImageBuilder
import B9.DiskImages
import qualified B9.Docker as Docker
import B9.ExecEnv
import qualified B9.LibVirtLXC as LXC
import qualified B9.SystemdNspawn as SystemdNspawn
import B9.Vm
import Control.Eff
import Control.Monad
import Control.Monad.IO.Class
import Data.List
import Data.Proxy
import System.Directory
  ( canonicalizePath,
    createDirectoryIfMissing,
  )
import Text.Printf (printf)
import Text.Show.Pretty (ppShow)

buildWithVm ::
  IsB9 e => InstanceId -> [ImageTarget] -> FilePath -> VmScript -> Eff e Bool
buildWithVm :: InstanceId -> [ImageTarget] -> FilePath -> VmScript -> Eff e Bool
buildWithVm InstanceId
iid [ImageTarget]
imageTargets FilePath
instanceDir VmScript
vmScript = do
  Maybe Bool
res <- (forall x. Backend x => x -> Eff e Bool) -> Eff e (Maybe Bool)
forall (e :: [* -> *]) a.
IsB9 e =>
(forall x. Backend x => x -> Eff e a) -> Eff e (Maybe a)
withBackend (InstanceId
-> [ImageTarget] -> FilePath -> VmScript -> x -> Eff e Bool
forall backendCfg (e :: [* -> *]).
(Backend backendCfg, IsB9 e) =>
InstanceId
-> [ImageTarget]
-> FilePath
-> VmScript
-> backendCfg
-> Eff e Bool
buildWithBackend InstanceId
iid [ImageTarget]
imageTargets FilePath
instanceDir VmScript
vmScript)
  case Maybe Bool
res of
    Maybe Bool
Nothing ->
      FilePath -> Eff e Bool
forall (e :: [* -> *]) a.
(CommandIO e, Member ExcB9 e) =>
FilePath -> Eff e a
errorExitL FilePath
"No container configured."
    Just Bool
success ->
      Bool -> Eff e Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
success

buildWithBackend :: forall backendCfg e. (Backend backendCfg, IsB9 e) => InstanceId -> [ImageTarget] -> FilePath -> VmScript -> backendCfg -> Eff e Bool
buildWithBackend :: InstanceId
-> [ImageTarget]
-> FilePath
-> VmScript
-> backendCfg
-> Eff e Bool
buildWithBackend InstanceId
iid [ImageTarget]
imageTargets FilePath
instanceDir VmScript
vmScript backendCfg
backendCfg = do
  let vmBuildSupportedImageTypes :: [ImageType]
vmBuildSupportedImageTypes = Proxy backendCfg -> [ImageType]
forall config (proxy :: * -> *).
Backend config =>
proxy config -> [ImageType]
supportedImageTypes (Proxy backendCfg
forall k (t :: k). Proxy t
Proxy :: Proxy backendCfg)
  [Image]
buildImages <- [ImageTarget] -> [ImageType] -> Eff e [Image]
forall (e :: [* -> *]).
IsB9 e =>
[ImageTarget] -> [ImageType] -> Eff e [Image]
createBuildImages [ImageTarget]
imageTargets [ImageType]
vmBuildSupportedImageTypes
  Bool
success <- backendCfg
-> InstanceId
-> [ImageTarget]
-> [Image]
-> FilePath
-> VmScript
-> Eff e Bool
forall (e :: [* -> *]) backendCfg.
(Backend backendCfg, IsB9 e) =>
backendCfg
-> InstanceId
-> [ImageTarget]
-> [Image]
-> FilePath
-> VmScript
-> Eff e Bool
runVmScript backendCfg
backendCfg InstanceId
iid [ImageTarget]
imageTargets [Image]
buildImages FilePath
instanceDir VmScript
vmScript
  Bool -> Eff e () -> Eff e ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
success ([Image] -> [ImageTarget] -> Eff e ()
forall (e :: [* -> *]).
IsB9 e =>
[Image] -> [ImageTarget] -> Eff e ()
createDestinationImages [Image]
buildImages [ImageTarget]
imageTargets)
  Bool -> Eff e Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
success

createBuildImages :: IsB9 e => [ImageTarget] -> [ImageType] -> Eff e [Image]
createBuildImages :: [ImageTarget] -> [ImageType] -> Eff e [Image]
createBuildImages [ImageTarget]
imageTargets [ImageType]
vmBuildSupportedImageTypes = do
  FilePath -> Eff e ()
forall (e :: [* -> *]). CommandIO e => FilePath -> Eff e ()
dbgL FilePath
"creating build images"
  FilePath -> Eff e ()
forall (e :: [* -> *]). CommandIO e => FilePath -> Eff e ()
traceL ([ImageTarget] -> FilePath
forall a. Show a => a -> FilePath
ppShow [ImageTarget]
imageTargets)
  [Image]
buildImages <- (ImageTarget -> Eff e Image) -> [ImageTarget] -> Eff e [Image]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ImageTarget -> Eff e Image
createBuildImage [ImageTarget]
imageTargets
  FilePath -> Eff e ()
forall (e :: [* -> *]). CommandIO e => FilePath -> Eff e ()
infoL FilePath
"CREATED BUILD IMAGES"
  FilePath -> Eff e ()
forall (e :: [* -> *]). CommandIO e => FilePath -> Eff e ()
traceL ([Image] -> FilePath
forall a. Show a => a -> FilePath
ppShow [Image]
buildImages)
  [Image] -> Eff e [Image]
forall (m :: * -> *) a. Monad m => a -> m a
return [Image]
buildImages
  where
    createBuildImage :: ImageTarget -> Eff e Image
createBuildImage (ImageTarget ImageDestination
dest ImageSource
imageSource MountPoint
_mnt) = do
      FilePath
buildDir <- Eff e FilePath
forall (e :: [* -> *]). Member BuildInfoReader e => Eff e FilePath
getBuildDir
      [ImageType]
destTypes <- ImageSource -> Eff e [ImageType]
forall (e :: [* -> *]). IsB9 e => ImageSource -> Eff e [ImageType]
preferredDestImageTypes ImageSource
imageSource
      let buildImgType :: ImageType
buildImgType =
            [ImageType] -> ImageType
forall a. [a] -> a
head
              ( [ImageType]
destTypes
                  [ImageType] -> [ImageType] -> [ImageType]
forall a. Eq a => [a] -> [a] -> [a]
`intersect` HasCallStack => ImageDestination -> [ImageType]
ImageDestination -> [ImageType]
preferredSourceImageTypes ImageDestination
dest
                  [ImageType] -> [ImageType] -> [ImageType]
forall a. Eq a => [a] -> [a] -> [a]
`intersect` [ImageType]
vmBuildSupportedImageTypes
              )
      Image
srcImg <- ImageSource -> Eff e Image
forall (e :: [* -> *]). IsB9 e => ImageSource -> Eff e Image
resolveImageSource ImageSource
imageSource
      let buildImg :: Image
buildImg =
            ImageType -> Image -> Image
changeImageFormat ImageType
buildImgType (FilePath -> Image -> Image
changeImageDirectory FilePath
buildDir Image
srcImg)
      Image
buildImgAbsolutePath <- Image -> Eff e Image
forall (e :: [* -> *]). IsB9 e => Image -> Eff e Image
ensureAbsoluteImageDirExists Image
buildImg
      ImageSource -> Image -> Eff e ()
forall (e :: [* -> *]). IsB9 e => ImageSource -> Image -> Eff e ()
materializeImageSource ImageSource
imageSource Image
buildImg
      Image -> Eff e Image
forall (m :: * -> *) a. Monad m => a -> m a
return Image
buildImgAbsolutePath

runVmScript ::
  forall e backendCfg.
  (Backend backendCfg, IsB9 e) =>
  backendCfg ->
  InstanceId ->
  [ImageTarget] ->
  [Image] ->
  FilePath ->
  VmScript ->
  Eff e Bool
runVmScript :: backendCfg
-> InstanceId
-> [ImageTarget]
-> [Image]
-> FilePath
-> VmScript
-> Eff e Bool
runVmScript backendCfg
_ InstanceId
_ [ImageTarget]
_ [Image]
_ FilePath
_ VmScript
NoVmScript = Bool -> Eff e Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
runVmScript backendCfg
backendCfg (IID FilePath
iid) [ImageTarget]
imageTargets [Image]
buildImages FilePath
instanceDir VmScript
vmScript = do
  FilePath -> Eff e ()
forall (e :: [* -> *]). CommandIO e => FilePath -> Eff e ()
dbgL (FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"starting vm script with instanceDir '%s'" FilePath
instanceDir)
  FilePath -> Eff e ()
forall (e :: [* -> *]). CommandIO e => FilePath -> Eff e ()
traceL (VmScript -> FilePath
forall a. Show a => a -> FilePath
ppShow VmScript
vmScript)
  ExecEnv
execEnv <- Eff e ExecEnv
IsB9 e => Eff e ExecEnv
setUpExecEnv
  let (VmScript CPUArch
_ [SharedDirectory]
_ Script
script) = VmScript
vmScript
  Either SomeException Bool
result <- Eff (ExcB9 : e) Bool -> Eff e (Either SomeException Bool)
forall (e :: [* -> *]) a.
Eff (ExcB9 : e) a -> Eff e (Either SomeException a)
runExcB9 (Eff (ExcB9 : e) Bool -> Eff e (Either SomeException Bool))
-> Eff (ExcB9 : e) Bool -> Eff e (Either SomeException Bool)
forall a b. (a -> b) -> a -> b
$ backendCfg -> ExecEnv -> Script -> Eff (ExcB9 : e) Bool
forall config (e :: [* -> *]).
(Backend config, Member BuildInfoReader e, CommandIO e,
 Member ExcB9 e) =>
config -> ExecEnv -> Script -> Eff e Bool
runInEnvironment backendCfg
backendCfg ExecEnv
execEnv Script
script
  Either FilePath Bool -> Eff e Bool
IsB9 e => Either FilePath Bool -> Eff e Bool
handleErrors ((SomeException -> Either FilePath Bool)
-> (Bool -> Either FilePath Bool)
-> Either SomeException Bool
-> Either FilePath Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (FilePath -> Either FilePath Bool
forall a b. a -> Either a b
Left (FilePath -> Either FilePath Bool)
-> (SomeException -> FilePath)
-> SomeException
-> Either FilePath Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> FilePath
forall a. Show a => a -> FilePath
show) Bool -> Either FilePath Bool
forall a b. b -> Either a b
Right Either SomeException Bool
result)
  where
    handleErrors :: IsB9 e => Either String Bool -> Eff e Bool
    handleErrors :: Either FilePath Bool -> Eff e Bool
handleErrors (Right Bool
False) = do
      FilePath -> Eff e ()
forall (e :: [* -> *]). CommandIO e => FilePath -> Eff e ()
errorL FilePath
"The containerized build failed!"
      Bool -> Eff e Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    handleErrors (Right Bool
True) = do
      FilePath -> Eff e ()
forall (e :: [* -> *]). CommandIO e => FilePath -> Eff e ()
traceL FilePath
"The containerized build was successful."
      Bool -> Eff e Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    handleErrors (Left FilePath
err) =
      FilePath -> Eff e Bool
forall (e :: [* -> *]) a.
(CommandIO e, Member ExcB9 e) =>
FilePath -> Eff e a
errorExitL (FilePath
"Failed to complete the containerized build: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
err)
    setUpExecEnv :: IsB9 e => Eff e ExecEnv
    setUpExecEnv :: Eff e ExecEnv
setUpExecEnv = do
      let (VmScript CPUArch
cpu [SharedDirectory]
shares Script
_) = VmScript
vmScript
      let mountedImages :: [(Image, MountPoint)]
mountedImages = [Image]
buildImages [Image] -> [MountPoint] -> [(Image, MountPoint)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` (ImageTarget -> MountPoint
itImageMountPoint (ImageTarget -> MountPoint) -> [ImageTarget] -> [MountPoint]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ImageTarget]
imageTargets)
      [SharedDirectory]
sharesAbs <- FilePath -> [SharedDirectory] -> Eff e [SharedDirectory]
forall (e :: [* -> *]).
IsB9 e =>
FilePath -> [SharedDirectory] -> Eff e [SharedDirectory]
createSharedDirs FilePath
instanceDir [SharedDirectory]
shares
      ExecEnv -> Eff e ExecEnv
forall (m :: * -> *) a. Monad m => a -> m a
return
        (FilePath
-> [(Image, MountPoint)]
-> [SharedDirectory]
-> Resources
-> ExecEnv
ExecEnv FilePath
iid [(Image, MountPoint)]
mountedImages [SharedDirectory]
sharesAbs (RamSize -> Int -> CPUArch -> Resources
Resources RamSize
AutomaticRamSize Int
8 CPUArch
cpu))

createSharedDirs ::
  IsB9 e => FilePath -> [SharedDirectory] -> Eff e [SharedDirectory]
createSharedDirs :: FilePath -> [SharedDirectory] -> Eff e [SharedDirectory]
createSharedDirs FilePath
instanceDir = (SharedDirectory -> Eff e SharedDirectory)
-> [SharedDirectory] -> Eff e [SharedDirectory]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM SharedDirectory -> Eff e SharedDirectory
createSharedDir
  where
    createSharedDir :: SharedDirectory -> Eff e SharedDirectory
createSharedDir (SharedDirectoryRO FilePath
d MountPoint
m) = do
      FilePath
d' <- FilePath -> Eff e FilePath
forall (m :: * -> *). MonadIO m => FilePath -> m FilePath
createAndCanonicalize FilePath
d
      SharedDirectory -> Eff e SharedDirectory
forall (m :: * -> *) a. Monad m => a -> m a
return (SharedDirectory -> Eff e SharedDirectory)
-> SharedDirectory -> Eff e SharedDirectory
forall a b. (a -> b) -> a -> b
$ FilePath -> MountPoint -> SharedDirectory
SharedDirectoryRO FilePath
d' MountPoint
m
    createSharedDir (SharedDirectory FilePath
d MountPoint
m) = do
      FilePath
d' <- FilePath -> Eff e FilePath
forall (m :: * -> *). MonadIO m => FilePath -> m FilePath
createAndCanonicalize FilePath
d
      SharedDirectory -> Eff e SharedDirectory
forall (m :: * -> *) a. Monad m => a -> m a
return (SharedDirectory -> Eff e SharedDirectory)
-> SharedDirectory -> Eff e SharedDirectory
forall a b. (a -> b) -> a -> b
$ FilePath -> MountPoint -> SharedDirectory
SharedDirectory FilePath
d' MountPoint
m
    createSharedDir (SharedSources MountPoint
mp) = do
      FilePath
d' <- FilePath -> Eff e FilePath
forall (m :: * -> *). MonadIO m => FilePath -> m FilePath
createAndCanonicalize FilePath
instanceDir
      SharedDirectory -> Eff e SharedDirectory
forall (m :: * -> *) a. Monad m => a -> m a
return (SharedDirectory -> Eff e SharedDirectory)
-> SharedDirectory -> Eff e SharedDirectory
forall a b. (a -> b) -> a -> b
$ FilePath -> MountPoint -> SharedDirectory
SharedDirectoryRO FilePath
d' MountPoint
mp
    createAndCanonicalize :: FilePath -> m FilePath
createAndCanonicalize FilePath
d = IO FilePath -> m FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> m FilePath) -> IO FilePath -> m FilePath
forall a b. (a -> b) -> a -> b
$ do
      Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
d
      FilePath -> IO FilePath
canonicalizePath FilePath
d

createDestinationImages :: IsB9 e => [Image] -> [ImageTarget] -> Eff e ()
createDestinationImages :: [Image] -> [ImageTarget] -> Eff e ()
createDestinationImages [Image]
buildImages [ImageTarget]
imageTargets = do
  FilePath -> Eff e ()
forall (e :: [* -> *]). CommandIO e => FilePath -> Eff e ()
dbgL FilePath
"converting build- to output images"
  let pairsToConvert :: [(Image, ImageDestination)]
pairsToConvert =
        [Image]
buildImages [Image] -> [ImageDestination] -> [(Image, ImageDestination)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` (ImageTarget -> ImageDestination
itImageDestination (ImageTarget -> ImageDestination)
-> [ImageTarget] -> [ImageDestination]
forall a b. (a -> b) -> [a] -> [b]
`map` [ImageTarget]
imageTargets)
  FilePath -> Eff e ()
forall (e :: [* -> *]). CommandIO e => FilePath -> Eff e ()
traceL ([(Image, ImageDestination)] -> FilePath
forall a. Show a => a -> FilePath
ppShow [(Image, ImageDestination)]
pairsToConvert)
  ((Image, ImageDestination) -> Eff e ())
-> [(Image, ImageDestination)] -> Eff e ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Image -> ImageDestination -> Eff e ())
-> (Image, ImageDestination) -> Eff e ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Image -> ImageDestination -> Eff e ()
forall (e :: [* -> *]).
IsB9 e =>
Image -> ImageDestination -> Eff e ()
createDestinationImage) [(Image, ImageDestination)]
pairsToConvert
  FilePath -> Eff e ()
forall (e :: [* -> *]). CommandIO e => FilePath -> Eff e ()
infoL FilePath
"CONVERTED BUILD- TO OUTPUT IMAGES"

withBackend :: IsB9 e => (forall x. Backend x => x -> Eff e a) -> Eff e (Maybe a)
withBackend :: (forall x. Backend x => x -> Eff e a) -> Eff e (Maybe a)
withBackend forall x. Backend x => x -> Eff e a
k = do
  Maybe LibVirtLXC
lxcCfg <- Proxy LibVirtLXC -> Eff e (Maybe LibVirtLXC)
forall config (proxy :: * -> *) (e :: [* -> *]).
(Backend config, Member BuildInfoReader e, CommandIO e) =>
proxy config -> Eff e (Maybe config)
getBackendConfig (Proxy LibVirtLXC
forall k (t :: k). Proxy t
Proxy :: Proxy LXC.LibVirtLXC)
  case Maybe LibVirtLXC
lxcCfg of
    Just LibVirtLXC
cfg ->
      a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Eff e a -> Eff e (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LibVirtLXC -> Eff e a
forall x. Backend x => x -> Eff e a
k LibVirtLXC
cfg
    Maybe LibVirtLXC
Nothing -> do
      Maybe Docker
dockerCfg <- Proxy Docker -> Eff e (Maybe Docker)
forall config (proxy :: * -> *) (e :: [* -> *]).
(Backend config, Member BuildInfoReader e, CommandIO e) =>
proxy config -> Eff e (Maybe config)
getBackendConfig (Proxy Docker
forall k (t :: k). Proxy t
Proxy :: Proxy Docker.Docker)
      case Maybe Docker
dockerCfg of
        Just Docker
cfg ->
          a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Eff e a -> Eff e (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Docker -> Eff e a
forall x. Backend x => x -> Eff e a
k Docker
cfg
        Maybe Docker
Nothing -> do
          Maybe SystemdNspawn
systemdNspawnCfg <- Proxy SystemdNspawn -> Eff e (Maybe SystemdNspawn)
forall config (proxy :: * -> *) (e :: [* -> *]).
(Backend config, Member BuildInfoReader e, CommandIO e) =>
proxy config -> Eff e (Maybe config)
getBackendConfig (Proxy SystemdNspawn
forall k (t :: k). Proxy t
Proxy :: Proxy SystemdNspawn.SystemdNspawn)
          case Maybe SystemdNspawn
systemdNspawnCfg of
            Just SystemdNspawn
cfg ->
              a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Eff e a -> Eff e (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SystemdNspawn -> Eff e a
forall x. Backend x => x -> Eff e a
k SystemdNspawn
cfg
            Maybe SystemdNspawn
Nothing ->
              Maybe a -> Eff e (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing