-- | Implementation of an execution environment that uses /systemdNspawn/.
module B9.SystemdNspawn
  ( SystemdNspawn (..),
  )
where

import B9.B9Config
  ( getB9Config,
    systemdNspawnConfigs,
  )
import B9.B9Config.SystemdNspawn 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 (when)
import Control.Monad.IO.Class
  ( liftIO,
  )
import Data.Foldable (traverse_)
import Data.List (intercalate, partition)
import Data.Maybe (fromMaybe, maybe)
import System.Directory
import System.FilePath
import Text.Printf (printf)

newtype SystemdNspawn = SystemdNspawn SystemdNspawnConfig

type SudoPrepender = String -> String

instance Backend SystemdNspawn where
  getBackendConfig :: proxy SystemdNspawn -> Eff e (Maybe SystemdNspawn)
getBackendConfig proxy SystemdNspawn
_ =
    (SystemdNspawnConfig -> SystemdNspawn)
-> Maybe SystemdNspawnConfig -> Maybe SystemdNspawn
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SystemdNspawnConfig -> SystemdNspawn
SystemdNspawn (Maybe SystemdNspawnConfig -> Maybe SystemdNspawn)
-> (B9Config -> Maybe SystemdNspawnConfig)
-> B9Config
-> Maybe SystemdNspawn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting
  (Maybe SystemdNspawnConfig) B9Config (Maybe SystemdNspawnConfig)
-> B9Config -> Maybe SystemdNspawnConfig
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (Maybe SystemdNspawnConfig) B9Config (Maybe SystemdNspawnConfig)
Lens' B9Config (Maybe SystemdNspawnConfig)
systemdNspawnConfigs (B9Config -> Maybe SystemdNspawn)
-> Eff e B9Config -> Eff e (Maybe SystemdNspawn)
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 SystemdNspawn -> [ImageType]
supportedImageTypes proxy SystemdNspawn
_ = [ImageType
Raw]

  runInEnvironment :: SystemdNspawn -> ExecEnv -> Script -> Eff e Bool
runInEnvironment (SystemdNspawn SystemdNspawnConfig
dCfg) ExecEnv
env Script
scriptIn =
    if Script -> Bool
emptyScript Script
scriptIn
      then Bool -> Eff e Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
      else do
        let sudo :: [Char] -> [Char]
sudo = if SystemdNspawnConfig -> Bool
_systemdNspawnUseSudo SystemdNspawnConfig
dCfg then ([Char]
"sudo " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) else [Char] -> [Char]
forall a. a -> a
id
        ContainerBuildDirectories
containerBuildDirs <- Eff e ContainerBuildDirectories
forall (e :: [* -> *]).
(Member BuildInfoReader e, Member ExcB9 e, CommandIO e) =>
Eff e ContainerBuildDirectories
createContainerBuildRootDir
        ContainerMounts
containerMounts <- ([Char] -> [Char])
-> ExecEnv -> ContainerBuildDirectories -> Eff e ContainerMounts
forall (e :: [* -> *]).
(Member BuildInfoReader e, Member ExcB9 e, CommandIO e) =>
([Char] -> [Char])
-> ExecEnv -> ContainerBuildDirectories -> Eff e ContainerMounts
mountLoopbackImages [Char] -> [Char]
sudo ExecEnv
env ContainerBuildDirectories
containerBuildDirs
        Eff e Bool -> Eff e () -> Eff e Bool
