{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}

-- | This module contains the podman/bubblewrap context wrapper
module Podenv.Runtime
  ( execute,
    showRuntimeCmd,
    getPodmanPodStatus,
    deletePodmanPod,

    -- * Podman helpers
    podman,
    podmanRunArgs,

    -- * Bubblewrap helpers
    bwrap,
    bwrapRunArgs,

    -- * data type and lenses
    module Podenv.Context,
    RuntimeEnv (..),
    defaultRuntimeEnv,
  )
where

import Data.Map.Strict qualified as Map
import Data.Set qualified
import Data.Text qualified as Text
import Podenv.Config (defaultSystemConfig)
import Podenv.Context
import Podenv.Dhall (SystemConfig (..), sysDns)
import Podenv.Prelude
import System.Process.Typed qualified as P

execute :: RuntimeEnv -> Context -> IO ()
execute :: RuntimeEnv -> Context -> IO ()
execute RuntimeEnv
re Context
ctx = do
  (Volume -> IO ()) -> [Volume] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (FilePath -> Volume -> IO ()
ensureHostDirectory (RuntimeEnv -> FilePath
volumesDir RuntimeEnv
re)) (Map FilePath Volume -> [Volume]
forall k a. Map k a -> [a]
Map.elems (Map FilePath Volume -> [Volume])
-> Map FilePath Volume -> [Volume]
forall a b. (a -> b) -> a -> b
$ Context
ctx Context
-> FoldLike
     (Map FilePath Volume)
     Context
     Context
     (Map FilePath Volume)
     (Map FilePath Volume)
-> Map FilePath Volume
forall s a t b. s -> FoldLike a s t a b -> a
^. FoldLike
  (Map FilePath Volume)
  Context
  Context
  (Map FilePath Volume)
  (Map FilePath Volume)
forall (f :: * -> *).
Functor f =>
(Map FilePath Volume -> f (Map FilePath Volume))
-> Context -> f Context
mounts)
  ReaderT RuntimeEnv IO () -> RuntimeEnv -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Context -> ReaderT RuntimeEnv IO ()
doExecute Context
ctx) RuntimeEnv
re

-- | Create host directory and set SELinux label if needed
ensureHostDirectory :: FilePath -> Volume -> IO ()
ensureHostDirectory :: FilePath -> Volume -> IO ()
ensureHostDirectory FilePath
volumesDir (MkVolume Mode
_ (Volume Text
volumeName)) =
  FilePath -> IO ()
ensureHostDirectory' (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
volumesDir FilePath -> FilePath -> FilePath
</> Text -> FilePath
forall a. ToString a => a -> FilePath
toString Text
volumeName
ensureHostDirectory FilePath
_ (MkVolume Mode
_ (HostPath FilePath
fp)) | (NonEmpty Char -> Char
forall (f :: * -> *) a. IsNonEmpty f a a "last" => f a -> a
last (NonEmpty Char -> Char) -> Maybe (NonEmpty Char) -> Maybe Char
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> Maybe (NonEmpty Char)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty FilePath
fp) Maybe Char -> Maybe Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'/' = FilePath -> IO ()
ensureHostDirectory' FilePath
fp
ensureHostDirectory FilePath
_ Volume
_ = () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

ensureHostDirectory' :: FilePath -> IO ()
ensureHostDirectory' :: FilePath -> IO ()
ensureHostDirectory' FilePath
fp = do
  Bool
exist <- FilePath -> IO Bool
doesPathExist FilePath
fp
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exist (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
fp
    ProcessConfig () () () -> IO ()
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ()
P.runProcess_ (ProcessConfig () () () -> IO ())
-> ProcessConfig () () () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> ProcessConfig () () ()
P.proc FilePath
"/bin/chcon" [FilePath
"system_u:object_r:container_file_t:s0", FilePath
fp]

doExecute :: Context -> ContextEnvT ()
doExecute :: Context -> ReaderT RuntimeEnv IO ()
doExecute Context
ctx = case Context
ctx Context
-> FoldLike
     RuntimeContext Context Context RuntimeContext RuntimeContext
-> RuntimeContext
forall s a t b. s -> FoldLike a s t a b -> a
^. FoldLike
  RuntimeContext Context Context RuntimeContext RuntimeContext
forall (f :: * -> *).
Functor f =>
(RuntimeContext -> f RuntimeContext) -> Context -> f Context
runtimeCtx of
  Container ImageName
image -> Context -> ImageName -> ReaderT RuntimeEnv IO ()
executePodman Context
ctx ImageName
image
  Bubblewrap FilePath
fp -> Context -> FilePath -> ReaderT RuntimeEnv IO ()
executeBubblewrap Context
ctx FilePath
fp

executeBubblewrap :: Context -> FilePath -> ContextEnvT ()
executeBubblewrap :: Context -> FilePath -> ReaderT RuntimeEnv IO ()
executeBubblewrap Context
ctx FilePath
fp = do
  RuntimeEnv
re <- ReaderT RuntimeEnv IO RuntimeEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
  let args :: [FilePath]
args = RuntimeEnv -> Context -> FilePath -> [FilePath]
bwrapRunArgs RuntimeEnv
re Context
ctx FilePath
fp
  let cmd :: ProcessConfig () () ()
cmd = [FilePath] -> ProcessConfig () () ()
bwrap [FilePath]
args
  Text -> ReaderT RuntimeEnv IO ()
debug (Text -> ReaderT RuntimeEnv IO ())
-> Text -> ReaderT RuntimeEnv IO ()
forall a b. (a -> b) -> a -> b
$ ProcessConfig () () () -> Text
forall b a. (Show a, IsString b) => a -> b
show ProcessConfig () () ()
cmd
  ProcessConfig () () () -> ReaderT RuntimeEnv IO ()
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ()
P.runProcess_ ProcessConfig () () ()
cmd

bwrap :: [String] -> P.ProcessConfig () () ()
bwrap :: [FilePath] -> ProcessConfig () () ()
bwrap = Bool -> ProcessConfig () () () -> ProcessConfig () () ()
forall stdin stdout stderr.
Bool
-> ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
P.setDelegateCtlc Bool
True (ProcessConfig () () () -> ProcessConfig () () ())
-> ([FilePath] -> ProcessConfig () () ())
-> [FilePath]
-> ProcessConfig () () ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath] -> ProcessConfig () () ()
P.proc FilePath
"bwrap"

