{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
-- makeLenses does not produce those
{-# OPTIONS_GHC -Wno-missing-signatures #-}
{-# OPTIONS_GHC -fno-warn-missing-export-lists #-}

-- | Runtime Context data types and lenses
module Podenv.Context where

import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Lens.Family.TH (makeLenses)
import Podenv.Prelude
import System.Linux.Capabilities (Capability)

newtype ImageName = ImageName {ImageName -> Text
unImageName :: Text}
  deriving (Int -> ImageName -> ShowS
[ImageName] -> ShowS
ImageName -> String
(Int -> ImageName -> ShowS)
-> (ImageName -> String)
-> ([ImageName] -> ShowS)
-> Show ImageName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ImageName] -> ShowS
$cshowList :: [ImageName] -> ShowS
show :: ImageName -> String
$cshow :: ImageName -> String
showsPrec :: Int -> ImageName -> ShowS
$cshowsPrec :: Int -> ImageName -> ShowS
Show)

data RuntimeContext
  = Container ImageName
  | Bubblewrap FilePath
  deriving (Int -> RuntimeContext -> ShowS
[RuntimeContext] -> ShowS
RuntimeContext -> String
(Int -> RuntimeContext -> ShowS)
-> (RuntimeContext -> String)
-> ([RuntimeContext] -> ShowS)
-> Show RuntimeContext
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RuntimeContext] -> ShowS
$cshowList :: [RuntimeContext] -> ShowS
show :: RuntimeContext -> String
$cshow :: RuntimeContext -> String
showsPrec :: Int -> RuntimeContext -> ShowS
$cshowsPrec :: Int -> RuntimeContext -> ShowS
Show)

data Mode = RO | RW
  deriving (Int -> Mode -> ShowS
[Mode] -> ShowS
Mode -> String
(Int -> Mode -> ShowS)
-> (Mode -> String) -> ([Mode] -> ShowS) -> Show Mode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Mode] -> ShowS
$cshowList :: [Mode] -> ShowS
show :: Mode -> String
$cshow :: Mode -> String
showsPrec :: Int -> Mode -> ShowS
$cshowsPrec :: Int -> Mode -> ShowS
Show)

data VolumeType = HostPath FilePath | TmpFS | Volume Text
  deriving (Int -> VolumeType -> ShowS
[VolumeType] -> ShowS
VolumeType -> String
(Int -> VolumeType -> ShowS)
-> (VolumeType -> String)
-> ([VolumeType] -> ShowS)
-> Show VolumeType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [VolumeType] -> ShowS
$cshowList :: [VolumeType] -> ShowS
show :: VolumeType -> String
$cshow :: VolumeType -> String
showsPrec :: Int -> VolumeType -> ShowS
$cshowsPrec :: Int -> VolumeType -> ShowS
Show)

data Volume = MkVolume Mode VolumeType
  deriving (Int -> Volume -> ShowS
[Volume] -> ShowS
Volume -> String
(Int -> Volume -> ShowS)
-> (Volume -> String) -> ([Volume] -> ShowS) -> Show Volume
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Volume] -> ShowS
$cshowList :: [Volume] -> ShowS
show :: Volume -> String
$cshow :: Volume -> String
showsPrec :: Int -> Volume -> ShowS
$cshowsPrec :: Int -> Volume -> ShowS
Show)

data RunAs = RunAsRoot | RunAsHostUID | RunAsAnyUID
  deriving (Int -> RunAs -> ShowS
[RunAs] -> ShowS
RunAs -> String
(Int -> RunAs -> ShowS)
-> (RunAs -> String) -> ([RunAs] -> ShowS) -> Show RunAs
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RunAs] -> ShowS
$cshowList :: [RunAs] -> ShowS
show :: RunAs -> String
$cshow :: RunAs -> String
showsPrec :: Int -> RunAs -> ShowS
$cshowsPrec :: Int -> RunAs -> ShowS
Show)