forall (e :: [* -> *]) a.
Member ExcB9 e =>
Eff e a -> Eff e () -> Eff e a
finallyB9
          ( do
              BootScript
bootScript <- ContainerBuildDirectories -> Script -> Eff e BootScript
forall (e :: [* -> *]).
(Member ExcB9 e, CommandIO e) =>
ContainerBuildDirectories -> Script -> Eff e BootScript
prepareBootScript ContainerBuildDirectories
containerBuildDirs Script
scriptIn
              ([Char] -> [Char])
-> ContainerMounts
-> [SharedDirectory]
-> BootScript
-> SystemdNspawnConfig
-> Eff e Bool
forall (e :: [* -> *]).
(Member ExcB9 e, Member BuildInfoReader e, CommandIO e) =>
([Char] -> [Char])
-> ContainerMounts
-> [SharedDirectory]
-> BootScript
-> SystemdNspawnConfig
-> Eff e Bool
execBuild [Char] -> [Char]
sudo ContainerMounts
containerMounts (ExecEnv -> [SharedDirectory]
envSharedDirectories ExecEnv
env) BootScript
bootScript SystemdNspawnConfig
dCfg
          )
          ( do
              ([Char] -> [Char]) -> ContainerMounts -> Eff e ()
forall (e :: [* -> *]).
(Member ExcB9 e, CommandIO e) =>
([Char] -> [Char]) -> ContainerMounts -> Eff e ()
umountLoopbackImages [Char] -> [Char]
sudo ContainerMounts
containerMounts
              ([Char] -> [Char]) -> ContainerBuildDirectories -> Eff e ()
forall (e :: [* -> *]).
(Member ExcB9 e, CommandIO e) =>
([Char] -> [Char]) -> ContainerBuildDirectories -> Eff e ()
removeContainerBuildRootDir [Char] -> [Char]
sudo ContainerBuildDirectories
containerBuildDirs
          )

createContainerBuildRootDir ::
  (Member BuildInfoReader e, Member ExcB9 e, CommandIO e) => Eff e ContainerBuildDirectories
createContainerBuildRootDir :: Eff e ContainerBuildDirectories
createContainerBuildRootDir = do
  [Char]
buildD <- Eff e [Char]
forall (e :: [* -> *]). Member BuildInfoReader e => Eff e [Char]
getBuildDir
  let loopbackMountDir :: [Char]
loopbackMountDir = [Char]
root [Char] -> [Char] -> [Char]
</> [Char]
"loopback_mounts"
      root :: [Char]
root = [Char]
buildD [Char] -> [Char] -> [Char]
</> [Char]
"container_build_root"
  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 -> [Char] -> IO ()
createDirectoryIfMissing Bool
True [Char]
root
    Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True [Char]
loopbackMountDir
  let res :: ContainerBuildDirectories
res = ContainerBuildDirectories :: [Char] -> [Char] -> ContainerBuildDirectories
ContainerBuildDirectories {containerBuildRoot :: [Char]
containerBuildRoot = [Char]
root, containerLoopbackMountRoot :: [Char]
containerLoopbackMountRoot = [Char]
loopbackMountDir}
  [Char] -> Eff e ()
forall (e :: [* -> *]). CommandIO e => [Char] -> Eff e ()
traceL ([Char]
"Created container build directories: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ContainerBuildDirectories -> [Char]
forall a. Show a => a -> [Char]
show ContainerBuildDirectories
res)
  ContainerBuildDirectories -> Eff e ContainerBuildDirectories
forall (m :: * -> *) a. Monad m => a -> m a
return ContainerBuildDirectories
res

data ContainerBuildDirectories
  = ContainerBuildDirectories
      { ContainerBuildDirectories -> [Char]
containerBuildRoot :: FilePath,
        ContainerBuildDirectories -> [Char]
containerLoopbackMountRoot :: FilePath
      }
  deriving (Int -> ContainerBuildDirectories -> [Char] -> [Char]
[ContainerBuildDirectories] -> [Char] -> [Char]
ContainerBuildDirectories -> [Char]
(Int -> ContainerBuildDirectories -> [Char] -> [Char])
-> (ContainerBuildDirectories -> [Char])
-> ([ContainerBuildDirectories] -> [Char] -> [Char])
-> Show ContainerBuildDirectories
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [ContainerBuildDirectories] -> [Char] -> [Char]
$cshowList :: [ContainerBuildDirectories] -> [Char] -> [Char]
show :: ContainerBuildDirectories -> [Char]
$cshow :: ContainerBuildDirectories -> [Char]
showsPrec :: Int -> ContainerBuildDirectories -> [Char] -> [Char]
$cshowsPrec :: Int -> ContainerBuildDirectories -> [Char] -> [Char]
Show)