commonArgs :: Context -> [Text]
commonArgs :: Context -> [Text]
commonArgs Context {Bool
[Text]
[Port]
Maybe FilePath
Maybe Text
Maybe RunAs
Map FilePath Volume
Map Text Text
UserID
Set FilePath
Set Capability
Name
RuntimeContext
$sel:_privileged:Context :: Context -> Bool
$sel:_terminal:Context :: Context -> Bool
$sel:_interactive:Context :: Context -> Bool
$sel:_hostname:Context :: Context -> Maybe Text
$sel:_devices:Context :: Context -> Set FilePath
$sel:_ro:Context :: Context -> Bool
$sel:_syscaps:Context :: Context -> Set Capability
$sel:_mounts:Context :: Context -> Map FilePath Volume
$sel:_environ:Context :: Context -> Map Text Text
$sel:_workdir:Context :: Context -> Maybe FilePath
$sel:_command:Context :: Context -> [Text]
$sel:_uid:Context :: Context -> UserID
$sel:_anyUid:Context :: Context -> UserID
$sel:_selinux:Context :: Context -> Bool
$sel:_runAs:Context :: Context -> Maybe RunAs
$sel:_ports:Context :: Context -> [Port]
$sel:_network:Context :: Context -> Bool
$sel:_runtimeCtx:Context :: Context -> RuntimeContext
$sel:_namespace:Context :: Context -> Maybe Text
$sel:_name:Context :: Context -> Name
_privileged :: Bool
_terminal :: Bool
_interactive :: Bool
_hostname :: Maybe Text
_devices :: Set FilePath
_ro :: Bool
_syscaps :: Set Capability
_mounts :: Map FilePath Volume
_environ :: Map Text Text
_workdir :: Maybe FilePath
_command :: [Text]
_uid :: UserID
_anyUid :: UserID
_selinux :: Bool
_runAs :: Maybe RunAs
_ports :: [Port]
_network :: Bool
_runtimeCtx :: RuntimeContext
_namespace :: Maybe Text
_name :: Name
..} =
  (Capability -> [Text]) -> [Capability] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Capability
c -> [Text
"--cap-add", Capability -> Text
forall b a. (Show a, IsString b) => a -> b
show Capability
c]) ([Capability] -> [Text]) -> [Capability] -> [Text]
forall a b. (a -> b) -> a -> b
$ [Capability] -> [Capability]
forall a. Ord a => [a] -> [a]
sort ([Capability] -> [Capability]) -> [Capability] -> [Capability]
forall a b. (a -> b) -> a -> b
$ Set Capability -> [Capability]
forall a. Set a -> [a]
Data.Set.toList Set Capability
_syscaps

bwrapRunArgs :: RuntimeEnv -> Context -> FilePath -> [String]
bwrapRunArgs :: RuntimeEnv -> Context -> FilePath -> [FilePath]
bwrapRunArgs RuntimeEnv {Bool
FilePath
[Text]
SystemConfig
$sel:extraArgs:RuntimeEnv :: RuntimeEnv -> [Text]
$sel:system:RuntimeEnv :: RuntimeEnv -> SystemConfig
$sel:detach:RuntimeEnv :: RuntimeEnv -> Bool
$sel:verbose:RuntimeEnv :: RuntimeEnv -> Bool
volumesDir :: FilePath
extraArgs :: [Text]
system :: SystemConfig
detach :: Bool
verbose :: Bool
$sel:volumesDir:RuntimeEnv :: RuntimeEnv -> FilePath
..} ctx :: Context
ctx@Context {Bool
[Text]
[Port]
Maybe FilePath
Maybe Text
Maybe RunAs
Map FilePath Volume
Map Text Text
UserID
Set FilePath
Set Capability
Name
RuntimeContext
_privileged :: Bool
_terminal :: Bool
_interactive :: Bool
_hostname :: Maybe Text
_devices :: Set FilePath
_ro :: Bool
_syscaps :: Set Capability
_mounts :: Map FilePath Volume
_environ :: Map Text Text
_workdir :: Maybe FilePath
_command :: [Text]
_uid :: UserID
_anyUid :: UserID
_selinux :: Bool
_runAs :: Maybe RunAs
_ports :: [Port]
_network :: Bool
_runtimeCtx :: RuntimeContext
_namespace :: Maybe Text
_name :: Name
$sel:_privileged:Context :: Context -> Bool
$sel:_terminal:Context :: Context -> Bool
$sel:_interactive:Context :: Context -> Bool
$sel:_hostname:Context :: Context -> Maybe Text
$sel:_devices:Context :: Context -> Set FilePath
$sel:_ro:Context :: Context -> Bool
$sel:_syscaps:Context :: Context -> Set Capability
$sel:_mounts:Context :: Context -> Map FilePath Volume
$sel:_environ:Context :: Context -> Map Text Text
$sel:_workdir:Context :: Context -> Maybe FilePath
$sel:_command:Context :: Context -> [Text]
$sel:_uid:Context :: Context -> UserID
$sel:_anyUid:Context :: Context -> UserID
$sel:_selinux:Context :: Context -> Bool
$sel:_runAs:Context :: Context -> Maybe RunAs
$sel:_ports:Context :: Context -> [Port]
$sel:_network:Context :: Context -> Bool
$sel:_runtimeCtx:Context :: Context -> RuntimeContext
$sel:_namespace:Context :: Context -> Maybe Text
$sel:_name:Context :: Context -> Name
..} FilePath
fp = Text -> FilePath
forall a. ToString a => a -> FilePath
toString (Text -> FilePath) -> [Text] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
args
  where
    userArg :: [Text]
userArg = case Context
ctx Context
-> FoldLike
     (Maybe RunAs) Context Context (Maybe RunAs) (Maybe RunAs)