data Port = PortTcp Natural | PortUdp Natural
  deriving (Int -> Port -> ShowS
[Port] -> ShowS
Port -> String
(Int -> Port -> ShowS)
-> (Port -> String) -> ([Port] -> ShowS) -> Show Port
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Port] -> ShowS
$cshowList :: [Port] -> ShowS
show :: Port -> String
$cshow :: Port -> String
showsPrec :: Int -> Port -> ShowS
$cshowsPrec :: Int -> Port -> ShowS
Show)

newtype Name = Name {Name -> Text
unName :: Text}
  deriving (Int -> Name -> ShowS
[Name] -> ShowS
Name -> String
(Int -> Name -> ShowS)
-> (Name -> String) -> ([Name] -> ShowS) -> Show Name
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Name] -> ShowS
$cshowList :: [Name] -> ShowS
show :: Name -> String
$cshow :: Name -> String
showsPrec :: Int -> Name -> ShowS
$cshowsPrec :: Int -> Name -> ShowS
Show)

-- | The application context to be executed by podman or kubectl
data Context = Context
  { -- | identifier
    Context -> Name
_name :: Name,
    Context -> Maybe Text
_namespace :: Maybe Text,
    -- | container image name
    Context -> RuntimeContext
_runtimeCtx :: RuntimeContext,
    -- | network namespace name
    Context -> Bool
_network :: Bool,
    Context -> [Port]
_ports :: [Port],
    Context -> Maybe RunAs
_runAs :: Maybe RunAs,
    Context -> Bool
_selinux :: Bool,
    -- | the unique uid for this container
    Context -> UserID
_anyUid :: UserID,
    -- | host uid
    Context -> UserID
_uid :: UserID,
    -- | container command
    Context -> [Text]
_command :: [Text],
    Context -> Maybe String
_workdir :: Maybe FilePath,
    -- | container env
    Context -> Map Text Text
_environ :: Map Text Text,
    -- | container volumes
    Context -> Map String Volume
_mounts :: Map FilePath Volume,
    Context -> Set Capability
_syscaps :: Set.Set Capability,
    Context -> Bool
_ro :: Bool,
    -- | container devices
    Context -> Set String
_devices :: Set FilePath,
    Context -> Maybe Text
_hostname :: Maybe Text,
    Context -> Bool
_interactive :: Bool,
    Context -> Bool
_terminal :: Bool,
    Context -> Bool
_privileged :: Bool
  }
  deriving (Int -> Context -> ShowS
[Context] -> ShowS
Context -> String
(Int -> Context -> ShowS)
-> (Context -> String) -> ([Context] -> ShowS) -> Show Context
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Context] -> ShowS
$cshowList :: [Context] -> ShowS
show :: Context -> String
$cshow :: Context -> String
showsPrec :: Int -> Context -> ShowS
$cshowsPrec :: Int -> Context -> ShowS
Show)

$(makeLenses ''Context)

defaultContext :: Name -> RuntimeContext -> Context
defaultContext :: Name -> RuntimeContext -> Context
defaultContext Name
_name RuntimeContext
_runtimeCtx =
  Context :: Name
-> Maybe Text
-> RuntimeContext
-> Bool
-> [Port]
-> Maybe RunAs
-> Bool
-> UserID
-> UserID
-> [Text]
-> Maybe String
-> Map Text Text
-> Map String Volume
-> Set Capability
-> Bool
-> Set String
-> Maybe Text
-> Bool
-> Bool
-> Bool
-> Context
Context
    { Name
_name :: Name
$sel:_name:Context :: Name
_name,
      RuntimeContext
_runtimeCtx :: RuntimeContext
$sel:_runtimeCtx:Context :: RuntimeContext
_runtimeCtx,
      $sel:_command:Context :: [Text]
_command = [],
      $sel:_uid:Context :: UserID
_uid = UserID
0,
      $sel:_namespace:Context :: Maybe Text
_namespace = Maybe Text
forall a. Maybe a
Nothing,
      -- todo keep track of fresh uid
      $sel:_anyUid:Context :: UserID
_anyUid = UserID
4242,
      $sel:_selinux:Context :: Bool
_selinux = Bool
True,
      $sel:_network:Context :: Bool
_network = Bool
False,
      $sel:_ports:Context :: [Port]
_ports = [Port]
forall a. Monoid a => a
mempty,
      $sel:_runAs:Context :: Maybe RunAs
_runAs = Maybe RunAs
forall a. Maybe a
Nothing,
      $sel:_environ:Context :: Map Text Text
_environ = Map Text Text
forall a. Monoid a => a
mempty,
      $sel:_mounts:Context :: Map String Volume
_mounts = Map String Volume
forall a. Monoid a => a
mempty,
      $sel:_devices:Context :: Set String
_devices = Set String
forall a. Monoid a => a
mempty,
      $sel:_syscaps:Context :: Set Capability
_syscaps = Set Capability
forall a. Monoid a => a
mempty,
      -- TODO: make ro work for podman
      $sel:_ro:Context :: Bool
_ro = Bool
True,
      $sel:_workdir:Context :: Maybe String
_workdir = Maybe String
forall a. Maybe a
Nothing,
      $sel:_hostname:Context :: Maybe Text
_hostname = Maybe Text
forall a. Maybe a
Nothing,
      $sel:_interactive:Context :: Bool
_interactive = Bool
False,
      $sel:_terminal:Context :: Bool
_terminal = Bool
False,
      $sel:_privileged:Context :: Bool
_privileged = Bool
False
    }

