{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_GHC -fno-warn-missing-export-lists #-}
module Podenv.Application
( prepare,
preparePure,
capsAll,
Cap (..),
Mode (..),
)
where
import Data.Map qualified
import Data.Set qualified as Set
import Data.Text qualified as Text
import Podenv.Build qualified
import Podenv.Dhall
import Podenv.Env
import Podenv.Prelude
import Podenv.Runtime qualified as Ctx
import System.Posix.Files qualified
data Mode = Regular | Shell
prepare :: Mode -> Application -> Ctx.Name -> IO Ctx.Context
prepare :: Mode -> Application -> Name -> IO Context
prepare Mode
mode Application
app Name
ctxName = do
AppEnv
appEnv <- IO AppEnv
Podenv.Env.new
Mode -> AppEnv -> Application -> Name -> IO Context
preparePure Mode
mode AppEnv
appEnv Application
app Name
ctxName
preparePure :: Mode -> AppEnv -> Application -> Ctx.Name -> IO Ctx.Context
preparePure :: Mode -> AppEnv -> Application -> Name -> IO Context
preparePure Mode
mode AppEnv
envBase Application
app Name
ctxName = do
Maybe Text
home <- IO (Maybe Text)
getContainerHome
ReaderT AppEnv IO Context -> AppEnv -> IO Context
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Application
-> Mode -> Name -> Maybe Text -> ReaderT AppEnv IO Context
doPrepare Application
app Mode
mode Name
ctxName Maybe Text
home) (Maybe Text -> AppEnv
forall a. ToString a => Maybe a -> AppEnv
appEnv Maybe Text
home)
where
appEnv :: Maybe a -> AppEnv
appEnv Maybe a
home = AppEnv
envBase AppEnv -> (AppEnv -> AppEnv) -> AppEnv
forall a b. a -> (a -> b) -> b
& (Maybe FilePath -> Identity (Maybe FilePath))
-> AppEnv -> Identity AppEnv
forall (f :: * -> *).
Functor f =>
(Maybe FilePath -> f (Maybe FilePath)) -> AppEnv -> f AppEnv
appHomeDir ((Maybe FilePath -> Identity (Maybe FilePath))
-> AppEnv -> Identity AppEnv)
-> Maybe FilePath -> AppEnv -> AppEnv
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (a -> FilePath
forall a. ToString a => a -> FilePath
toString (a -> FilePath) -> Maybe a -> Maybe FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe a
home)
getContainerHome :: IO (Maybe Text)
getContainerHome
| Application
app Application
-> FoldLike Bool Application Application Bool Bool -> Bool
forall s a t b. s -> FoldLike a s t a b -> a
^. (Capabilities -> Constant Bool Capabilities)
-> Application -> Constant Bool Application
forall (f :: * -> *).
Functor f =>
(Capabilities -> f Capabilities) -> Application -> f Application
appCapabilities ((Capabilities -> Constant Bool Capabilities)
-> Application -> Constant Bool Application)
-> ((Bool -> Constant Bool Bool)
-> Capabilities -> Constant Bool Capabilities)
-> FoldLike Bool Application Application Bool Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Constant Bool Bool)
-> Capabilities -> Constant Bool Capabilities
forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Capabilities -> f Capabilities
capRoot = Maybe Text -> IO (Maybe Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> IO (Maybe Text)) -> Maybe Text -> IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"/root"
| Bool
otherwise = case Application
app Application
-> FoldLike Runtime Application Application Runtime Runtime
-> Runtime
forall s a t b. s -> FoldLike a s t a b -> a
^. FoldLike Runtime Application Application Runtime Runtime
forall (f :: * -> *).
Functor f =>
(Runtime -> f Runtime) -> Application -> f Application
appRuntime of
Container ContainerBuild
cb -> Maybe Text -> IO (Maybe Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> IO (Maybe Text)) -> Maybe Text -> IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ ContainerBuild
cb ContainerBuild
-> FoldLike
(Maybe Text)
ContainerBuild
ContainerBuild
(Maybe Text)
(Maybe Text)
-> Maybe Text
forall s a t b. s -> FoldLike a s t a b -> a
^. FoldLike
(Maybe Text)
ContainerBuild
ContainerBuild
(Maybe Text)
(Maybe Text)
forall (f :: * -> *).
Functor f =>
(Maybe Text -> f (Maybe Text))
-> ContainerBuild -> f ContainerBuild
cbImage_home
Rootfs Text
fp -> (FilePath -> Text) -> Maybe FilePath -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> Text
forall a. ToText a => a -> Text
toText (Maybe FilePath -> Maybe Text)
-> IO (Maybe FilePath) -> IO (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (AppEnv
envBase AppEnv
-> FoldLike
(FilePath -> IO (Maybe FilePath))
AppEnv
AppEnv
(FilePath -> IO (Maybe FilePath))
(FilePath -> IO (Maybe FilePath))
-> FilePath
-> IO (Maybe FilePath)
forall s a t b. s -> FoldLike a s t a b -> a
^. FoldLike
(FilePath -> IO (Maybe FilePath))
AppEnv
AppEnv
(FilePath -> IO (Maybe FilePath))
(FilePath -> IO (Maybe FilePath))
forall (f :: * -> *).
Functor f =>
((FilePath -> IO (Maybe FilePath))
-> f (FilePath -> IO (Maybe FilePath)))
-> AppEnv -> f AppEnv
rootfsHome) (Text -> FilePath
forall a. ToString a => a -> FilePath
toString Text
fp)
Nix Flakes
_ -> Maybe Text -> IO (Maybe Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> IO (Maybe Text)) -> Maybe Text -> IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
forall a. ToText a => a -> Text
toText (FilePath -> Text) -> Maybe FilePath -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AppEnv
envBase AppEnv
-> FoldLike
(Maybe FilePath) AppEnv AppEnv (Maybe FilePath) (Maybe FilePath)
-> Maybe FilePath
forall s a t b. s -> FoldLike a s t a b -> a
^. FoldLike
(Maybe FilePath) AppEnv AppEnv (Maybe FilePath) (Maybe FilePath)
forall (f :: * -> *).
Functor f =>
(Maybe FilePath -> f (Maybe FilePath)) -> AppEnv -> f AppEnv
hostHomeDir
Image Text
_ -> Maybe Text -> IO (Maybe Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
forall a. Maybe a
Nothing
doPrepare :: Application -> Mode -> Ctx.Name -> Maybe Text -> AppEnvT Ctx.Context
doPrepare :: Application
-> Mode -> Name -> Maybe Text -> ReaderT AppEnv IO Context
doPrepare Application
app Mode
mode Name
ctxName Maybe Text
appHome = do
UserID
uid <- (AppEnv -> UserID) -> ReaderT AppEnv IO UserID
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks AppEnv -> UserID
_hostUid
let baseCtx :: Context
baseCtx =
(Name -> RuntimeContext -> Context
Ctx.defaultContext Name
ctxName RuntimeContext
runtimeCtx)
{ $sel:_uid:Context :: UserID
Ctx._uid = UserID
uid,
$sel:_namespace:Context :: Maybe Text
Ctx._namespace = Application
app Application
-> FoldLike
(Maybe Text) Application Application (Maybe Text) (Maybe Text)
-> Maybe Text
forall s a t b. s -> FoldLike a s t a b -> a
^. FoldLike
(Maybe Text) Application Application (Maybe Text) (Maybe Text)
forall (f :: * -> *).
Functor f =>
(Maybe Text -> f (Maybe Text)) -> Application -> f Application
appNamespace
}
Context
ctx <-
(Context -> Text -> ReaderT AppEnv IO Context)
-> Context -> [Text] -> ReaderT AppEnv IO Context
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Context -> Text -> ReaderT AppEnv IO Context
addVolume Context
baseCtx (Application
app Application
-> FoldLike [Text] Application Application [Text] [Text] -> [Text]
forall s a t b. s -> FoldLike a s t a b -> a
^. FoldLike [Text] Application Application [Text] [Text]
forall (f :: * -> *).
Functor f =>
([Text] -> f [Text]) -> Application -> f Application
appVolumes)
ReaderT AppEnv IO Context
-> (Context -> ReaderT AppEnv IO Context)
-> ReaderT AppEnv IO Context
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Context -> [Cap] -> ReaderT AppEnv IO Context)
-> [Cap] -> Context -> ReaderT AppEnv IO Context
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Context -> Cap -> ReaderT AppEnv IO Context)
-> Context -> [Cap] -> ReaderT AppEnv IO Context
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Context -> Cap -> ReaderT AppEnv IO Context
setCaps) [Cap]
capsAll
Context -> Context
setCommand <- case Mode
mode of
Mode
Regular ->
if Application
app Application
-> FoldLike Bool Application Application Bool Bool -> Bool
forall s a t b. s -> FoldLike a s t a b -> a
^. (Capabilities -> Constant Bool Capabilities)
-> Application -> Constant Bool Application
forall (f :: * -> *).
Functor f =>
(Capabilities -> f Capabilities) -> Application -> f Application
appCapabilities ((Capabilities -> Constant Bool Capabilities)
-> Application -> Constant Bool Application)
-> ((Bool -> Constant Bool Bool)
-> Capabilities -> Constant Bool Capabilities)
-> FoldLike Bool Application Application Bool Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Constant Bool Bool)
-> Capabilities -> Constant Bool Capabilities
forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Capabilities -> f Capabilities
capHostfile
then [Text] -> ReaderT AppEnv IO (Context -> Context)
resolveFileArgs ([Text] -> ReaderT AppEnv IO (Context -> Context))
-> [Text] -> ReaderT AppEnv IO (Context -> Context)
forall a b. (a -> b) -> a -> b
$ Application
app Application
-> FoldLike [Text] Application Application [Text] [Text] -> [Text]
forall s a t b. s -> FoldLike a s t a b -> a
^. FoldLike [Text] Application Application [Text] [Text]
forall (f :: * -> *).
Functor f =>
([Text] -> f [Text]) -> Application -> f Application
appCommand
else (Context -> Context) -> ReaderT AppEnv IO (Context -> Context)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Context -> Context) -> ReaderT AppEnv IO (Context -> Context))
-> (Context -> Context) -> ReaderT AppEnv IO (Context -> Context)
forall a b. (a -> b) -> a -> b
$ ([Text] -> Identity [Text]) -> Context -> Identity Context
forall (f :: * -> *).
Functor f =>
([Text] -> f [Text]) -> Context -> f Context
Ctx.command (([Text] -> Identity [Text]) -> Context -> Identity Context)
-> [Text] -> Context -> Context
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Application
app Application
-> FoldLike [Text] Application Application [Text] [Text] -> [Text]
forall s a t b. s -> FoldLike a s t a b -> a
^. FoldLike [Text] Application Application [Text] [Text]
forall (f :: * -> *).
Functor f =>
([Text] -> f [Text]) -> Application -> f Application
appCommand
Mode
Shell -> (Context -> Context) -> ReaderT AppEnv IO (Context -> Context)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Context -> Context) -> ReaderT AppEnv IO (Context -> Context))
-> (Context -> Context) -> ReaderT AppEnv IO (Context -> Context)
forall a b. (a -> b) -> a -> b
$ ([Text] -> Identity [Text]) -> Context -> Identity Context
forall (f :: * -> *).
Functor f =>
([Text] -> f [Text]) -> Context -> f Context
Ctx.command (([Text] -> Identity [Text]) -> Context -> Identity Context)
-> [Text] -> Context -> Context
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Text
"/bin/sh"]
Context -> ReaderT AppEnv IO Context
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Context -> Context
validate (Context -> Context) -> (Context -> Context) -> Context -> Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context -> Context
setCommand (Context -> Context) -> (Context -> Context) -> Context -> Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context -> Context
modifiers (Context -> Context) -> Context -> Context
forall a b. (a -> b) -> a -> b
$ Context
ctx)
where
runtimeCtx :: RuntimeContext
runtimeCtx = case Application
app Application
-> FoldLike Runtime Application Application Runtime Runtime
-> Runtime
forall s a t b. s -> FoldLike a s t a b -> a
^. FoldLike Runtime Application Application Runtime Runtime
forall (f :: * -> *).
Functor f =>
(Runtime -> f Runtime) -> Application -> f Application
appRuntime of
Image Text
x -> ImageName -> RuntimeContext
Ctx.Container (ImageName -> RuntimeContext) -> ImageName -> RuntimeContext
forall a b. (a -> b) -> a -> b
$ Text -> ImageName
Ctx.ImageName Text
x
Rootfs Text
root -> FilePath -> RuntimeContext
Ctx.Bubblewrap (FilePath -> RuntimeContext) -> FilePath -> RuntimeContext
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
forall a. ToString a => a -> FilePath
toString Text
root
Container ContainerBuild
cb -> ContainerBuild -> RuntimeContext
Podenv.Build.containerBuildRuntime ContainerBuild
cb
Nix Flakes
_ -> RuntimeContext
Podenv.Build.nixRuntime
validate :: Context -> Context
validate Context
ctx = case RuntimeContext
runtimeCtx of
Ctx.Bubblewrap FilePath
_ | [Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Context
ctx Context -> FoldLike [Text] Context Context [Text] [Text] -> [Text]
forall s a t b. s -> FoldLike a s t a b -> a
^. FoldLike [Text] Context Context [Text] [Text]
forall (f :: * -> *).
Functor f =>
([Text] -> f [Text]) -> Context -> f Context
Ctx.command) -> Context
ctx Context -> (Context -> Context) -> Context
forall a b. a -> (a -> b) -> b
& ([Text] -> Identity [Text]) -> Context -> Identity Context
forall (f :: * -> *).
Functor f =>
([Text] -> f [Text]) -> Context -> f Context
Ctx.command (([Text] -> Identity [Text]) -> Context -> Identity Context)
-> [Text] -> Context -> Context
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Text
"/bin/sh"]
RuntimeContext
_ -> Context
ctx
modifiers :: Ctx.Context -> Ctx.Context
modifiers :: Context -> Context
modifiers = Context -> Context
disableSelinux (Context -> Context) -> (Context -> Context) -> Context -> Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context -> Context
setRunAs (Context -> Context) -> (Context -> Context) -> Context -> Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context -> Context
addSysCaps (Context -> Context) -> (Context -> Context) -> Context -> Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context -> Context
addEnvs (Context -> Context) -> (Context -> Context) -> Context -> Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context -> Context
setEnv (Context -> Context) -> (Context -> Context) -> Context -> Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context -> Context
ensureWorkdir (Context -> Context) -> (Context -> Context) -> Context -> Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context -> Context
ensureHome
ensureHome :: Context -> Context
ensureHome = case Maybe Text
appHome of
Just Text
fp ->
let volumeName :: Text
volumeName = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe (Name -> Text
Ctx.unName Name
ctxName) (Application
app Application
-> FoldLike
(Maybe Text) Application Application (Maybe Text) (Maybe Text)
-> Maybe Text
forall s a t b. s -> FoldLike a s t a b -> a
^. FoldLike
(Maybe Text) Application Application (Maybe Text) (Maybe Text)
forall (f :: * -> *).
Functor f =>
(Maybe Text -> f (Maybe Text)) -> Application -> f Application
appNamespace)
in FilePath -> Volume -> Context -> Context
Ctx.addMount (Text -> FilePath
forall a. ToString a => a -> FilePath
toString Text
fp) (Mode -> VolumeType -> Volume
Ctx.MkVolume Mode
Ctx.RW (Text -> VolumeType
Ctx.Volume (Text -> VolumeType) -> Text -> VolumeType
forall a b. (a -> b) -> a -> b
$ Text
volumeName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"-home"))
Maybe Text
Nothing -> Context -> Context
forall a. a -> a
id
isMounted :: FilePath -> Ctx.Context -> Bool
isMounted :: FilePath -> Context -> Bool
isMounted FilePath
fp Context
ctx = (FilePath -> Bool) -> [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any FilePath -> Bool
isPrefix [FilePath]
mountPaths
where
mountPaths :: [FilePath]
mountPaths = Map FilePath Volume -> [FilePath]
forall k a. Map k a -> [k]
Data.Map.keys (Map FilePath Volume -> [FilePath])
-> Map FilePath Volume -> [FilePath]
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
Ctx.mounts
isPrefix :: FilePath -> Bool
isPrefix FilePath
x = FilePath
fp FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
x
ensureWorkdir :: Context -> Context
ensureWorkdir Context
ctx = case Maybe Text
appHome of
(Just Text
x) | FilePath -> Context -> Bool
isMounted (Text -> FilePath
forall a. ToString a => a -> FilePath
toString Text
x) Context
ctx -> Context
ctx Context -> (Context -> Context) -> Context
forall a b. a -> (a -> b) -> b
& (Maybe FilePath -> Identity (Maybe FilePath))
-> Context -> Identity Context
forall (f :: * -> *).
Functor f =>
(Maybe FilePath -> f (Maybe FilePath)) -> Context -> f Context
Ctx.workdir ((Maybe FilePath -> Identity (Maybe FilePath))
-> Context -> Identity Context)
-> FilePath -> Context -> Context
forall s t b. ASetter s t (Maybe b) (Maybe b) -> b -> s -> t
`setWhenNothing` Text -> FilePath
forall a. ToString a => a -> FilePath
toString Text
x
Maybe Text
_ -> Context
ctx
setEnv :: Context -> Context
setEnv = case Maybe Text
appHome of
Just Text
x -> Text -> Text -> Context -> Context
Ctx.addEnv Text
"HOME" Text
x
Maybe Text
_ -> Context -> Context
forall a. a -> a
id
noSelinuxCaps :: [(Bool -> Constant Bool Bool)
-> Capabilities -> Constant Bool Capabilities]
noSelinuxCaps = [(Bool -> Constant Bool Bool)
-> Capabilities -> Constant Bool Capabilities
forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Capabilities -> f Capabilities
capWayland, (Bool -> Constant Bool Bool)
-> Capabilities -> Constant Bool Capabilities
forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Capabilities -> f Capabilities
capX11]
hasPrivCap :: Bool
hasPrivCap = (((Bool -> Constant Bool Bool)
-> Capabilities -> Constant Bool Capabilities)
-> Bool)
-> [(Bool -> Constant Bool Bool)
-> Capabilities -> Constant Bool Capabilities]
-> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(Bool -> Constant Bool Bool)
-> Capabilities -> Constant Bool Capabilities
l -> Application
app Application
-> FoldLike Bool Application Application Bool Bool -> Bool
forall s a t b. s -> FoldLike a s t a b -> a
^. (Capabilities -> Constant Bool Capabilities)
-> Application -> Constant Bool Application
forall (f :: * -> *).
Functor f =>
(Capabilities -> f Capabilities) -> Application -> f Application
appCapabilities ((Capabilities -> Constant Bool Capabilities)
-> Application -> Constant Bool Application)
-> ((Bool -> Constant Bool Bool)
-> Capabilities -> Constant Bool Capabilities)
-> FoldLike Bool Application Application Bool Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Constant Bool Bool)
-> Capabilities -> Constant Bool Capabilities
l) [(Bool -> Constant Bool Bool)
-> Capabilities -> Constant Bool Capabilities]
noSelinuxCaps
hasDevice :: Context -> Bool
hasDevice Context
ctx = Context
ctx Context
-> FoldLike
(Set FilePath) Context Context (Set FilePath) (Set FilePath)
-> Set FilePath
forall s a t b. s -> FoldLike a s t a b -> a
^. FoldLike
(Set FilePath) Context Context (Set FilePath) (Set FilePath)
forall (f :: * -> *).
Functor f =>
(Set FilePath -> f (Set FilePath)) -> Context -> f Context
Ctx.devices Set FilePath -> Set FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= Set FilePath
forall a. Monoid a => a
mempty
isHostPath :: Volume -> Bool
isHostPath = \case
Ctx.MkVolume Mode
_ (Ctx.HostPath FilePath
_) -> Bool
True
Volume
_anyOtherVolume -> Bool
False
hasHostPath :: Context -> Bool
hasHostPath Context
ctx = (Volume -> Bool) -> [Volume] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Volume -> Bool
isHostPath (Map FilePath Volume -> [Volume]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (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
Ctx.mounts)
disableSelinux :: Context -> Context
disableSelinux Context
ctx
| Bool
hasPrivCap Bool -> Bool -> Bool
|| Context -> Bool
hasDevice Context
ctx Bool -> Bool -> Bool
|| Context -> Bool
hasHostPath Context
ctx = Context
ctx Context -> (Context -> Context) -> Context
forall a b. a -> (a -> b) -> b
& (Bool -> Identity Bool) -> Context -> Identity Context
forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Context -> f Context
Ctx.selinux ((Bool -> Identity Bool) -> Context -> Identity Context)
-> Bool -> Context -> Context
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
False
| Bool
otherwise = Context
ctx
setRunAs :: Context -> Context
setRunAs = case Maybe Text
appHome of
Just Text
h | Text
"/home" Text -> Text -> Bool
`Text.isPrefixOf` Text
h -> (Maybe RunAs -> Identity (Maybe RunAs))
-> Context -> Identity Context
forall (f :: * -> *).
Functor f =>
(Maybe RunAs -> f (Maybe RunAs)) -> Context -> f Context
Ctx.runAs ((Maybe RunAs -> Identity (Maybe RunAs))
-> Context -> Identity Context)
-> RunAs -> Context -> Context
forall s t b. ASetter s t (Maybe b) (Maybe b) -> b -> s -> t
`setWhenNothing` RunAs
Ctx.RunAsHostUID
Maybe Text
_ -> Context -> Context
forall a. a -> a
id
addSysCaps :: Context -> Context
addSysCaps Context
ctx = (Text -> Context -> Context) -> Context -> [Text] -> Context
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Text -> Context -> Context
addSysCap Context
ctx (Application
app Application
-> FoldLike [Text] Application Application [Text] [Text] -> [Text]
forall s a t b. s -> FoldLike a s t a b -> a
^. FoldLike [Text] Application Application [Text] [Text]
forall (f :: * -> *).
Functor f =>
([Text] -> f [Text]) -> Application -> f Application
appSyscaps)
addSysCap :: Text -> Ctx.Context -> Ctx.Context
addSysCap :: Text -> Context -> Context
addSysCap Text
syscap = case FilePath -> Maybe Capability
forall a. Read a => FilePath -> Maybe a
readMaybe (Text -> FilePath
forall a. ToString a => a -> FilePath
toString (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ Text
"CAP_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
syscap) of
Maybe Capability
Nothing -> Text -> Context -> Context
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> Context -> Context) -> Text -> Context -> Context
forall a b. (a -> b) -> a -> b
$ Text
"Can't read syscap: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall b a. (Show a, IsString b) => a -> b
show Text
syscap
Just Capability
c -> (Set Capability -> Identity (Set Capability))
-> Context -> Identity Context
forall (f :: * -> *).
Functor f =>
(Set Capability -> f (Set Capability)) -> Context -> f Context
Ctx.syscaps ((Set Capability -> Identity (Set Capability))
-> Context -> Identity Context)
-> (Set Capability -> Set Capability) -> Context -> Context
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Capability -> Set Capability -> Set Capability
forall a. Ord a => a -> Set a -> Set a
Set.insert Capability
c)
addEnvs :: Context -> Context
addEnvs Context
ctx = (Text -> Context -> Context) -> Context -> [Text] -> Context
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Text -> Context -> Context
addEnv Context
ctx (Application
app Application
-> FoldLike [Text] Application Application [Text] [Text] -> [Text]
forall s a t b. s -> FoldLike a s t a b -> a
^. FoldLike [Text] Application Application [Text] [Text]
forall (f :: * -> *).
Functor f =>
([Text] -> f [Text]) -> Application -> f Application
appEnviron)
addEnv :: Text -> Ctx.Context -> Ctx.Context
addEnv :: Text -> Context -> Context
addEnv Text
env =
let (Text
k, Text
v) = Text -> Text -> (Text, Text)
Text.breakOn Text
"=" Text
env
in Text -> Text -> Context -> Context
Ctx.addEnv Text
k (Int -> Text -> Text
Text.drop Int
1 Text
v)
setCaps :: Context -> Cap -> ReaderT AppEnv IO Context
setCaps = Capabilities -> Context -> Cap -> ReaderT AppEnv IO Context
capContextApply (Capabilities -> Context -> Cap -> ReaderT AppEnv IO Context)
-> Capabilities -> Context -> Cap -> ReaderT AppEnv IO Context
forall a b. (a -> b) -> a -> b
$ Application
app Application
-> FoldLike
Capabilities Application Application Capabilities Capabilities
-> Capabilities
forall s a t b. s -> FoldLike a s t a b -> a
^. FoldLike
Capabilities Application Application Capabilities Capabilities
forall (f :: * -> *).
Functor f =>
(Capabilities -> f Capabilities) -> Application -> f Application
appCapabilities
capContextApply :: Capabilities -> Ctx.Context -> Cap -> AppEnvT Ctx.Context
capContextApply :: Capabilities -> Context -> Cap -> ReaderT AppEnv IO Context
capContextApply Capabilities
appCaps Context
ctx Cap {Text
Context -> ReaderT AppEnv IO Context
forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Capabilities -> f Capabilities
$sel:capSet:Cap :: Cap -> Context -> ReaderT AppEnv IO Context
$sel:capLens:Cap :: Cap
-> forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Capabilities -> f Capabilities
$sel:capDescription:Cap :: Cap -> Text
$sel:capName:Cap :: Cap -> Text
capSet :: Context -> ReaderT AppEnv IO Context
capLens :: forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Capabilities -> f Capabilities
capDescription :: Text
capName :: Text
..} =
if Capabilities
appCaps Capabilities
-> ((Bool -> Constant Bool Bool)
-> Capabilities -> Constant Bool Capabilities)
-> Bool
forall s a t b. s -> FoldLike a s t a b -> a
^. (Bool -> Constant Bool Bool)
-> Capabilities -> Constant Bool Capabilities
forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Capabilities -> f Capabilities
capLens
then Context -> ReaderT AppEnv IO Context
capSet Context
ctx
else Context -> ReaderT AppEnv IO Context
forall (f :: * -> *) a. Applicative f => a -> f a
pure Context
ctx
data Cap = Cap
{ Cap -> Text
capName :: Text,
Cap -> Text
capDescription :: Text,
Cap
-> forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Capabilities -> f Capabilities
capLens :: Lens' Capabilities Bool,
Cap -> Context -> ReaderT AppEnv IO Context
capSet :: Ctx.Context -> AppEnvT Ctx.Context
}
capsAll, capsToggle :: [Cap]
capsAll :: [Cap]
capsAll = [Cap]
capsToggle
capsToggle :: [Cap]
capsToggle =
[ Text
-> Text
-> (forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Capabilities -> f Capabilities)
-> (Context -> ReaderT AppEnv IO Context)
-> Cap
Cap Text
"root" Text
"run as root" forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Capabilities -> f Capabilities
capRoot ((forall (f :: * -> *).
Functor f =>
(Maybe RunAs -> f (Maybe RunAs)) -> Context -> f Context)
-> Maybe RunAs -> Context -> ReaderT AppEnv IO Context
forall a.
Lens' Context a -> a -> Context -> ReaderT AppEnv IO Context
contextSet forall (f :: * -> *).
Functor f =>
(Maybe RunAs -> f (Maybe RunAs)) -> Context -> f Context
Ctx.runAs (RunAs -> Maybe RunAs
forall a. a -> Maybe a
Just RunAs
Ctx.RunAsRoot)),
Text
-> Text
-> (forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Capabilities -> f Capabilities)
-> (Context -> ReaderT AppEnv IO Context)
-> Cap
Cap Text
"terminal" Text
"allocate a tty" forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Capabilities -> f Capabilities
capTerminal Context -> ReaderT AppEnv IO Context
setTerminal,
Text
-> Text
-> (forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Capabilities -> f Capabilities)
-> (Context -> ReaderT AppEnv IO Context)
-> Cap
Cap Text
"interactive" Text
"interactive mode" forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Capabilities -> f Capabilities
capInteractive ((forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Context -> f Context)
-> Bool -> Context -> ReaderT AppEnv IO Context
forall a.
Lens' Context a -> a -> Context -> ReaderT AppEnv IO Context
contextSet forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Context -> f Context
Ctx.interactive Bool
True),
Text
-> Text
-> (forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Capabilities -> f Capabilities)
-> (Context -> ReaderT AppEnv IO Context)
-> Cap
Cap Text
"dbus" Text
"share session dbus socket" forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Capabilities -> f Capabilities
capDbus Context -> ReaderT AppEnv IO Context
setDbus,
Text
-> Text
-> (forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Capabilities -> f Capabilities)
-> (Context -> ReaderT AppEnv IO Context)
-> Cap
Cap Text
"wayland" Text
"share wayland socket" forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Capabilities -> f Capabilities
capWayland Context -> ReaderT AppEnv IO Context
setWayland,
Text
-> Text
-> (forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Capabilities -> f Capabilities)
-> (Context -> ReaderT AppEnv IO Context)
-> Cap
Cap Text
"pipewire" Text
"share pipewire socket" forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Capabilities -> f Capabilities
capPipewire Context -> ReaderT AppEnv IO Context
setPipewire,
Text
-> Text
-> (forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Capabilities -> f Capabilities)
-> (Context -> ReaderT AppEnv IO Context)
-> Cap
Cap Text
"video" Text
"share video devices" forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Capabilities -> f Capabilities
capVideo Context -> ReaderT AppEnv IO Context
setVideo,
Text
-> Text
-> (forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Capabilities -> f Capabilities)
-> (Context -> ReaderT AppEnv IO Context)
-> Cap
Cap Text
"dri" Text
"share graphic device" forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Capabilities -> f Capabilities
capDri Context -> ReaderT AppEnv IO Context
setDri,
Text
-> Text
-> (forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Capabilities -> f Capabilities)
-> (Context -> ReaderT AppEnv IO Context)
-> Cap
Cap Text
"kvm" Text
"share kvm device" forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Capabilities -> f Capabilities
capKvm (Context -> ReaderT AppEnv IO Context
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Context -> ReaderT AppEnv IO Context)
-> (Context -> Context) -> Context -> ReaderT AppEnv IO Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Context -> Context
Ctx.addDevice FilePath
"/dev/kvm"),
Text
-> Text
-> (forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Capabilities -> f Capabilities)
-> (Context -> ReaderT AppEnv IO Context)
-> Cap
Cap Text
"tun" Text
"share tun device" forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Capabilities -> f Capabilities
capTun (Context -> ReaderT AppEnv IO Context
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Context -> ReaderT AppEnv IO Context)
-> (Context -> Context) -> Context -> ReaderT AppEnv IO Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Context -> Context
Ctx.addDevice FilePath
"/dev/net/tun"),
Text
-> Text
-> (forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Capabilities -> f Capabilities)
-> (Context -> ReaderT AppEnv IO Context)
-> Cap
Cap Text
"alsa" Text
"share alsa devices" forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Capabilities -> f Capabilities
capAlsa (Context -> ReaderT AppEnv IO Context
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Context -> ReaderT AppEnv IO Context)
-> (Context -> Context) -> Context -> ReaderT AppEnv IO Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Context -> Context
Ctx.addDevice FilePath
"/dev/snd"),
Text
-> Text
-> (forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Capabilities -> f Capabilities)
-> (Context -> ReaderT AppEnv IO Context)
-> Cap
Cap Text
"pulseaudio" Text
"share pulseaudio socket" forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Capabilities -> f Capabilities
capPulseaudio Context -> ReaderT AppEnv IO Context
setPulseaudio,
Text
-> Text
-> (forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Capabilities -> f Capabilities)
-> (Context -> ReaderT AppEnv IO Context)
-> Cap
Cap Text
"ssh" Text
"share ssh agent and keys" forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Capabilities -> f Capabilities
capSsh Context -> ReaderT AppEnv IO Context
setSsh,
Text
-> Text
-> (forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Capabilities -> f Capabilities)
-> (Context -> ReaderT AppEnv IO Context)
-> Cap
Cap Text
"gpg" Text
"share gpg agent and keys" forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Capabilities -> f Capabilities
capGpg Context -> ReaderT AppEnv IO Context
setGpg,
Text
-> Text
-> (forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Capabilities -> f Capabilities)
-> (Context -> ReaderT AppEnv IO Context)
-> Cap
Cap Text
"x11" Text
"share x11 socket" forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Capabilities -> f Capabilities
capX11 Context -> ReaderT AppEnv IO Context
setX11,
Text
-> Text
-> (forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Capabilities -> f Capabilities)
-> (Context -> ReaderT AppEnv IO Context)
-> Cap
Cap Text
"cwd" Text
"mount cwd" forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Capabilities -> f Capabilities
capCwd Context -> ReaderT AppEnv IO Context
setCwd,
Text
-> Text
-> (forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Capabilities -> f Capabilities)
-> (Context -> ReaderT AppEnv IO Context)
-> Cap
Cap Text
"network" Text
"enable network" forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Capabilities -> f Capabilities
capNetwork Context -> ReaderT AppEnv IO Context
setNetwork,
Text
-> Text
-> (forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Capabilities -> f Capabilities)
-> (Context -> ReaderT AppEnv IO Context)
-> Cap
Cap Text
"hostfile" Text
"mount command file arg" forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Capabilities -> f Capabilities
capHostfile Context -> ReaderT AppEnv IO Context
forall (f :: * -> *) a. Applicative f => a -> f a
pure,
Text
-> Text
-> (forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Capabilities -> f Capabilities)
-> (Context -> ReaderT AppEnv IO Context)
-> Cap
Cap Text
"rw" Text
"mount rootfs rw" forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Capabilities -> f Capabilities
capRw ((forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Context -> f Context)
-> Bool -> Context -> ReaderT AppEnv IO Context
forall a.
Lens' Context a -> a -> Context -> ReaderT AppEnv IO Context
contextSet forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Context -> f Context
Ctx.ro Bool
False),
Text
-> Text
-> (forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Capabilities -> f Capabilities)
-> (Context -> ReaderT AppEnv IO Context)
-> Cap
Cap Text
"privileged" Text
"run with extra privileges" forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Capabilities -> f Capabilities
capPrivileged ((forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Context -> f Context)
-> Bool -> Context -> ReaderT AppEnv IO Context
forall a.
Lens' Context a -> a -> Context -> ReaderT AppEnv IO Context
contextSet forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Context -> f Context
Ctx.privileged Bool
True)
]
setNetwork :: Ctx.Context -> AppEnvT Ctx.Context
setNetwork :: Context -> ReaderT AppEnv IO Context
setNetwork Context
ctx = do
Context -> Context
setResolvConf <- IO (Context -> Context) -> ReaderT AppEnv IO (Context -> Context)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Context -> Context) -> ReaderT AppEnv IO (Context -> Context))
-> IO (Context -> Context)
-> ReaderT AppEnv IO (Context -> Context)
forall a b. (a -> b) -> a -> b
$ Context -> IO (Context -> Context)
ensureResolvConf Context
ctx
Context -> ReaderT AppEnv IO Context
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Context -> ReaderT AppEnv IO Context)
-> Context -> ReaderT AppEnv IO Context
forall a b. (a -> b) -> a -> b
$ Context
ctx Context -> (Context -> Context) -> Context
forall a b. a -> (a -> b) -> b
& ((Bool -> Identity Bool) -> Context -> Identity Context
forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Context -> f Context
Ctx.network ((Bool -> Identity Bool) -> Context -> Identity Context)
-> Bool -> Context -> Context
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True) (Context -> Context) -> (Context -> Context) -> Context -> Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context -> Context
setResolvConf
ensureResolvConf :: Ctx.Context -> IO (Ctx.Context -> Ctx.Context)
ensureResolvConf :: Context -> IO (Context -> Context)
ensureResolvConf 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
Ctx.runtimeCtx of
Ctx.Bubblewrap FilePath
"/" -> do
Bool
symlink <- FileStatus -> Bool
System.Posix.Files.isSymbolicLink (FileStatus -> Bool) -> IO FileStatus -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO FileStatus
System.Posix.Files.getSymbolicLinkStatus FilePath
"/etc/resolv.conf"
if Bool
symlink
then do
FilePath
realResolvConf <- IO FilePath
getSymlinkPath
(Context -> Context) -> IO (Context -> Context)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Context -> Context) -> IO (Context -> Context))
-> (Context -> Context) -> IO (Context -> Context)
forall a b. (a -> b) -> a -> b
$ FilePath -> Volume -> Context -> Context
Ctx.addMount FilePath
realResolvConf (Volume -> Context -> Context) -> Volume -> Context -> Context
forall a b. (a -> b) -> a -> b
$ FilePath -> Volume
Ctx.roHostPath FilePath
realResolvConf
else (Context -> Context) -> IO (Context -> Context)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Context -> Context
forall a. a -> a
id
Ctx.Bubblewrap FilePath
_ -> (Context -> Context) -> IO (Context -> Context)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Context -> Context) -> IO (Context -> Context))
-> (Context -> Context) -> IO (Context -> Context)
forall a b. (a -> b) -> a -> b
$ FilePath -> Volume -> Context -> Context
Ctx.addMount FilePath
"/etc/resolv.conf" (FilePath -> Volume
Ctx.roHostPath FilePath
"/etc/resolv.conf")
RuntimeContext
_ -> (Context -> Context) -> IO (Context -> Context)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Context -> Context
forall a. a -> a
id
where
getSymlinkPath :: IO FilePath
getSymlinkPath = do
FilePath
realResolvConf <- FilePath -> IO FilePath
System.Posix.Files.readSymbolicLink FilePath
"/etc/resolv.conf"
FilePath -> IO FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$
if FilePath
"../" FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
realResolvConf
then Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
drop Int
2 FilePath
realResolvConf
else FilePath
realResolvConf
setTerminal :: Ctx.Context -> AppEnvT Ctx.Context
setTerminal :: Context -> ReaderT AppEnv IO Context
setTerminal Context
ctx =
Context -> ReaderT AppEnv IO Context
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Context -> ReaderT AppEnv IO Context)
-> Context -> ReaderT AppEnv IO Context
forall a b. (a -> b) -> a -> b
$ Context
ctx Context -> (Context -> Context) -> Context
forall a b. a -> (a -> b) -> b
& ((Bool -> Identity Bool) -> Context -> Identity Context
forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Context -> f Context
Ctx.interactive ((Bool -> Identity Bool) -> Context -> Identity Context)
-> Bool -> Context -> Context
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True) (Context -> Context) -> (Context -> Context) -> Context -> Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Bool -> Identity Bool) -> Context -> Identity Context
forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Context -> f Context
Ctx.terminal ((Bool -> Identity Bool) -> Context -> Identity Context)
-> Bool -> Context -> Context
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True) (Context -> Context) -> (Context -> Context) -> Context -> Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text -> Context -> Context
Ctx.addEnv Text
"TERM" Text
"xterm-256color")
setWayland :: Ctx.Context -> AppEnvT Ctx.Context
setWayland :: Context -> ReaderT AppEnv IO Context
setWayland Context
ctx = do
Maybe FilePath
sktM <- IO (Maybe FilePath) -> ReaderT AppEnv IO (Maybe FilePath)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe FilePath) -> ReaderT AppEnv IO (Maybe FilePath))
-> IO (Maybe FilePath) -> ReaderT AppEnv IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> IO (Maybe FilePath)
forall (m :: * -> *). MonadIO m => FilePath -> m (Maybe FilePath)
lookupEnv FilePath
"WAYLAND_DISPLAY"
case Maybe FilePath
sktM of
Maybe FilePath
Nothing -> Context -> ReaderT AppEnv IO Context
setX11 Context
ctx
Just FilePath
skt -> FilePath -> Context -> ReaderT AppEnv IO Context
setWayland' FilePath
skt Context
ctx
setWayland' :: FilePath -> Ctx.Context -> AppEnvT Ctx.Context
setWayland' :: FilePath -> Context -> ReaderT AppEnv IO Context
setWayland' FilePath
skt Context
ctx = do
Context -> Context
shareSkt <- FilePath -> ReaderT AppEnv IO (Context -> Context)
addXdgRun FilePath
skt
Context -> ReaderT AppEnv IO Context
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Context -> ReaderT AppEnv IO Context)
-> Context -> ReaderT AppEnv IO Context
forall a b. (a -> b) -> a -> b
$
Context
ctx
Context -> (Context -> Context) -> Context
forall a b. a -> (a -> b) -> b
& FilePath -> Context -> Context
Ctx.directMount FilePath
"/etc/machine-id"
(Context -> Context) -> (Context -> Context) -> Context -> Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context -> Context
shareSkt
(Context -> Context) -> (Context -> Context) -> Context -> Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Context -> Context
Ctx.addEnv Text
"GDK_BACKEND" Text
"wayland"
(Context -> Context) -> (Context -> Context) -> Context -> Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Context -> Context
Ctx.addEnv Text
"QT_QPA_PLATFORM" Text
"wayland"
(Context -> Context) -> (Context -> Context) -> Context -> Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Context -> Context
Ctx.addEnv Text
"WAYLAND_DISPLAY" (FilePath -> Text
forall a. ToText a => a -> Text
toText FilePath
skt)
(Context -> Context) -> (Context -> Context) -> Context -> Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Context -> Context
Ctx.addEnv Text
"XDG_SESSION_TYPE" Text
"wayland"
(Context -> Context) -> (Context -> Context) -> Context -> Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Volume -> Context -> Context
Ctx.addMount FilePath
"/dev/shm" Volume
Ctx.tmpfs
setPipewire :: Ctx.Context -> AppEnvT Ctx.Context
setPipewire :: Context -> ReaderT AppEnv IO Context
setPipewire Context
ctx = do
let skt :: FilePath
skt = FilePath
"pipewire-0"
Context -> Context
shareSkt <- FilePath -> ReaderT AppEnv IO (Context -> Context)
addXdgRun FilePath
skt
Context -> ReaderT AppEnv IO Context
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Context -> ReaderT AppEnv IO Context)
-> Context -> ReaderT AppEnv IO Context
forall a b. (a -> b) -> a -> b
$
Context
ctx
Context -> (Context -> Context) -> Context
forall a b. a -> (a -> b) -> b
& FilePath -> Context -> Context
Ctx.directMount FilePath
"/etc/machine-id"
(Context -> Context) -> (Context -> Context) -> Context -> Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context -> Context
shareSkt
setDbus :: Ctx.Context -> AppEnvT Ctx.Context
setDbus :: Context -> ReaderT AppEnv IO Context
setDbus Context
ctx = do
let skt :: FilePath
skt = FilePath
"bus"
(FilePath
sktPath, Context -> Context
shareSkt) <- FilePath -> AppEnvT (FilePath, Context -> Context)
addXdgRun' FilePath
skt
Context -> ReaderT AppEnv IO Context
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Context -> ReaderT AppEnv IO Context)
-> Context -> ReaderT AppEnv IO Context
forall a b. (a -> b) -> a -> b
$
Context
ctx
Context -> (Context -> Context) -> Context
forall a b. a -> (a -> b) -> b
& FilePath -> Context -> Context
Ctx.directMount FilePath
"/etc/machine-id"
(Context -> Context) -> (Context -> Context) -> Context -> Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Context -> Context
Ctx.addEnv Text
"DBUS_SESSION_BUS_ADDRESS" (Text
"unix:path=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
forall a. ToText a => a -> Text
toText FilePath
sktPath)
(Context -> Context) -> (Context -> Context) -> Context -> Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context -> Context
shareSkt
setVideo :: Ctx.Context -> AppEnvT Ctx.Context
setVideo :: Context -> ReaderT AppEnv IO Context
setVideo Context
ctx = do
[FilePath]
devices <- IO [FilePath] -> ReaderT AppEnv IO [FilePath]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [FilePath] -> ReaderT AppEnv IO [FilePath])
-> IO [FilePath] -> ReaderT AppEnv IO [FilePath]
forall a b. (a -> b) -> a -> b
$ FilePath -> IO [FilePath]
listDirectory FilePath
"/dev"
let addDevices :: [Context -> Context]
addDevices =
(Text -> Context -> Context) -> [Text] -> [Context -> Context]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> Context -> Context
Ctx.addDevice (FilePath -> Context -> Context)
-> (Text -> FilePath) -> Text -> Context -> Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
forall a. ToString a => a -> FilePath
toString (Text -> FilePath) -> (Text -> Text) -> Text -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text
forall a. Monoid a => a -> a -> a
mappend Text
"/dev/") ([Text] -> [Context -> Context]) -> [Text] -> [Context -> Context]
forall a b. (a -> b) -> a -> b
$
(Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text
"video" Text -> Text -> Bool
`Text.isPrefixOf`) ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ (FilePath -> Text) -> [FilePath] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Text
forall a. ToText a => a -> Text
toText [FilePath]
devices
Context -> ReaderT AppEnv IO Context
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Context -> ReaderT AppEnv IO Context)
-> Context -> ReaderT AppEnv IO Context
forall a b. (a -> b) -> a -> b
$ ((Context -> Context) -> Context -> Context)
-> Context -> [Context -> Context] -> Context
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Context -> Context
c Context
a -> Context -> Context
c Context
a) Context
ctx [Context -> Context]
addDevices
setDri :: Ctx.Context -> AppEnvT Ctx.Context
setDri :: Context -> ReaderT AppEnv IO Context
setDri Context
ctx = do
Bool
nvidia <- IO Bool -> ReaderT AppEnv IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ReaderT AppEnv IO Bool)
-> IO Bool -> ReaderT AppEnv IO Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesPathExist FilePath
"/dev/nvidiactl"
Context -> ReaderT AppEnv IO Context
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Context -> ReaderT AppEnv IO Context)
-> Context -> ReaderT AppEnv IO Context
forall a b. (a -> b) -> a -> b
$
Context
ctx
Context -> (Context -> Context) -> Context
forall a b. a -> (a -> b) -> b
& if Bool
nvidia
then FilePath -> Context -> Context
Ctx.addDevice FilePath
"/dev/nvidiactl" (Context -> Context) -> (Context -> Context) -> Context -> Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Context -> Context
Ctx.addDevice FilePath
"/dev/nvidia0"
else FilePath -> Context -> Context
Ctx.addDevice FilePath
"/dev/dri"
setPulseaudio :: Ctx.Context -> AppEnvT Ctx.Context
setPulseaudio :: Context -> ReaderT AppEnv IO Context
setPulseaudio Context
ctx = do
Context -> Context
shareSkt <- FilePath -> ReaderT AppEnv IO (Context -> Context)
addXdgRun FilePath
"pulse"
UserID
uid <- (AppEnv -> UserID) -> ReaderT AppEnv IO UserID
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks AppEnv -> UserID
_hostUid
let pulseServer :: Text
pulseServer = Text
"/run/user/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> UserID -> Text
forall b a. (Show a, IsString b) => a -> b
show UserID
uid Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/pulse/native"
Context -> ReaderT AppEnv IO Context
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Context -> ReaderT AppEnv IO Context)
-> Context -> ReaderT AppEnv IO Context
forall a b. (a -> b) -> a -> b
$
Context
ctx
Context -> (Context -> Context) -> Context
forall a b. a -> (a -> b) -> b
& FilePath -> Context -> Context
Ctx.directMount FilePath
"/etc/machine-id"
(Context -> Context) -> (Context -> Context) -> Context -> Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context -> Context
shareSkt
(Context -> Context) -> (Context -> Context) -> Context -> Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Context -> Context
Ctx.addEnv Text
"PULSE_SERVER" Text
pulseServer
getHomes :: Text -> AppEnvT (FilePath, FilePath)
getHomes :: Text -> AppEnvT (FilePath, FilePath)
getHomes Text
help = do
FilePath
hostDir <- FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe (Text -> FilePath
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ Text
"Need HOME for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
help) (Maybe FilePath -> FilePath)
-> ReaderT AppEnv IO (Maybe FilePath) -> ReaderT AppEnv IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (AppEnv -> Maybe FilePath) -> ReaderT AppEnv IO (Maybe FilePath)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks AppEnv -> Maybe FilePath
_hostHomeDir
FilePath
appDir <- FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe (Text -> FilePath
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> FilePath) -> Text -> FilePath
forall a b. (a -> b) -> a -> b
$ Text
"Application need home for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
help) (Maybe FilePath -> FilePath)
-> ReaderT AppEnv IO (Maybe FilePath) -> ReaderT AppEnv IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (AppEnv -> Maybe FilePath) -> ReaderT AppEnv IO (Maybe FilePath)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks AppEnv -> Maybe FilePath
_appHomeDir
(FilePath, FilePath) -> AppEnvT (FilePath, FilePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath
hostDir, FilePath
appDir)
mountHomeConfig :: Text -> FilePath -> AppEnvT (Ctx.Context -> Ctx.Context)
mountHomeConfig :: Text -> FilePath -> ReaderT AppEnv IO (Context -> Context)
mountHomeConfig Text
help FilePath
fp = do
(FilePath
hostDir, FilePath
appDir) <- Text -> AppEnvT (FilePath, FilePath)
getHomes Text
help
(Context -> Context) -> ReaderT AppEnv IO (Context -> Context)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Context -> Context) -> ReaderT AppEnv IO (Context -> Context))
-> (Context -> Context) -> ReaderT AppEnv IO (Context -> Context)
forall a b. (a -> b) -> a -> b
$ FilePath -> Volume -> Context -> Context
Ctx.addMount (FilePath
appDir FilePath -> FilePath -> FilePath
</> FilePath
fp) (FilePath -> Volume
Ctx.roHostPath (FilePath -> Volume) -> FilePath -> Volume
forall a b. (a -> b) -> a -> b
$ FilePath
hostDir FilePath -> FilePath -> FilePath
</> FilePath
fp)
setAgent :: String -> IO (Ctx.Context -> Ctx.Context)
setAgent :: FilePath -> IO (Context -> Context)
setAgent FilePath
var = do
Maybe FilePath
value <- FilePath -> IO (Maybe FilePath)
forall (m :: * -> *). MonadIO m => FilePath -> m (Maybe FilePath)
lookupEnv FilePath
var
(Context -> Context) -> IO (Context -> Context)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Context -> Context) -> IO (Context -> Context))
-> (Context -> Context) -> IO (Context -> Context)
forall a b. (a -> b) -> a -> b
$ case Maybe FilePath
value of
Maybe FilePath
Nothing -> Context -> Context
forall a. a -> a
id
Just FilePath
path -> Text -> Text -> Context -> Context
Ctx.addEnv (FilePath -> Text
forall a. ToText a => a -> Text
toText FilePath
var) (FilePath -> Text
forall a. ToText a => a -> Text
toText FilePath
path) (Context -> Context) -> (Context -> Context) -> Context -> Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Context -> Context
Ctx.directMount (FilePath -> FilePath
takeDirectory FilePath
path)
setSsh :: Ctx.Context -> AppEnvT Ctx.Context
setSsh :: Context -> ReaderT AppEnv IO Context
setSsh Context
ctx = do
Context -> Context
shareAgent <- IO (Context -> Context) -> ReaderT AppEnv IO (Context -> Context)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Context -> Context) -> ReaderT AppEnv IO (Context -> Context))
-> IO (Context -> Context)
-> ReaderT AppEnv IO (Context -> Context)
forall a b. (a -> b) -> a -> b
$ FilePath -> IO (Context -> Context)
setAgent FilePath
"SSH_AUTH_SOCK"
Context -> ReaderT AppEnv IO Context
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Context -> ReaderT AppEnv IO Context)
-> Context -> ReaderT AppEnv IO Context
forall a b. (a -> b) -> a -> b
$ Context
ctx Context -> (Context -> Context) -> Context
forall a b. a -> (a -> b) -> b
& Context -> Context
shareAgent
setGpg :: Ctx.Context -> AppEnvT Ctx.Context
setGpg :: Context -> ReaderT AppEnv IO Context
setGpg Context
ctx = do
Context -> Context
shareConfig <- Text -> FilePath -> ReaderT AppEnv IO (Context -> Context)
mountHomeConfig Text
"gpg" FilePath
".gnupg"
Context -> Context
shareGpg <- FilePath -> ReaderT AppEnv IO (Context -> Context)
addXdgRun FilePath
"gnupg"
Context -> ReaderT AppEnv IO Context
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Context -> ReaderT AppEnv IO Context)
-> Context -> ReaderT AppEnv IO Context
forall a b. (a -> b) -> a -> b
$ Context
ctx Context -> (Context -> Context) -> Context
forall a b. a -> (a -> b) -> b
& Context -> Context
shareGpg (Context -> Context) -> (Context -> Context) -> Context -> Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context -> Context
shareConfig
setX11 :: Ctx.Context -> AppEnvT Ctx.Context
setX11 :: Context -> ReaderT AppEnv IO Context
setX11 Context
ctx = do
FilePath
display <- IO FilePath -> ReaderT AppEnv IO FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> ReaderT AppEnv IO FilePath)
-> IO FilePath -> ReaderT AppEnv IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
getEnv FilePath
"DISPLAY"
Context -> ReaderT AppEnv IO Context
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Context -> ReaderT AppEnv IO Context)
-> Context -> ReaderT AppEnv IO Context
forall a b. (a -> b) -> a -> b
$
Context
ctx
Context -> (Context -> Context) -> Context
forall a b. a -> (a -> b) -> b
& FilePath -> Context -> Context
Ctx.directMount FilePath
"/tmp/.X11-unix" (Context -> Context) -> (Context -> Context) -> Context -> Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Context -> Context
Ctx.addEnv Text
"DISPLAY" (FilePath -> Text
forall a. ToText a => a -> Text
toText FilePath
display) (Context -> Context) -> (Context -> Context) -> Context -> Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Volume -> Context -> Context
Ctx.addMount FilePath
"/dev/shm" Volume
Ctx.tmpfs
setCwd :: Ctx.Context -> AppEnvT Ctx.Context
setCwd :: Context -> ReaderT AppEnv IO Context
setCwd Context
ctx = do
FilePath
cwd <- (AppEnv -> FilePath) -> ReaderT AppEnv IO FilePath
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks AppEnv -> FilePath
_hostCwd
Context -> ReaderT AppEnv IO Context
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Context -> ReaderT AppEnv IO Context)
-> Context -> ReaderT AppEnv IO Context
forall a b. (a -> b) -> a -> b
$ Context
ctx Context -> (Context -> Context) -> Context
forall a b. a -> (a -> b) -> b
& FilePath -> Volume -> Context -> Context
Ctx.addMount FilePath
"/data" (FilePath -> Volume
Ctx.rwHostPath FilePath
cwd) (Context -> Context) -> (Context -> Context) -> Context -> Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Maybe FilePath -> Identity (Maybe FilePath))
-> Context -> Identity Context
forall (f :: * -> *).
Functor f =>
(Maybe FilePath -> f (Maybe FilePath)) -> Context -> f Context
Ctx.workdir ((Maybe FilePath -> Identity (Maybe FilePath))
-> Context -> Identity Context)
-> FilePath -> Context -> Context
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ FilePath
"/data")
addVolume :: Ctx.Context -> Text -> AppEnvT Ctx.Context
addVolume :: Context -> Text -> ReaderT AppEnv IO Context
addVolume Context
ctx Text
volume = do
FilePath
containerPath' <- Text -> ReaderT AppEnv IO FilePath
resolveContainerPath Text
containerPath
Volume
hostPath' <- Text -> AppEnvT Volume
resolveVolume Text
hostPath
Context -> ReaderT AppEnv IO Context
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Context -> ReaderT AppEnv IO Context)
-> Context -> ReaderT AppEnv IO Context
forall a b. (a -> b) -> a -> b
$ FilePath -> Volume -> Context -> Context
Ctx.addMount FilePath
containerPath' Volume
hostPath' Context
ctx
where
(Text
hostPath, Text
containerPath) = case Text -> Text -> (Text, Text)
Text.breakOn Text
":" Text
volume of
(Text
x, Text
"") -> (Text
x, Text
x)
(Text
x, Text
y) -> (Text
x, Int -> Text -> Text
Text.drop Int
1 Text
y)
resolveFileArgs :: [Text] -> AppEnvT (Ctx.Context -> Ctx.Context)
resolveFileArgs :: [Text] -> ReaderT AppEnv IO (Context -> Context)
resolveFileArgs [Text]
args = do
[Either Text FilePath]
fps <- (Text -> ReaderT AppEnv IO (Either Text FilePath))
-> [Text] -> ReaderT AppEnv IO [Either Text FilePath]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Text -> ReaderT AppEnv IO (Either Text FilePath)
checkExist [Text]
args
(Context -> Context) -> ReaderT AppEnv IO (Context -> Context)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Context -> Context) -> ReaderT AppEnv IO (Context -> Context))
-> (Context -> Context) -> ReaderT AppEnv IO (Context -> Context)
forall a b. (a -> b) -> a -> b
$ (Either Text FilePath
-> (Context -> Context) -> Context -> Context)
-> (Context -> Context)
-> [Either Text FilePath]
-> Context
-> Context
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Context -> Context) -> (Context -> Context) -> Context -> Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) ((Context -> Context)
-> (Context -> Context) -> Context -> Context)
-> (Either Text FilePath -> Context -> Context)
-> Either Text FilePath
-> (Context -> Context)
-> Context
-> Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either Text FilePath -> Context -> Context
addFileArg) Context -> Context
forall a. a -> a
id [Either Text FilePath]
fps
where
addCommand :: Text -> Ctx.Context -> Ctx.Context
addCommand :: Text -> Context -> Context
addCommand Text
arg = ([Text] -> Identity [Text]) -> Context -> Identity Context
forall (f :: * -> *).
Functor f =>
([Text] -> f [Text]) -> Context -> f Context
Ctx.command (([Text] -> Identity [Text]) -> Context -> Identity Context)
-> ([Text] -> [Text]) -> Context -> Context
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Text
arg Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:)
checkExist :: Text -> AppEnvT (Either Text FilePath)
checkExist :: Text -> ReaderT AppEnv IO (Either Text FilePath)
checkExist Text
arg = do
Maybe FilePath
fpM <- Text -> ReaderT AppEnv IO (Maybe FilePath)
resolveHostPath Text
arg
case Maybe FilePath
fpM of
Maybe FilePath
Nothing -> Either Text FilePath -> ReaderT AppEnv IO (Either Text FilePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text FilePath -> ReaderT AppEnv IO (Either Text FilePath))
-> Either Text FilePath -> ReaderT AppEnv IO (Either Text FilePath)
forall a b. (a -> b) -> a -> b
$ Text -> Either Text FilePath
forall a b. a -> Either a b
Left Text
arg
Just FilePath
fp -> do
Bool
exist <- IO Bool -> ReaderT AppEnv IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ReaderT AppEnv IO Bool)
-> IO Bool -> ReaderT AppEnv IO Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesPathExist FilePath
fp
Bool -> ReaderT AppEnv IO () -> ReaderT AppEnv IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exist (IO () -> ReaderT AppEnv IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT AppEnv IO ()) -> IO () -> ReaderT AppEnv IO ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putTextLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Warning, arg path does not exist: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
arg)
Either Text FilePath -> ReaderT AppEnv IO (Either Text FilePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text FilePath -> ReaderT AppEnv IO (Either Text FilePath))
-> Either Text FilePath -> ReaderT AppEnv IO (Either Text FilePath)
forall a b. (a -> b) -> a -> b
$ Either Text FilePath
-> Either Text FilePath -> Bool -> Either Text FilePath
forall a. a -> a -> Bool -> a
bool (Text -> Either Text FilePath
forall a b. a -> Either a b
Left Text
arg) (FilePath -> Either Text FilePath
forall a b. b -> Either a b
Right FilePath
fp) Bool
exist
addFileArg :: Either Text FilePath -> Ctx.Context -> Ctx.Context
addFileArg :: Either Text FilePath -> Context -> Context
addFileArg (Left Text
arg) = Text -> Context -> Context
addCommand Text
arg
addFileArg (Right FilePath
fp)
| FilePath -> Bool
hasTrailingPathSeparator FilePath
fp = Text -> Context -> Context
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"Directory filearg ar not supported"
| Bool
otherwise =
let cfp :: FilePath
cfp = FilePath
"/data" FilePath -> FilePath -> FilePath
</> FilePath -> FilePath
takeFileName FilePath
fp
in Text -> Context -> Context
addCommand (FilePath -> Text
forall a. ToText a => a -> Text
toText FilePath
cfp) (Context -> Context) -> (Context -> Context) -> Context -> Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Volume -> Context -> Context
Ctx.addMount FilePath
cfp (FilePath -> Volume
Ctx.rwHostPath FilePath
fp)
getXdgRuntimeDir :: AppEnvT FilePath
getXdgRuntimeDir :: ReaderT AppEnv IO FilePath
getXdgRuntimeDir = FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe (Text -> FilePath
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"Need XDG_RUNTIME_DIR") (Maybe FilePath -> FilePath)
-> ReaderT AppEnv IO (Maybe FilePath) -> ReaderT AppEnv IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (AppEnv -> Maybe FilePath) -> ReaderT AppEnv IO (Maybe FilePath)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks AppEnv -> Maybe FilePath
_hostXdgRunDir
fixPath :: Text -> FilePath
fixPath :: Text -> FilePath
fixPath = Text -> FilePath
forall a. ToString a => a -> FilePath
toString (Text -> FilePath) -> (Text -> Text) -> Text -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> Text
Text.drop Int
1 (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
Text.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'/')
resolveContainerPath :: Text -> AppEnvT FilePath
resolveContainerPath :: Text -> ReaderT AppEnv IO FilePath
resolveContainerPath Text
path
| Text
path Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"~" Bool -> Bool -> Bool
|| Text
"~/" Text -> Text -> Bool
`Text.isPrefixOf` Text
path = do
FilePath
appHome' <- FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe (Text -> FilePath
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"Need app home") (Maybe FilePath -> FilePath)
-> ReaderT AppEnv IO (Maybe FilePath) -> ReaderT AppEnv IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (AppEnv -> Maybe FilePath) -> ReaderT AppEnv IO (Maybe FilePath)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks AppEnv -> Maybe FilePath
_appHomeDir
FilePath -> ReaderT AppEnv IO FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> ReaderT AppEnv IO FilePath)
-> FilePath -> ReaderT AppEnv IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
appHome' FilePath -> FilePath -> FilePath
</> Text -> FilePath
fixPath Text
path
| Text
"/" Text -> Text -> Bool
`Text.isPrefixOf` Text
path = FilePath -> ReaderT AppEnv IO FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> ReaderT AppEnv IO FilePath)
-> FilePath -> ReaderT AppEnv IO FilePath
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
forall a. ToString a => a -> FilePath
toString Text
path
| Bool
otherwise = Text -> ReaderT AppEnv IO FilePath
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> ReaderT AppEnv IO FilePath)
-> Text -> ReaderT AppEnv IO FilePath
forall a b. (a -> b) -> a -> b
$ Text
"Invalid container path: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
path
resolveHostPath :: Text -> AppEnvT (Maybe FilePath)
resolveHostPath :: Text -> ReaderT AppEnv IO (Maybe FilePath)
resolveHostPath Text
path
| Text
"~/" Text -> Text -> Bool
`Text.isPrefixOf` Text
path = do
FilePath
envHome' <- FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe (Text -> FilePath
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"Need HOME") (Maybe FilePath -> FilePath)
-> ReaderT AppEnv IO (Maybe FilePath) -> ReaderT AppEnv IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (AppEnv -> Maybe FilePath) -> ReaderT AppEnv IO (Maybe FilePath)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks AppEnv -> Maybe FilePath
_hostHomeDir
Maybe FilePath -> ReaderT AppEnv IO (Maybe FilePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe FilePath -> ReaderT AppEnv IO (Maybe FilePath))
-> Maybe FilePath -> ReaderT AppEnv IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath
envHome' FilePath -> FilePath -> FilePath
</> Text -> FilePath
fixPath Text
path)
| Text
"./" Text -> Text -> Bool
`Text.isPrefixOf` Text
path = do
FilePath
curDir' <- (AppEnv -> FilePath) -> ReaderT AppEnv IO FilePath
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks AppEnv -> FilePath
_hostCwd
Maybe FilePath -> ReaderT AppEnv IO (Maybe FilePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe FilePath -> ReaderT AppEnv IO (Maybe FilePath))
-> Maybe FilePath -> ReaderT AppEnv IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath
curDir' FilePath -> FilePath -> FilePath
</> Text -> FilePath
fixPath Text
path)
| Text
"/" Text -> Text -> Bool
`Text.isPrefixOf` Text
path = Maybe FilePath -> ReaderT AppEnv IO (Maybe FilePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe FilePath -> ReaderT AppEnv IO (Maybe FilePath))
-> Maybe FilePath -> ReaderT AppEnv IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (Text -> FilePath
forall a. ToString a => a -> FilePath
toString Text
path)
| Bool
otherwise = Maybe FilePath -> ReaderT AppEnv IO (Maybe FilePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe FilePath
forall a. Maybe a
Nothing
resolveHostPath' :: Text -> AppEnvT FilePath
resolveHostPath' :: Text -> ReaderT AppEnv IO FilePath
resolveHostPath' Text
path = do
Maybe FilePath
pathM <- Text -> ReaderT AppEnv IO (Maybe FilePath)
resolveHostPath Text
path
case Maybe FilePath
pathM of
Just FilePath
x -> FilePath -> ReaderT AppEnv IO FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
x
Maybe FilePath
Nothing -> Text -> ReaderT AppEnv IO FilePath
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> ReaderT AppEnv IO FilePath)
-> Text -> ReaderT AppEnv IO FilePath
forall a b. (a -> b) -> a -> b
$ Text
"Invalid host path: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
path
resolveVolume :: Text -> AppEnvT Ctx.Volume
resolveVolume :: Text -> AppEnvT Volume
resolveVolume Text
name = case Text -> Maybe (Char, Text)
Text.uncons Text
name of
Maybe (Char, Text)
Nothing -> Text -> AppEnvT Volume
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"Empty host path"
Just (Char
x, Text
_xs)
| Char
x Char -> FilePath -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [Char
'~', Char
'.', Char
'/'] -> FilePath -> Volume
Ctx.rwHostPath (FilePath -> Volume)
-> ReaderT AppEnv IO FilePath -> AppEnvT Volume
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> ReaderT AppEnv IO FilePath
resolveHostPath' Text
name
| Bool
otherwise -> Volume -> AppEnvT Volume
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Volume -> AppEnvT Volume) -> Volume -> AppEnvT Volume
forall a b. (a -> b) -> a -> b
$ Mode -> VolumeType -> Volume
Ctx.MkVolume Mode
Ctx.RW (Text -> VolumeType
Ctx.Volume Text
name)
addXdgRun :: FilePath -> AppEnvT (Ctx.Context -> Ctx.Context)
addXdgRun :: FilePath -> ReaderT AppEnv IO (Context -> Context)
addXdgRun FilePath
fp = (FilePath, Context -> Context) -> Context -> Context
forall a b. (a, b) -> b
snd ((FilePath, Context -> Context) -> Context -> Context)
-> AppEnvT (FilePath, Context -> Context)
-> ReaderT AppEnv IO (Context -> Context)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> AppEnvT (FilePath, Context -> Context)
addXdgRun' FilePath
fp
addXdgRun' :: FilePath -> AppEnvT (FilePath, Ctx.Context -> Ctx.Context)
addXdgRun' :: FilePath -> AppEnvT (FilePath, Context -> Context)
addXdgRun' FilePath
fp = do
FilePath
hostXdg <- ReaderT AppEnv IO FilePath
getXdgRuntimeDir
UserID
uid <- (AppEnv -> UserID) -> ReaderT AppEnv IO UserID
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks AppEnv -> UserID
_hostUid
let containerPath :: FilePath
containerPath = FilePath
runDir FilePath -> FilePath -> FilePath
</> FilePath
fp
hostPath :: FilePath
hostPath = FilePath
hostXdg FilePath -> FilePath -> FilePath
</> FilePath
fp
runBaseDir :: FilePath
runBaseDir = FilePath
"/run/user"
runDir :: FilePath
runDir = FilePath
runBaseDir FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"/" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> UserID -> FilePath
forall b a. (Show a, IsString b) => a -> b
show UserID
uid
(FilePath, Context -> Context)
-> AppEnvT (FilePath, Context -> Context)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( FilePath
containerPath,
Text -> Text -> Context -> Context
Ctx.addEnv Text
"XDG_RUNTIME_DIR" (FilePath -> Text
forall a. ToText a => a -> Text
toText FilePath
runDir)
(Context -> Context) -> (Context -> Context) -> Context -> Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Volume -> Context -> Context
Ctx.addMount FilePath
runBaseDir Volume
Ctx.tmpfs
(Context -> Context) -> (Context -> Context) -> Context -> Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Volume -> Context -> Context
Ctx.addMount FilePath
containerPath (FilePath -> Volume
Ctx.rwHostPath FilePath
hostPath)
)
contextSet :: Lens' Ctx.Context a -> a -> Ctx.Context -> AppEnvT Ctx.Context
contextSet :: Lens' Context a -> a -> Context -> ReaderT AppEnv IO Context
contextSet Lens' Context a
lens a
value Context
ctx = Context -> ReaderT AppEnv IO Context
forall (f :: * -> *) a. Applicative f => a -> f a
pure (((a -> Identity a) -> Context -> Identity Context
Lens' Context a
lens ((a -> Identity a) -> Context -> Identity Context)
-> a -> Context -> Context
forall s t a b. ASetter s t a b -> b -> s -> t
.~ a
value) Context
ctx)