-> Maybe RunAs
forall s a t b. s -> FoldLike a s t a b -> a
^. FoldLike (Maybe RunAs) Context Context (Maybe RunAs) (Maybe RunAs)
forall (f :: * -> *).
Functor f =>
(Maybe RunAs -> f (Maybe RunAs)) -> Context -> f Context
runAs of
      Just RunAs
RunAsRoot -> [Text
"--unshare-user", Text
"--uid", Text
"0"]
      Just RunAs
RunAsHostUID -> []
      Just RunAs
RunAsAnyUID -> [Text
"--unshare-user", Text
"--uid", UserID -> Text
forall b a. (Show a, IsString b) => a -> b
show (UserID -> Text) -> UserID -> Text
forall a b. (a -> b) -> a -> b
$ Context
ctx Context -> FoldLike UserID Context Context UserID UserID -> UserID
forall s a t b. s -> FoldLike a s t a b -> a
^. FoldLike UserID Context Context UserID UserID
forall (f :: * -> *).
Functor f =>
(UserID -> f UserID) -> Context -> f Context
anyUid]
      Maybe RunAs
Nothing -> []

    networkArg :: [Text]
networkArg
      | Bool
_network = case Maybe Text
_namespace of
          Just Text
"host" -> []
          Just Text
_ns -> Text -> [Text]
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"Shared netns not implemented"
          Maybe Text
Nothing -> [] -- TODO: implement private network namespace
      | Bool
otherwise = [Text
"--unshare-net"]

    volumeArg :: (FilePath, Volume) -> [Text]
    volumeArg :: (FilePath, Volume) -> [Text]
volumeArg (FilePath
destPath, MkVolume Mode
mode VolumeType
vtype) = case VolumeType
vtype of
      HostPath FilePath
hostPath -> [Mode -> Text
volumeMode Mode
mode, FilePath -> Text
forall a. ToText a => a -> Text
toText FilePath
hostPath, FilePath -> Text
forall a. ToText a => a -> Text
toText FilePath
destPath]
      Volume Text
x -> [Mode -> Text
volumeMode Mode
mode, FilePath -> Text
forall a. ToText a => a -> Text
toText (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ FilePath
volumesDir FilePath -> FilePath -> FilePath
</> Text -> FilePath
forall a. ToString a => a -> FilePath
toString Text
x, FilePath -> Text
forall a. ToText a => a -> Text
toText FilePath
destPath]
      VolumeType
TmpFS -> [Text
"--tmpfs", FilePath -> Text
forall a. ToText a => a -> Text
toText FilePath
destPath]
      where
        volumeMode :: Mode -> Text
volumeMode = \case
          Mode
RO -> Text
"--ro-bind"
          Mode
RW -> Text
"--bind"

    rootMounts :: [Text]
rootMounts = case FilePath
fp of
      FilePath
"/" ->
        FilePath -> [Text]
doBind FilePath
"usr"
          [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> FilePath -> [Text]
doBind FilePath
"lib"
          [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> FilePath -> [Text]
doBind FilePath
"lib64"
          [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> FilePath -> [Text]
doBind FilePath
"bin"
          [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> FilePath -> [Text]
doBind FilePath
"sbin"
          [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> FilePath -> [Text]
doBind FilePath
"etc"
      Char
c : FilePath
_ | Char
c Char -> FilePath -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`notElem` [Char
'/', Char
':'] -> FilePath -> Text
forall a. ToText a => a -> Text
toText (FilePath -> Text) -> [FilePath] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FilePath
bindMode, FilePath -> FilePath
forall a. ToString a => a -> FilePath
toString FilePath
volumesDir FilePath -> FilePath -> FilePath
</> FilePath
fp, FilePath
"/"]
      FilePath
_ -> FilePath -> [Text]
doBind FilePath
""

    sysMounts :: [Text]
sysMounts
      | Set FilePath -> Bool
forall a. Set a -> Bool
Data.Set.null Set FilePath
_devices = []
      | Bool
otherwise = [Text
"--ro-bind", Text
"/sys", Text
"/sys"]

    bindMode :: FilePath
bindMode
      | Context
ctx Context -> FoldLike Bool Context Context Bool Bool -> Bool
forall s a t b. s -> FoldLike a s t a b -> a
^. FoldLike Bool Context Context Bool Bool
forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Context -> f Context
ro = FilePath
"--ro-bind"
      | Bool
otherwise = FilePath
"--bind"
    doBind :: FilePath -> [Text]
doBind FilePath
p = FilePath -> Text
forall a. ToText a => a -> Text
toText (FilePath -> Text) -> [FilePath] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FilePath
bindMode, FilePath
fp FilePath -> FilePath -> FilePath
</> FilePath
p, FilePath
"/" FilePath -> FilePath -> FilePath
</> FilePath
p]
    args :: [Text]
args =
      [Text]
userArg
        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
"--die-with-parent", Text
"--unshare-pid", Text
"--unshare-ipc", Text
"--unshare-uts"]
        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
networkArg
        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> Context -> [Text]
commonArgs Context
ctx
        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
rootMounts
        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
"--proc", Text
"/proc"]
        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
"--dev", Text
"/dev"]
        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
"--perms", Text
"01777", Text
"--tmpfs", Text
"/tmp"]
        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> ((FilePath, Volume) -> [Text]) -> [(FilePath, Volume)] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (FilePath, Volume) -> [Text]
volumeArg (Map FilePath Volume -> [(FilePath, Volume)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map FilePath Volume
_mounts)
        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> (FilePath -> [Text]) -> Set FilePath -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\FilePath
d -> [Text
"--dev-bind", FilePath -> Text
forall a. ToText a => a -> Text
toText FilePath
d, FilePath -> Text
forall a. ToText a => a -> Text
toText FilePath
d]) Set FilePath
_devices
        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
sysMounts
        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
"--clearenv"]
        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> ((Text, Text) -> [Text]) -> [(Text, Text)] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Text
