{-# 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 #-}

-- | This module contains the capability logic.
-- The goal is to convert an Application into a Context
--
-- This module performs read-only IO
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

-- | Converts an Application into a Context
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

-- TODO: make this stricly pure using a PodenvMonad similar to the PandocMonad
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

    -- Check if path is part of a mount point
    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

    -- Some capabilities do not work with selinux
    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
    -- When using host device, selinux also needs to be disabled
    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
    -- When using direct host path, its simpler to disable selinux too. That can be improved though
    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
      -- To keep it simple, when the app home is in `/home`, assume we share the host uid.
      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

-- | CapInfo describes a capability and how it modify the runtime context
data Cap = Cap
  { Cap -> Text
capName :: Text,
    Cap -> Text
capDescription :: Text,
    -- | How to get the capability value from the user provided record:
    Cap
-> forall (f :: * -> *).
   Functor f =>
   (Bool -> f Bool) -> Capabilities -> f Capabilities
capLens :: Lens' Capabilities Bool,
    -- | How the capability change the context:
    Cap -> Context -> ReaderT AppEnv IO Context
capSet :: Ctx.Context -> AppEnvT Ctx.Context
  }

-- | The main list of capabilities
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
  -- When using host rootfs, then we need to mount /etc/resolv.conf target when it is a symlink
  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
  -- Otherwise we can just mount it directly
  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" -- TODO discover skt name
  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" -- TODO discover skt name
  (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)

-- | Helper functions to manipulate paths
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)
    -- TODO: handle suffix such as :Z
    | 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)

-- | Helper function to share a XDG_RUNTIME_DIR path
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

-- | Returns the container path and the context setter for xdg
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)
        -- Podman creates parent directory as root, ensure user can r/w xdgdir using tmpfs
        (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)
    )

-- | Helper for capabilities that are directly represented in the context
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)