mountLoopbackImages ::
  (Member BuildInfoReader e, Member ExcB9 e, CommandIO e) =>
  SudoPrepender ->
  ExecEnv ->
  ContainerBuildDirectories ->
  Eff e ContainerMounts
mountLoopbackImages :: ([Char] -> [Char])
-> ExecEnv -> ContainerBuildDirectories -> Eff e ContainerMounts
mountLoopbackImages [Char] -> [Char]
sudo ExecEnv
e ContainerBuildDirectories
containerDirs = do
  let imgMounts0 :: [(Image, [Char])]
imgMounts0 = [(Image
img, [Char]
mountPoint) | (Image
img, MountPoint [Char]
mountPoint) <- ExecEnv -> [(Image, MountPoint)]
envImageMounts ExecEnv
e]
      imgMounts :: [([Char], [Char])]
imgMounts = [([Char]
imgPath, [Char]
mountPoint) | (Image [Char]
imgPath ImageType
_ FileSystem
_, [Char]
mountPoint) <- [(Image, [Char])]
imgMounts0]
      invalidImages :: [(Image, [Char])]
invalidImages = [(Image, [Char])
x | x :: (Image, [Char])
x@(Image [Char]
_ ImageType
t FileSystem
_, [Char]
_) <- [(Image, [Char])]
imgMounts0, ImageType
t ImageType -> ImageType -> Bool
forall a. Eq a => a -> a -> Bool
/= ImageType
Raw]
  Bool -> Eff e () -> Eff e ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
    (Bool -> Bool
not ([(Image, [Char])] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Image, [Char])]
invalidImages))
    ([Char] -> Eff e ()
forall (e :: [* -> *]) a. Member ExcB9 e => [Char] -> Eff e a
throwB9Error ([Char]
"Internal Error: Only 'raw' disk images can be used for container builds, and these images were supposed to be automatically converted: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [(Image, [Char])] -> [Char]
forall a. Show a => a -> [Char]
show [(Image, [Char])]
invalidImages))
  case (([Char], [Char]) -> Bool)
-> [([Char], [Char])] -> ([([Char], [Char])], [([Char], [Char])])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (([Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"/") ([Char] -> Bool)
-> (([Char], [Char]) -> [Char]) -> ([Char], [Char]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char], [Char]) -> [Char]
forall a b. (a, b) -> b
snd) [([Char], [Char])]
imgMounts of
    ([([Char], [Char])
rootImg], [([Char], [Char])]
otherImgs) -> do
      LoopbackMount
rootMount <- ([Char], [Char]) -> Eff e LoopbackMount
mountLoopback ([Char], [Char])
rootImg
      [LoopbackMount]
otherMounts <- (([Char], [Char]) -> Eff e LoopbackMount)
-> [([Char], [Char])] -> Eff e [LoopbackMount]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ([Char], [Char]) -> Eff e LoopbackMount
mountLoopback [([Char], [Char])]
otherImgs
      ContainerMounts -> Eff e ContainerMounts
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ContainerRootImage LoopbackMount
-> [LoopbackMount] -> ContainerMounts
ContainerMounts (LoopbackMount -> Either ContainerRootImage LoopbackMount
forall a b. b -> Either a b
Right LoopbackMount
rootMount) [LoopbackMount]
otherMounts)
    ([], [([Char], [Char])]
_) ->
      [Char] -> Eff e ContainerMounts