k, Text
v) -> [Text
"--setenv", Text -> Text
forall a. ToText a => a -> Text
toText Text
k, Text
v]) (Map Text Text -> [(Text, Text)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map Text Text
_environ)
        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> Bool -> [Text] -> [Text]
forall a. Bool -> [a] -> [a]
cond (Bool -> Bool
not Bool
_terminal) [Text
"--new-session"]
        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text] -> (FilePath -> [Text]) -> Maybe FilePath -> [Text]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\FilePath
wd -> [Text
"--chdir", FilePath -> Text
forall a. ToText a => a -> Text
toText FilePath
wd]) Maybe FilePath
_workdir
        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
_command

showRuntimeCmd :: RuntimeEnv -> Context -> Text
showRuntimeCmd :: RuntimeEnv -> Context -> Text
showRuntimeCmd RuntimeEnv
re Context
ctx = case Context
ctx Context
-> FoldLike
     RuntimeContext Context Context RuntimeContext RuntimeContext
-> RuntimeContext
forall s a t b. s -> FoldLike a s t a b -> a
^. FoldLike
  RuntimeContext Context Context RuntimeContext RuntimeContext
forall (f :: * -> *).
Functor f =>
(RuntimeContext -> f RuntimeContext) -> Context -> f Context
runtimeCtx of
  Container ImageName
image -> ProcessConfig () () () -> Text
forall b a. (Show a, IsString b) => a -> b
show (ProcessConfig () () () -> Text)
-> ([FilePath] -> ProcessConfig () () ()) -> [FilePath] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath] -> ProcessConfig () () ()
P.proc FilePath
"podman" ([FilePath] -> Text) -> [FilePath] -> Text
forall a b. (a -> b) -> a -> b
$ RuntimeEnv -> Context -> ImageName -> [FilePath]
podmanRunArgs RuntimeEnv
re Context
ctx ImageName
image
  Bubblewrap FilePath
fp -> ProcessConfig () () () -> Text
forall b a. (Show a, IsString b) => a -> b
show (ProcessConfig () () () -> Text)
-> ([FilePath] -> ProcessConfig () () ()) -> [FilePath] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath] -> ProcessConfig () () ()
P.proc FilePath
"bwrap" ([FilePath] -> Text) -> [FilePath] -> Text
forall a b. (a -> b) -> a -> b
$ RuntimeEnv -> Context -> FilePath -> [FilePath]
bwrapRunArgs RuntimeEnv
re Context
ctx FilePath
fp

data RuntimeEnv = RuntimeEnv
  { RuntimeEnv -> Bool
verbose :: Bool,
    RuntimeEnv -> Bool
detach :: Bool,
    RuntimeEnv -> SystemConfig
system :: SystemConfig,
    -- | The app argument provided on the command line
    RuntimeEnv -> [Text]
extraArgs :: [Text],
    -- | The host location of the volumes directory, default to ~/.local/share/podenv/volumes
    RuntimeEnv -> FilePath
volumesDir :: FilePath
  }
  deriving (Int -> RuntimeEnv -> FilePath -> FilePath
[RuntimeEnv] -> FilePath -> FilePath
RuntimeEnv -> FilePath
(Int -> RuntimeEnv -> FilePath -> FilePath)
-> (RuntimeEnv -> FilePath)
-> ([RuntimeEnv] -> FilePath -> FilePath)
-> Show RuntimeEnv
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [RuntimeEnv] -> FilePath -> FilePath
$cshowList :: [RuntimeEnv] -> FilePath -> FilePath
show :: RuntimeEnv -> FilePath
$cshow :: RuntimeEnv -> FilePath
showsPrec :: Int -> RuntimeEnv -> FilePath -> FilePath
$cshowsPrec :: Int -> RuntimeEnv -> FilePath -> FilePath
Show)

defaultRuntimeEnv :: FilePath -> RuntimeEnv
defaultRuntimeEnv :: FilePath -> RuntimeEnv
defaultRuntimeEnv = Bool -> Bool -> SystemConfig -> [Text] -> FilePath -> RuntimeEnv
RuntimeEnv Bool
True Bool
False SystemConfig
defaultSystemConfig []

type ContextEnvT a = ReaderT RuntimeEnv IO a

debug :: Text -> ContextEnvT ()
debug :: Text -> ReaderT RuntimeEnv IO ()
debug Text
msg = do
  Bool
isVerbose <- (RuntimeEnv -> Bool) -> ReaderT RuntimeEnv IO Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RuntimeEnv -> Bool
verbose
  Bool -> ReaderT RuntimeEnv IO () -> ReaderT RuntimeEnv IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isVerbose (ReaderT RuntimeEnv IO () -> ReaderT RuntimeEnv IO ())
-> ReaderT RuntimeEnv IO () -> ReaderT RuntimeEnv IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> ReaderT RuntimeEnv IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT RuntimeEnv IO ())
-> IO () -> ReaderT RuntimeEnv IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr (FilePath
"[+] " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
forall a. ToString a => a -> FilePath
toString Text
msg)

cond :: Bool -> [a] -> [a]
cond :: Bool -> [a] -> [a]
cond Bool
b [a]
xs = if Bool
b then [a]
xs else []

infraName :: Text -> Text
infraName :: Text -> Text
infraName Text
ns = Text
ns Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"-ns"