rwHostPath :: FilePath -> Volume
rwHostPath :: String -> Volume
rwHostPath = Mode -> VolumeType -> Volume
MkVolume Mode
RW (VolumeType -> Volume)
-> (String -> VolumeType) -> String -> Volume
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> VolumeType
HostPath

roHostPath :: FilePath -> Volume
roHostPath :: String -> Volume
roHostPath = Mode -> VolumeType -> Volume
MkVolume Mode
RO (VolumeType -> Volume)
-> (String -> VolumeType) -> String -> Volume
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> VolumeType
HostPath

tmpfs :: Volume
tmpfs :: Volume
tmpfs = Mode -> VolumeType -> Volume
MkVolume Mode
RW VolumeType
TmpFS

-- Env and mounts head value takes priority
addEnv :: Text -> Text -> Context -> Context
addEnv :: Text -> Text -> Context -> Context
addEnv Text
k Text
v = (Map Text Text -> Identity (Map Text Text))
-> Context -> Identity Context
forall (f :: * -> *).
Functor f =>
(Map Text Text -> f (Map Text Text)) -> Context -> f Context
environ ((Map Text Text -> Identity (Map Text Text))
 -> Context -> Identity Context)
-> (Map Text Text -> Map Text Text) -> Context -> Context
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Text -> Text -> Text)
-> Text -> Text -> Map Text Text -> Map Text Text
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith (\Text
_n Text
o -> Text
o) Text
k Text
v

addMount :: FilePath -> Volume -> Context -> Context
addMount :: String -> Volume -> Context -> Context
addMount String
containerPath Volume
hostPath = (Map String Volume -> Identity (Map String Volume))
-> Context -> Identity Context
forall (f :: * -> *).
Functor f =>
(Map String Volume -> f (Map String Volume))
-> Context -> f Context
mounts ((Map String Volume -> Identity (Map String Volume))
 -> Context -> Identity Context)
-> (Map String Volume -> Map String Volume) -> Context -> Context
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Volume -> Volume -> Volume)
-> String -> Volume -> Map String Volume -> Map String Volume
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith (\Volume
_n Volume
o -> Volume
o) String
containerPath Volume
hostPath

directMount :: FilePath -> Context -> Context
directMount :: String -> Context -> Context
directMount String
fp = String -> Volume -> Context -> Context
addMount String
fp (String -> Volume
rwHostPath String
fp)

addDevice :: FilePath -> Context -> Context
addDevice :: String -> Context -> Context
addDevice String
dev = (Set String -> Identity (Set String))
-> Context -> Identity Context
forall (f :: * -> *).
Functor f =>
(Set String -> f (Set String)) -> Context -> f Context
devices ((Set String -> Identity (Set String))
 -> Context -> Identity Context)
-> (Set String -> Set String) -> Context -> Context
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ String -> Set String -> Set String
forall a. Ord a => a -> Set a -> Set a
Set.insert String
dev