forall (e :: [* -> *]) a. Member ExcB9 e => [Char] -> Eff e a
throwB9Error [Char]
"A containerized build requires that a disk image for the root-, i.e. the '/' directory is configured."
    ([([Char], [Char])]
rootImgs, [([Char], [Char])]
_) ->
      [Char] -> Eff e ContainerMounts
forall (e :: [* -> *]) a. Member ExcB9 e => [Char] -> Eff e a
throwB9Error ([Char]
"A containerized build requires that only one disk image for the root-, i.e. the '/' directory, instead these were given: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [([Char], [Char])] -> [Char]
forall a. Show a => a -> [Char]
show [([Char], [Char])]
rootImgs)
  where
    mountLoopback :: ([Char], [Char]) -> Eff e LoopbackMount
mountLoopback ([Char]
imgPath, [Char]
containerMountPoint) = do
      let hostMountPoint :: [Char]
hostMountPoint =
            ContainerBuildDirectories -> [Char]
containerLoopbackMountRoot ContainerBuildDirectories
containerDirs
              [Char] -> [Char] -> [Char]
</> ([Char], [Char]) -> [Char]
forall a. Hashable a => a -> [Char]
printHash ([Char]
imgPath, [Char]
containerMountPoint)
      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
$ Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True [Char]
hostMountPoint
      [Char] -> Maybe Timeout -> Eff e Bool
forall (e :: [* -> *]).
(CommandIO e, Member ExcB9 e) =>
[Char] -> Maybe Timeout -> Eff e Bool
hostCmd ([Char] -> [Char]
sudo ([Char] -> [Char] -> [Char] -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"mount -o loop '%s' '%s'" [Char]
imgPath [Char]
hostMountPoint)) Maybe Timeout
timeoutFastCmd
      LoopbackMount -> Eff e LoopbackMount
forall (m :: * -> *) a. Monad m => a -> m a
return
        ( LoopbackMount :: [Char] -> [Char] -> LoopbackMount
LoopbackMount
            { loopbackHost :: [Char]
loopbackHost = [Char]
hostMountPoint,
              loopbackContainer :: [Char]
loopbackContainer = [Char]
containerMountPoint
            }
        )

newtype ContainerRootImage
  = ContainerRootImage FilePath
  deriving (Int -> ContainerRootImage -> [Char] -> [Char]
[ContainerRootImage] -> [Char] -> [Char]
ContainerRootImage -> [Char]
(Int -> ContainerRootImage -> [Char] -> [Char])
-> (ContainerRootImage -> [Char])
-> ([ContainerRootImage] -> [Char] -> [Char])
-> Show ContainerRootImage
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [ContainerRootImage] -> [Char] -> [Char]
$cshowList :: [ContainerRootImage] -> [Char] -> [Char]
show :: ContainerRootImage -> [Char]
$cshow :: ContainerRootImage -> [Char]
showsPrec :: Int -> ContainerRootImage -> [Char] -> [Char]
$cshowsPrec :: Int -> ContainerRootImage -> [Char] -> [Char]
Show)

data ContainerMounts
  = ContainerMounts
      { ContainerMounts -> Either ContainerRootImage LoopbackMount
containerRootImage :: Either ContainerRootImage LoopbackMount,
        ContainerMounts -> [LoopbackMount]
containerLoopbackMounts :: [LoopbackMount]
      }
  deriving (Int -> ContainerMounts -> [Char] -> [Char]
[ContainerMounts] -> [Char] -> [Char]
ContainerMounts -> [Char]
(Int -> ContainerMounts -> [Char] -> [Char])
-> (ContainerMounts -> [Char])
-> ([ContainerMounts] -> [Char] -> [Char])
-> Show ContainerMounts
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [ContainerMounts] -> [Char] -> [Char]
$cshowList :: [ContainerMounts] -> [Char] -> [Char]
show :: ContainerMounts -> [Char]
$cshow :: ContainerMounts -> [Char]
showsPrec :: Int -> ContainerMounts -> [Char] -> [Char]
$cshowsPrec :: Int -> ContainerMounts -> [Char] -> [Char]
Show)