podmanArgs :: Context -> [Text]
podmanArgs :: Context -> [Text]
podmanArgs Context {Bool
[Text]
[Port]
Maybe FilePath
Maybe Text
Maybe RunAs
Map FilePath Volume
Map Text Text
UserID
Set FilePath
Set Capability
Name
RuntimeContext
_privileged :: Bool
_terminal :: Bool
_interactive :: Bool
_hostname :: Maybe Text
_devices :: Set FilePath
_ro :: Bool
_syscaps :: Set Capability
_mounts :: Map FilePath Volume
_environ :: Map Text Text
_workdir :: Maybe FilePath
_command :: [Text]
_uid :: UserID
_anyUid :: UserID
_selinux :: Bool
_runAs :: Maybe RunAs
_ports :: [Port]
_network :: Bool
_runtimeCtx :: RuntimeContext
_namespace :: Maybe Text
_name :: Name
$sel:_privileged:Context :: Context -> Bool
$sel:_terminal:Context :: Context -> Bool
$sel:_interactive:Context :: Context -> Bool
$sel:_hostname:Context :: Context -> Maybe Text
$sel:_devices:Context :: Context -> Set FilePath
$sel:_ro:Context :: Context -> Bool
$sel:_syscaps:Context :: Context -> Set Capability
$sel:_mounts:Context :: Context -> Map FilePath Volume
$sel:_environ:Context :: Context -> Map Text Text
$sel:_workdir:Context :: Context -> Maybe FilePath
$sel:_command:Context :: Context -> [Text]
$sel:_uid:Context :: Context -> UserID
$sel:_anyUid:Context :: Context -> UserID
$sel:_selinux:Context :: Context -> Bool
$sel:_runAs:Context :: Context -> Maybe RunAs
$sel:_ports:Context :: Context -> [Port]
$sel:_network:Context :: Context -> Bool
$sel:_runtimeCtx:Context :: Context -> RuntimeContext
$sel:_namespace:Context :: Context -> Maybe Text
$sel:_name:Context :: Context -> Name
..} = Bool -> [Text] -> [Text]
forall a. Bool -> [a] -> [a]
cond Bool
_interactive [Text
"-i", Text
"--detach-keys", Text
""] [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> Bool -> [Text] -> [Text]
forall a. Bool -> [a] -> [a]
cond Bool
_terminal [Text
"-t"]

podmanRunArgs :: RuntimeEnv -> Context -> ImageName -> [String]
podmanRunArgs :: RuntimeEnv -> Context -> ImageName -> [FilePath]
podmanRunArgs RuntimeEnv {Bool
FilePath
[Text]
SystemConfig
volumesDir :: FilePath
extraArgs :: [Text]
system :: SystemConfig
detach :: Bool
verbose :: Bool
$sel:extraArgs:RuntimeEnv :: RuntimeEnv -> [Text]
$sel:system:RuntimeEnv :: RuntimeEnv -> SystemConfig
$sel:detach:RuntimeEnv :: RuntimeEnv -> Bool
$sel:verbose:RuntimeEnv :: RuntimeEnv -> Bool
$sel:volumesDir:RuntimeEnv :: RuntimeEnv -> FilePath
..} ctx :: Context
ctx@Context {Bool
[Text]
[Port]
Maybe FilePath
Maybe Text
Maybe RunAs
Map FilePath Volume
Map Text Text
UserID
Set FilePath
Set Capability
Name
RuntimeContext
_privileged :: Bool
_terminal :: Bool
_interactive :: Bool
_hostname :: Maybe Text
_devices :: Set FilePath
_ro :: Bool
_syscaps :: Set Capability
_mounts :: Map FilePath Volume
_environ :: Map Text Text
_workdir :: Maybe FilePath
_command :: [Text]
_uid :: UserID
_anyUid :: UserID
_selinux :: Bool
_runAs :: Maybe RunAs
_ports :: [Port]
_network :: Bool
_runtimeCtx :: RuntimeContext
_namespace :: Maybe Text
_name :: Name
$sel:_privileged:Context :: Context -> Bool
$sel:_terminal:Context :: Context -> Bool
$sel:_interactive:Context :: Context -> Bool
$sel:_hostname:Context :: Context -> Maybe Text
$sel:_devices:Context :: Context -> Set FilePath
$sel:_ro:Context :: Context -> Bool
$sel:_syscaps:Context :: Context -> Set Capability
$sel:_mounts:Context :: Context -> Map FilePath Volume
$sel:_environ:Context :: Context -> Map Text Text
$sel:_workdir:Context :: Context -> Maybe FilePath
$sel:_command:Context :: Context -> [Text]
$sel:_uid:Context :: Context -> UserID
$sel:_anyUid:Context :: Context -> UserID
$sel:_selinux:Context :: Context -> Bool
$sel:_runAs:Context :: Context -> Maybe RunAs
$sel:_ports:Context :: Context -> [Port]
$sel:_network:Context :: Context -> Bool
$sel:_runtimeCtx:Context :: Context -> RuntimeContext
$sel:_namespace:Context :: Context -> Maybe Text
$sel:_name:Context :: Context -> Name
..} ImageName
image = Text -> FilePath
forall a. ToString a => a -> FilePath
toString (Text -> FilePath) -> [Text] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
args
  where
    portArgs :: [Text]
portArgs = (Port -> [Text]) -> [Port] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Port -> [Text]
forall a. IsString a => Port -> [a]
publishArg [Port]
_ports
    publishArg :: Port -> [a]
publishArg Port
port = [a
"--publish", Port -> a
forall b. IsString b => Port -> b
showPort Port
port]
    showPort :: Port -> b
showPort Port
port = Natural -> b
forall b a. (Show a, IsString b) => a -> b
show (Natural -> b) -> Natural -> b
forall a b. (a -> b) -> a -> b
$ case Port
port of
      -- podman does not seem to distinguish protocol
      PortTcp Natural
p -> Natural
p
      PortUdp Natural
p -> Natural
p

    hostnameArg :: [Text]
hostnameArg = [Text
"--hostname", Name -> Text
unName Name
_name]
    networkArg :: [Text]
networkArg
      | Bool
_network =
          [Text]
hostnameArg [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> case Maybe Text
_namespace of
            Just Text
"host" -> [Text
"--network", Text
"host"]
            Just Text
ns -> [Text
"--network", Text
"container:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
infraName Text
ns]
            Maybe Text
Nothing -> [Text] -> (Text -> [Text]) -> Maybe Text -> [Text]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Text
dns -> [Text
"--dns=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
dns]) (SystemConfig
system SystemConfig
-> FoldLike
     (Maybe Text) SystemConfig SystemConfig (Maybe Text) (Maybe Text)
-> Maybe Text
forall s a t b. s -> FoldLike a s t a b -> a
^. FoldLike
  (Maybe Text) SystemConfig SystemConfig (Maybe Text) (Maybe Text)
forall (f :: * -> *).
Functor f =>
(Maybe Text -> f (Maybe Text)) -> SystemConfig -> f SystemConfig
sysDns) [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
portArgs
      | Bool
otherwise = [Text
"--network", Text
"none"]

    volumeArg :: (FilePath, Volume) -> [Text]
    volumeArg :: (FilePath, Volume) -> [Text]
volumeArg (FilePath
fp, MkVolume Mode
mode VolumeType
vtype) = case VolumeType
vtype of
      HostPath FilePath
x -> Text -> [Text]
volume (FilePath -> Text
forall a. ToText a => a -> Text
toText FilePath
x)
      Volume Text
x -> Text -> [Text]
volume (FilePath -> Text
forall a. ToText a => a -> Text
toText (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ FilePath
volumesDir FilePath -> FilePath -> FilePath
</> Text -> FilePath
forall a. ToString a => a -> FilePath
toString Text
x)
      VolumeType
TmpFS -> [Text
"--mount", Text
"type=tmpfs,destination=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
forall a. ToText a => a -> Text
toText FilePath
fp]
      where
        volume :: Text -> [Text]
volume Text
hp = [Text
"--volume", Text
hp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
forall a. ToText a => a -> Text
toText FilePath
fp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Mode -> Text
showVolumeMode Mode
mode]
        showVolumeMode :: Mode -> Text
showVolumeMode = \case
          Mode
RO -> Text
":ro"
          Mode
RW -> Text
""

    -- The goal here is to ensure host files created by the container are readable by the host user.
    userArg :: [Text]
userArg = case Context
ctx Context
-> FoldLike
     (Maybe RunAs) Context Context (Maybe RunAs) (Maybe RunAs)
-> Maybe RunAs
forall s a t b. s -> FoldLike a s t a b -> a
^. FoldLike (Maybe RunAs) Context Context (Maybe RunAs) (Maybe RunAs)
forall (f :: * -> *).
Functor f =>
(Maybe RunAs -> f (Maybe RunAs)) -> Context -> f Context
runAs of
      Just RunAs
RunAsRoot -> [Text
"--user", Text
"0"]
      Just RunAs
RunAsHostUID -> [Text
"--user", UserID -> Text
forall b a. (Show a, IsString b) => a -> b
show (Context
ctx Context -> FoldLike UserID Context Context UserID UserID -> UserID
forall s a t b. s -> FoldLike a s t a b -> a
^. FoldLike UserID Context Context UserID UserID
forall (f :: * -> *).
Functor f =>
(UserID -> f UserID) -> Context -> f Context
uid), Text
"--userns", Text
"keep-id"]
      Just RunAs
RunAsAnyUID ->
        let x :: UserID
x = Context
ctx Context -> FoldLike UserID Context Context UserID UserID -> UserID
forall s a t b. s -> FoldLike a s t a b -> a
^. FoldLike UserID Context Context UserID UserID
forall (f :: * -> *).
Functor f =>
(UserID -> f UserID) -> Context -> f Context
anyUid
         in [Text
"--user", UserID -> Text
forall b a. (Show a, IsString b) => a -> b
show UserID
x, Text
"--uidmap", UserID -> Text
forall b a. (Show a, IsString b) => a -> b
show UserID
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":0:1", Text
"--uidmap", Text
"0:1:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> UserID -> Text
forall b a. (Show a, IsString b) => a -> b
show UserID
x]
      Maybe RunAs
Nothing -> []

    nameArg :: [Text]
nameArg = [Text
"--name", Name -> Text
unName Name
_name]

    args :: [Text]
args =
      [Text
"run"]
        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> Context -> [Text]
podmanArgs Context
ctx
        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
"--detach" | Bool
detach]
        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text] -> (Text -> [Text]) -> Maybe Text -> [Text]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Text
h -> [Text
"--hostname", Text
h]) Maybe Text
_hostname
        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> Bool -> [Text] -> [Text]
forall a. Bool -> [a] -> [a]
cond Bool
_privileged [Text
"--privileged"]
        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
"--rm"]
        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> Bool -> [Text] -> [Text]
forall a. Bool -> [a] -> [a]
cond Bool
_ro [Text
"--read-only=true"]
        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> Bool -> [Text] -> [Text]
forall a. Bool -> [a] -> [a]
cond (Bool -> Bool
not Bool
_selinux) [Text
"--security-opt", Text
"label=disable"]
        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
userArg
        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
networkArg
        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> Context -> [Text]
commonArgs Context
ctx
        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> (FilePath -> [Text]) -> Set FilePath -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\FilePath
d -> [Text
"--device", FilePath -> Text
forall a. ToText a => a -> Text
toText FilePath
d]) Set FilePath
_devices
        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text] -> (FilePath -> [Text]) -> Maybe FilePath -> [Text]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\FilePath
wd -> [Text
"--workdir", FilePath -> Text
forall a. ToText a => a -> Text
toText FilePath
wd]) Maybe FilePath
_workdir
        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> ((Text, Text) -> [Text]) -> [(Text, Text)] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Text
k, Text
v) -> [Text
"--env", Text -> Text
forall a. ToText a => a -> Text
toText (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
v]) (Map Text Text -> [(Text, Text)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map Text Text
_environ)
        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> ((FilePath, Volume) -> [Text]) -> [(FilePath, Volume)] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (FilePath, Volume) -> [Text]
volumeArg (Map FilePath Volume -> [(FilePath, Volume)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map FilePath Volume
_mounts)
        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
nameArg
        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [ImageName -> Text
unImageName ImageName
image]
        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
_command

podman :: [String] -> P.ProcessConfig () () ()
podman :: [FilePath] -> ProcessConfig () () ()
podman = Bool -> ProcessConfig () () () -> ProcessConfig () () ()
forall stdin stdout stderr.
Bool
-> ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
P.setDelegateCtlc Bool
True (ProcessConfig () () () -> ProcessConfig () () ())
-> ([FilePath] -> ProcessConfig () () ())
-> [FilePath]
-> ProcessConfig () () ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath] -> ProcessConfig () () ()
P.proc FilePath
"podman"

data PodmanStatus
  = -- | The container does not exists, it needs to be created
    NotFound
  | -- | The container is already running
    Running
  | -- | The container ran and it is now stopped
    Unknown Text
  deriving (Int -> PodmanStatus -> FilePath -> FilePath
[PodmanStatus] -> FilePath -> FilePath
PodmanStatus -> FilePath
(Int -> PodmanStatus -> FilePath -> FilePath)
-> (PodmanStatus -> FilePath)
-> ([PodmanStatus] -> FilePath -> FilePath)
-> Show PodmanStatus
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [PodmanStatus] -> FilePath -> FilePath
$cshowList :: [PodmanStatus] -> FilePath -> FilePath
show :: PodmanStatus -> FilePath
$cshow :: PodmanStatus -> FilePath
showsPrec :: Int -> PodmanStatus -> FilePath -> FilePath
$cshowsPrec :: Int -> PodmanStatus -> FilePath -> FilePath
Show, PodmanStatus -> PodmanStatus -> Bool
(PodmanStatus -> PodmanStatus -> Bool)
-> (PodmanStatus -> PodmanStatus -> Bool) -> Eq PodmanStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PodmanStatus -> PodmanStatus -> Bool
$c/= :: PodmanStatus -> PodmanStatus -> Bool
== :: PodmanStatus -> PodmanStatus -> Bool
$c== :: PodmanStatus -> PodmanStatus -> Bool
Eq)

getPodmanPodStatus :: MonadIO m => Name -> m PodmanStatus
getPodmanPodStatus :: Name -> m PodmanStatus
getPodmanPodStatus (Name Text
cname) = do
  (ExitCode
_, ByteString
stdout', ByteString
_) <- ProcessConfig () () () -> m (ExitCode, ByteString, ByteString)
forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (ExitCode, ByteString, ByteString)
P.readProcess ([FilePath] -> ProcessConfig () () ()
podman [FilePath
"inspect", Text -> FilePath
Text.unpack Text
cname, FilePath
"--format", FilePath
"{{.State.Status}}"])
  PodmanStatus -> m PodmanStatus
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PodmanStatus -> m PodmanStatus) -> PodmanStatus -> m PodmanStatus
forall a b. (a -> b) -> a -> b
$ case ByteString
stdout' of
    ByteString