data LoopbackMount = LoopbackMount {LoopbackMount -> [Char]
loopbackHost :: FilePath, LoopbackMount -> [Char]
loopbackContainer :: FilePath}
  deriving (Int -> LoopbackMount -> [Char] -> [Char]
[LoopbackMount] -> [Char] -> [Char]
LoopbackMount -> [Char]
(Int -> LoopbackMount -> [Char] -> [Char])
-> (LoopbackMount -> [Char])
-> ([LoopbackMount] -> [Char] -> [Char])
-> Show LoopbackMount
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [LoopbackMount] -> [Char] -> [Char]
$cshowList :: [LoopbackMount] -> [Char] -> [Char]
show :: LoopbackMount -> [Char]
$cshow :: LoopbackMount -> [Char]
showsPrec :: Int -> LoopbackMount -> [Char] -> [Char]
$cshowsPrec :: Int -> LoopbackMount -> [Char] -> [Char]
Show)

prepareBootScript ::
  (Member ExcB9 e, CommandIO e) =>
  ContainerBuildDirectories ->
  Script ->
  Eff e BootScript
prepareBootScript :: ContainerBuildDirectories -> Script -> Eff e BootScript
prepareBootScript ContainerBuildDirectories
containerDirs Script
script = do
  let bs :: BootScript
bs =
        BootScript :: [Char] -> [Char] -> [Char] -> BootScript
BootScript
          { bootScriptHostDir :: [Char]
bootScriptHostDir = ContainerBuildDirectories -> [Char]
containerBuildRoot ContainerBuildDirectories
containerDirs [Char] -> [Char] -> [Char]
</> [Char]
"boot_script",
            bootScriptContainerDir :: [Char]
bootScriptContainerDir = [Char]
"/mnt/boot_script",
            bootScriptContainerCommand :: [Char]
bootScriptContainerCommand = BootScript -> [Char]
bootScriptContainerDir BootScript
bs [Char] -> [Char] -> [Char]
</> [Char]
scriptFile
          }
      scriptFile :: [Char]
scriptFile = [Char]
"run.sh"
      scriptEnv :: Script
scriptEnv =
        [Script] -> Script
Begin
          [ [Char] -> [[Char]] -> Script
Run [Char]
"export" [[Char]
"HOME=/root"],
            [Char] -> [[Char]] -> Script
Run [Char]
"export" [[Char]
"USER=root"],
            -- IgnoreErrors True [Run "source" ["/etc/profile"]],
            Script
script
          ]
  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 -> [Char] -> IO ()
createDirectoryIfMissing Bool
True (BootScript -> [Char]
bootScriptHostDir BootScript
bs)
    [Char] -> Script -> IO ()
writeSh (BootScript -> [Char]
bootScriptHostDir BootScript
bs [Char] -> [Char] -> [Char]
</> [Char]
scriptFile) Script
scriptEnv
  [Char] -> Eff e ()
forall (e :: [* -> *]). CommandIO e => [Char] -> Eff e ()
traceL ([Char]
"wrote script: \n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Script -> [Char]
forall a. Show a => a -> [Char]
show Script
scriptEnv)
  [Char] -> Eff e ()
forall (e :: [* -> *]). CommandIO e => [Char] -> Eff e ()
traceL ([Char]
"created boot-script: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ BootScript -> [Char]
forall a. Show a => a -> [Char]
show BootScript
bs)
  BootScript -> Eff e BootScript
forall (m :: * -> *) a. Monad m => a -> m a
return BootScript
bs