"" -> PodmanStatus
NotFound
    ByteString
"running\n" -> PodmanStatus
Running
    ByteString
other -> Text -> PodmanStatus
Unknown ((Char -> Bool) -> Text -> Text
Text.dropWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n') (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 ByteString
other)

deletePodmanPod :: MonadIO m => Name -> m ()
deletePodmanPod :: Name -> m ()
deletePodmanPod (Name Text
cname) =
  ProcessConfig () () () -> m ()
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ()
P.runProcess_ ([FilePath] -> ProcessConfig () () ()
podman [FilePath
"rm", Text -> FilePath
forall a. ToString a => a -> FilePath
toString Text
cname])

ensureInfraNet :: Text -> ContextEnvT ()
ensureInfraNet :: Text -> ReaderT RuntimeEnv IO ()
ensureInfraNet Text
ns = do
  Text -> ReaderT RuntimeEnv IO ()
debug (Text -> ReaderT RuntimeEnv IO ())
-> Text -> ReaderT RuntimeEnv IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Ensuring infra net for: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall b a. (Show a, IsString b) => a -> b
show Text
ns
  let pod :: Text
pod = Text -> Text
infraName Text
ns
  PodmanStatus
infraStatus <- Name -> ReaderT RuntimeEnv IO PodmanStatus
forall (m :: * -> *). MonadIO m => Name -> m PodmanStatus
getPodmanPodStatus (Text -> Name
Name Text
pod)
  case PodmanStatus
infraStatus of
    PodmanStatus
Running -> () -> ReaderT RuntimeEnv IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    PodmanStatus
_ -> do
      Bool -> ReaderT RuntimeEnv IO () -> ReaderT RuntimeEnv IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PodmanStatus
infraStatus PodmanStatus -> PodmanStatus -> Bool
forall a. Eq a => a -> a -> Bool
/= PodmanStatus
NotFound) (ReaderT RuntimeEnv IO () -> ReaderT RuntimeEnv IO ())
-> ReaderT RuntimeEnv IO () -> ReaderT RuntimeEnv IO ()
forall a b. (a -> b) -> a -> b
$
        -- Try to delete any left-over infra container
        ProcessConfig () () () -> ReaderT RuntimeEnv IO ()
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ()
P.runProcess_ ([FilePath] -> ProcessConfig () () ()
podman [FilePath
"rm", Text -> FilePath
forall a. ToString a => a -> FilePath
toString Text
pod])

      SystemConfig
system' <- (RuntimeEnv -> SystemConfig) -> ReaderT RuntimeEnv IO SystemConfig
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks RuntimeEnv -> SystemConfig
system
      let cmd :: ProcessConfig () () ()
cmd =
            [FilePath] -> ProcessConfig () () ()
podman ([FilePath] -> ProcessConfig () () ())
-> [FilePath] -> ProcessConfig () () ()
forall a b. (a -> b) -> a -> b
$
              (Text -> FilePath) -> [Text] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Text -> FilePath
forall a. ToString a => a -> FilePath
toString ([Text] -> [FilePath]) -> [Text] -> [FilePath]
forall a b. (a -> b) -> a -> b
$
                [Text
"run", Text
"--rm", Text
"--name", Text
pod]
                  [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
"--detach"]
                  [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text] -> (Text -> [Text]) -> Maybe Text -> [Text]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Text
dns -> [Text
"--dns=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
dns]) (SystemConfig
system' SystemConfig
-> FoldLike
     (Maybe Text) SystemConfig SystemConfig (Maybe Text) (Maybe Text)
-> Maybe Text
forall s a t b. s -> FoldLike a s t a b -> a
^. FoldLike
  (Maybe Text) SystemConfig SystemConfig (Maybe Text) (Maybe Text)
forall (f :: * -> *).
Functor f =>
(Maybe Text -> f (Maybe Text)) -> SystemConfig -> f SystemConfig
sysDns)
                  [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
"ubi8"]
                  [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
"sleep", Text
"infinity"]
      Text -> ReaderT RuntimeEnv IO ()