data BootScript
  = BootScript
      { BootScript -> [Char]
bootScriptHostDir :: FilePath,
        BootScript -> [Char]
bootScriptContainerDir :: FilePath,
        BootScript -> [Char]
bootScriptContainerCommand :: String
      }
  deriving (Int -> BootScript -> [Char] -> [Char]
[BootScript] -> [Char] -> [Char]
BootScript -> [Char]
(Int -> BootScript -> [Char] -> [Char])
-> (BootScript -> [Char])
-> ([BootScript] -> [Char] -> [Char])
-> Show BootScript
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [BootScript] -> [Char] -> [Char]
$cshowList :: [BootScript] -> [Char] -> [Char]
show :: BootScript -> [Char]
$cshow :: BootScript -> [Char]
showsPrec :: Int -> BootScript -> [Char] -> [Char]
$cshowsPrec :: Int -> BootScript -> [Char] -> [Char]
Show)

execBuild ::
  (Member ExcB9 e, Member BuildInfoReader e, CommandIO e) =>
  SudoPrepender ->
  ContainerMounts ->
  [SharedDirectory] ->
  BootScript ->
  SystemdNspawnConfig ->
  Eff e Bool
execBuild :: ([Char] -> [Char])
-> ContainerMounts
-> [SharedDirectory]
-> BootScript
-> SystemdNspawnConfig
-> Eff e Bool
execBuild [Char] -> [Char]
sudo ContainerMounts
containerMounts [SharedDirectory]
sharedDirs BootScript
bootScript SystemdNspawnConfig
dCfg = do
  let systemdCmd :: [Char]
systemdCmd =
        [[Char]] -> [Char]
unwords
          ( [[Char]]
systemdNspawnExe
              [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
consoleOptions
              [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
rootImageOptions
              [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
capabilityOptions
              [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
bindMounts
              [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
extraArgs
              [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
execOptions
          )
      systemdNspawnExe :: [[Char]]
systemdNspawnExe =
        [[Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe [Char]
"systemd-nspawn" (SystemdNspawnConfig -> Maybe [Char]
_systemdNspawnExecutable SystemdNspawnConfig
dCfg)]
      consoleOptions :: [[Char]]
consoleOptions =
        [[Char]
"--console=" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SystemdNspawnConsole -> [Char]
forall a. Show a => a -> [Char]
show (SystemdNspawnConfig -> SystemdNspawnConsole
_systemdNspawnConsole SystemdNspawnConfig
dCfg)]
      rootImageOptions :: [[Char]]
rootImageOptions =
        case ContainerMounts -> Either ContainerRootImage LoopbackMount
containerRootImage ContainerMounts
containerMounts of
          Left (ContainerRootImage [Char]
imgPath) ->
            [[Char]
"-i", [Char]
imgPath]
          Right LoopbackMount
loopbackMounted ->
            [[Char]
"-D", LoopbackMount -> [Char]
loopbackHost LoopbackMount
loopbackMounted]
      capabilityOptions :: [[Char]]
capabilityOptions =
        case SystemdNspawnConfig -> [ContainerCapability]
_systemdNspawnCapabilities SystemdNspawnConfig
dCfg of
          [] -> []
          [ContainerCapability]
caps -> [[Char]
"--capability=" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"," ((ContainerCapability -> [Char])
-> [ContainerCapability] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ContainerCapability -> [Char]
forall a. Show a => a -> [Char]
show [ContainerCapability]
caps)]
      bindMounts :: [[Char]]
bindMounts =
        (([Char], [Char]) -> [Char]) -> [([Char], [Char])] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], [Char]) -> [Char]
mkBind [([Char], [Char])]
loopbackMounts
          [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ (([Char], [Char]) -> [Char]) -> [([Char], [Char])] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], [Char]) -> [Char]
mkBind [([Char], [Char])]
sharedDirMounts
          [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ (([Char], [Char]) -> [Char]) -> [([Char], [Char])] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], [Char]) -> [Char]
mkBindRo [([Char], [Char])]
sharedDirMountsRo
          [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [([Char], [Char]) -> [Char]
mkBindRo (BootScript -> [Char]
bootScriptHostDir BootScript
bootScript, BootScript -> [Char]
bootScriptContainerDir BootScript
bootScript)]
        where
          mkBind :: ([Char], [Char]) -> [Char]
mkBind ([Char]
hostDir, [Char]
containerDir) = [Char]
"--bind=" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
hostDir [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
":" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
containerDir
          mkBindRo :: ([Char], [Char]) -> [Char]
mkBindRo ([Char]
hostDir, [Char]
containerDir) = [Char]
"--bind-ro=" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
hostDir [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
":" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
containerDir
          loopbackMounts :: [([Char], [Char])]
loopbackMounts =
            [ ([Char]
h, [Char]
c)
              | LoopbackMount {loopbackHost :: LoopbackMount -> [Char]
loopbackHost = [Char]
h, loopbackContainer :: LoopbackMount -> [Char]
loopbackContainer = [Char]
c} <-
                  ContainerMounts -> [LoopbackMount]
containerLoopbackMounts ContainerMounts
containerMounts
            ]
          sharedDirMounts :: [([Char], [Char])]
sharedDirMounts = [([Char]
h, [Char]
c) | SharedDirectory [Char]
h (MountPoint [Char]
c) <- [SharedDirectory]
sharedDirs]
          sharedDirMountsRo :: [([Char], [Char])]
sharedDirMountsRo = [([Char]
h, [Char]
c) | SharedDirectoryRO [Char]
h (MountPoint [Char]
c) <- [SharedDirectory]
sharedDirs]
      extraArgs :: [[Char]]
extraArgs = [[Char]] -> ([Char] -> [[Char]]) -> Maybe [Char] -> [[Char]]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ([Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: []) (SystemdNspawnConfig -> Maybe [Char]
_systemdNspawnExtraArgs SystemdNspawnConfig
dCfg)
      execOptions :: [[Char]]
execOptions = [[Char]
"/bin/sh", BootScript -> [Char]
bootScriptContainerCommand BootScript
bootScript]
      timeout :: Maybe Timeout
timeout = (Int -> Timeout
TimeoutMicros (Int -> Timeout) -> (Int -> Int) -> Int -> Timeout
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000000)) (Int -> Timeout) -> Maybe Int -> Maybe Timeout
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SystemdNspawnConfig -> Maybe Int
_systemdNspawnMaxLifetimeSeconds SystemdNspawnConfig
dCfg
  [Char] -> Eff e ()
forall (e :: [* -> *]). CommandIO e => [Char] -> Eff e ()
traceL ([Char]
"executing systemd-nspawn container build")
  Bool
interactiveAction <- Eff e Bool
forall (e :: [* -> *]). Member BuildInfoReader e => Eff e Bool
isInteractive
  let 
    runInteractively :: Bool
runInteractively =
      case SystemdNspawnConfig -> SystemdNspawnConsole
_systemdNspawnConsole SystemdNspawnConfig
dCfg of
        SystemdNspawnConsole
SystemdNspawnInteractive ->
          Bool
True
        SystemdNspawnConsole
_ ->
          Bool
interactiveAction
  if Bool
runInteractively 
    then
      HostCommandStdin -> [Char] -> Maybe Timeout -> Eff e Bool
forall (e :: [* -> *]).
(CommandIO e, Member ExcB9 e) =>
HostCommandStdin -> [Char] -> Maybe Timeout -> Eff e Bool
hostCmdStdIn HostCommandStdin
HostCommandInheritStdin ([Char] -> [Char]
sudo [Char]
systemdCmd) Maybe Timeout
forall a. Maybe a
Nothing
    else  
      [Char] -> Maybe Timeout -> Eff e Bool
forall (e :: [* -> *]).
(CommandIO e, Member ExcB9 e) =>
[Char] -> Maybe Timeout -> Eff e Bool
hostCmd ([Char] -> [Char]
sudo [Char]
systemdCmd) Maybe Timeout
timeout

umountLoopbackImages ::
  forall e.
  (Member ExcB9 e, CommandIO e) =>
  SudoPrepender ->
  ContainerMounts ->
  Eff e ()
umountLoopbackImages :: ([Char] -> [Char]) -> ContainerMounts -> Eff e ()
umountLoopbackImages [Char] -> [Char]
sudo ContainerMounts
c = do
  case ContainerMounts -> Either ContainerRootImage LoopbackMount
containerRootImage ContainerMounts
c of
    Left ContainerRootImage
_ -> () -> Eff e ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Right LoopbackMount
r -> LoopbackMount -> Eff e ()
umount LoopbackMount
r
  (LoopbackMount -> Eff e ()) -> [LoopbackMount] -> Eff e ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ LoopbackMount -> Eff e ()
umount (ContainerMounts -> [LoopbackMount]
containerLoopbackMounts ContainerMounts
c)
  where
    umount :: LoopbackMount -> Eff e ()
    umount :: LoopbackMount -> Eff e ()
umount LoopbackMount
l = do
      [Char] -> Eff e ()
forall (e :: [* -> *]). CommandIO e => [Char] -> Eff e ()
traceL ([Char] -> Eff e ()) -> [Char] -> Eff e ()
forall a b. (a -> b) -> a -> b
$ [Char]
"unmounting: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ LoopbackMount -> [Char]
forall a. Show a => a -> [Char]
show LoopbackMount
l
      Bool
res <- [Char] -> Maybe Timeout -> Eff e Bool
forall (e :: [* -> *]).
(CommandIO e, Member ExcB9 e) =>
[Char] -> Maybe Timeout -> Eff e Bool
hostCmd ([Char] -> [Char]
sudo ([Char] -> [Char] -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"umount '%s'" (LoopbackMount -> [Char]
loopbackHost LoopbackMount
l))) Maybe Timeout
timeoutFastCmd
      Bool -> Eff e () -> Eff e ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
res) ([Char] -> Eff e ()
forall (e :: [* -> *]). CommandIO e => [Char] -> Eff e ()
errorL ([Char]
"failed to unmount: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ LoopbackMount -> [Char]
forall a. Show a => a -> [Char]
show LoopbackMount
l))

removeContainerBuildRootDir ::
  forall e.
  (Member ExcB9 e, CommandIO e) =>
  SudoPrepender ->
  ContainerBuildDirectories ->
  Eff e ()
removeContainerBuildRootDir :: ([Char] -> [Char]) -> ContainerBuildDirectories -> Eff e ()
removeContainerBuildRootDir [Char] -> [Char]
sudo ContainerBuildDirectories
containerBuildDirs = do
  let target :: [Char]
target = ContainerBuildDirectories -> [Char]
containerBuildRoot ContainerBuildDirectories
containerBuildDirs
  [Char] -> Eff e ()
forall (e :: [* -> *]). CommandIO e => [Char] -> Eff e ()
traceL ([Char] -> Eff e ()) -> [Char] -> Eff e ()
forall a b. (a -> b) -> a -> b
$ [Char]
"removing: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
target
  Bool
res <- [Char] -> Maybe Timeout -> Eff e Bool
forall (e :: [* -> *]).
(CommandIO e, Member ExcB9 e) =>
[Char] -> Maybe Timeout -> Eff e Bool
hostCmd ([Char] -> [Char]
sudo ([Char] -> [Char] -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"rm -rf '%s'" [Char]
target)) Maybe Timeout
timeoutFastCmd
  Bool -> Eff e () -> Eff e ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
res) ([Char] -> Eff e ()
forall (e :: [* -> *]). CommandIO e => [Char] -> Eff e ()
errorL ([Char]
"failed to remove: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
target))

timeoutFastCmd :: Maybe Timeout
timeoutFastCmd :: Maybe Timeout
timeoutFastCmd = Timeout -> Maybe Timeout
forall a. a -> Maybe a
Just (Int -> Timeout
TimeoutMicros Int
10000000)