debug (Text -> ReaderT RuntimeEnv IO ())
-> Text -> ReaderT RuntimeEnv IO ()
forall a b. (a -> b) -> a -> b
$ ProcessConfig () () () -> Text
forall b a. (Show a, IsString b) => a -> b
show ProcessConfig () () ()
cmd
      ProcessConfig () () () -> ReaderT RuntimeEnv IO ()
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ()
P.runProcess_ ProcessConfig () () ()
cmd

executePodman :: Context -> ImageName -> ContextEnvT ()
executePodman :: Context -> ImageName -> ReaderT RuntimeEnv IO ()
executePodman Context
ctx ImageName
image = do
  RuntimeEnv
re <- ReaderT RuntimeEnv IO RuntimeEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
  case (Context
ctx Context
-> FoldLike (Maybe Text) Context Context (Maybe Text) (Maybe Text)
-> Maybe Text
forall s a t b. s -> FoldLike a s t a b -> a
^. FoldLike (Maybe Text) Context Context (Maybe Text) (Maybe Text)
forall (f :: * -> *).
Functor f =>
(Maybe Text -> f (Maybe Text)) -> Context -> f Context
namespace, Context
ctx Context -> FoldLike Bool Context Context Bool Bool -> Bool
forall s a t b. s -> FoldLike a s t a b -> a
^. FoldLike Bool Context Context Bool Bool
forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Context -> f Context
network) of
    (Just Text
ns, Bool
True) | Text
ns Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
forall a. Monoid a => a
mempty -> Text -> ReaderT RuntimeEnv IO ()
ensureInfraNet Text
ns
    (Maybe Text, Bool)
_ -> () -> ReaderT RuntimeEnv IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  PodmanStatus
status <- Name -> ReaderT RuntimeEnv IO PodmanStatus
forall (m :: * -> *). MonadIO m => Name -> m PodmanStatus
getPodmanPodStatus (Context
ctx Context -> FoldLike Name Context Context Name Name -> Name
forall s a t b. s -> FoldLike a s t a b -> a
^. FoldLike Name Context Context Name Name
forall (f :: * -> *).
Functor f =>
(Name -> f Name) -> Context -> f Context
name)
  Text -> ReaderT RuntimeEnv IO ()
debug (Text -> ReaderT RuntimeEnv IO ())
-> Text -> ReaderT RuntimeEnv IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Podman status of " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PodmanStatus -> Text
forall b a. (Show a, IsString b) => a -> b
show PodmanStatus
status
  let cfail :: Text -> m a
cfail Text
err = IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> (Text -> IO a) -> Text -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either Text a -> IO a
forall a. Either Text a -> IO a
mayFail (Either Text a -> IO a) -> (Text -> Either Text a) -> Text -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text a
forall a b. a -> Either a b
Left (Text -> m a) -> Text -> m a
forall a b. (a -> b) -> a -> b
$ Text
cname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err
  [FilePath]
args <-
    case PodmanStatus
status of
      PodmanStatus
NotFound -> [FilePath] -> ReaderT RuntimeEnv IO [FilePath]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([FilePath] -> ReaderT RuntimeEnv IO [FilePath])
-> [FilePath] -> ReaderT RuntimeEnv IO [FilePath]
forall a b. (a -> b) -> a -> b
$ RuntimeEnv -> Context -> ImageName -> [FilePath]
podmanRunArgs RuntimeEnv
re Context
ctx ImageName
image
      PodmanStatus
Running -> Text -> ReaderT RuntimeEnv IO [FilePath]
forall (m :: * -> *) a. MonadIO m => Text -> m a
cfail Text
"container is already running, use `exec` to join, or `--name new` to start a new instance"
      Unknown Text
_ -> RuntimeEnv -> ReaderT RuntimeEnv IO [FilePath]
forall (m :: * -> *). MonadIO m => RuntimeEnv -> m [FilePath]
recreateContainer RuntimeEnv
re
  let cmd :: ProcessConfig () () ()
cmd = [FilePath] -> ProcessConfig () () ()
podman [FilePath]
args
  Text -> ReaderT RuntimeEnv IO ()
debug (Text -> ReaderT RuntimeEnv IO ())
-> Text -> ReaderT RuntimeEnv IO ()
forall a b. (a -> b) -> a -> b
$ ProcessConfig () () () -> Text
forall b a. (Show a, IsString b) => a -> b
show ProcessConfig () () ()
cmd
  ProcessConfig () () () -> ReaderT RuntimeEnv IO ()
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ()
P.runProcess_ ProcessConfig () () ()
cmd
  where
    cname :: Text
cname = Name -> Text
unName (Name -> Text) -> Name -> Text
forall a b. (a -> b) -> a -> b
$ Context
ctx Context -> FoldLike Name Context Context Name Name -> Name
forall s a t b. s -> FoldLike a s t a b -> a
^. FoldLike Name Context Context Name Name
forall (f :: * -> *).
Functor f =>
(Name -> f Name) -> Context -> f Context
name
    -- Delete a non-kept container and return the run args
    recreateContainer :: RuntimeEnv -> m [FilePath]
recreateContainer RuntimeEnv
re = do
      Name -> m ()
forall (m :: * -> *). MonadIO m => Name -> m ()
deletePodmanPod (Context
ctx Context -> FoldLike Name Context Context Name Name -> Name
forall s a t b. s -> FoldLike a s t a b -> a
^. FoldLike Name Context Context Name Name
forall (f :: * -> *).
Functor f =>
(Name -> f Name) -> Context -> f Context
name)
      [FilePath] -> m [FilePath]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([FilePath] -> m [FilePath]) -> [FilePath] -> m [FilePath]
forall a b. (a -> b) -> a -> b
$ RuntimeEnv -> Context -> ImageName -> [FilePath]
podmanRunArgs RuntimeEnv
re Context
ctx ImageName
image