{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Hercules.Effect.Container where

import Control.Lens
import Data.Aeson (Value (String), eitherDecode, encode, object, toJSON)
import Data.Aeson.Lens
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as BL
import Data.Map qualified as M
import Data.UUID.V4 qualified as UUID
import Data.Vector qualified as V
import GHC.IO.Exception (IOErrorType (HardwareFault))
import Protolude
import System.Directory (createDirectory)
import System.FilePath ((</>))
import System.IO (hClose)
import System.IO.Error (ioeGetErrorType)
import System.Posix.IO (closeFd, fdToHandle)
import System.Posix.Terminal (openPseudoTerminal)
import System.Process (CreateProcess (..), StdStream (UseHandle), proc, waitForProcess, withCreateProcess)
import System.Process.ByteString (readCreateProcessWithExitCode)

data BindMount = BindMount
  { BindMount -> Text
pathInContainer :: Text,
    BindMount -> Text
pathInHost :: Text,
    BindMount -> Bool
readOnly :: Bool
  }

defaultBindMount :: Text -> BindMount
defaultBindMount :: Text -> BindMount
defaultBindMount Text
path = BindMount {pathInContainer :: Text
pathInContainer = Text
path, pathInHost :: Text
pathInHost = Text
path, readOnly :: Bool
readOnly = Bool
True}

data Config = Config
  { Config -> [BindMount]
extraBindMounts :: [BindMount],
    Config -> Text
executable :: Text,
    Config -> [Text]
arguments :: [Text],
    Config -> Map Text Text
environment :: Map Text Text,
    Config -> Text
workingDirectory :: Text,
    Config -> Text
hostname :: Text,
    Config -> Bool
rootReadOnly :: Bool,
    Config -> Int
virtualUID :: Int,
    Config -> Int
virtualGID :: Int,
    Config -> Int
hostUID :: Int,
    Config -> Int
hostGID :: Int
  }

effectToOCIRuntimeSpec :: Config -> Value -> Value
effectToOCIRuntimeSpec :: Config -> Value -> Value
effectToOCIRuntimeSpec Config
config Value
spec =
  let defaultMounts :: [BindMount]
defaultMounts = [Text -> BindMount
defaultBindMount Text
"/nix/store"]
      mounts :: Vector Value
mounts =
        (BindMount -> Vector Value) -> [BindMount] -> Vector Value
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
          ( \BindMount
bindMount ->
              Value -> Vector Value
forall a. a -> Vector a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Vector Value) -> Value -> Vector Value
forall a b. (a -> b) -> a -> b
$
                [Pair] -> Value
object
                  [ (Key
"destination", Text -> Value
String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ BindMount -> Text
pathInContainer BindMount
bindMount),
                    (Key
"source", Text -> Value
String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ BindMount -> Text
pathInHost BindMount
bindMount),
                    (Key
"type", Value
"bind"),
                    ( Key
"options",
                      [Text] -> Value
forall a. ToJSON a => a -> Value
toJSON ([Text] -> Value) -> [Text] -> Value
forall a b. (a -> b) -> a -> b
$
                        [Text
"bind" :: Text]
                          [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
"ro" | BindMount -> Bool
readOnly BindMount
bindMount]
                    )
                  ]
          )
          ([BindMount]
defaultMounts [BindMount] -> [BindMount] -> [BindMount]
forall a. Semigroup a => a -> a -> a
<> Config -> [BindMount]
extraBindMounts Config
config)
   in Value
spec
        Value -> (Value -> Value) -> Value
forall a b. a -> (a -> b) -> b
& Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"process" ((Value -> Identity Value) -> Value -> Identity Value)
-> ((Value -> Identity Value) -> Value -> Identity Value)
-> (Value -> Identity Value)
-> Value
-> Identity Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"args" ((Value -> Identity Value) -> Value -> Identity Value)
-> Value -> Value -> Value
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Text] -> Value
forall a. ToJSON a => a -> Value
toJSON ([Config -> Text
executable Config
config] [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> Config -> [Text]
arguments Config
config)
        Value -> (Value -> Value) -> Value
forall a b. a -> (a -> b) -> b
& Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"mounts" ((Value -> Identity Value) -> Value -> Identity Value)
-> ((Vector Value -> Identity (Vector Value))
    -> Value -> Identity Value)
-> (Vector Value -> Identity (Vector Value))
-> Value
-> Identity Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Vector Value -> Identity (Vector Value))
-> Value -> Identity Value
forall t. AsValue t => Prism' t (Vector Value)
Prism' Value (Vector Value)
_Array ((Vector Value -> Identity (Vector Value))
 -> Value -> Identity Value)
-> (Vector Value -> Vector Value) -> Value -> Value
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Vector Value -> Vector Value -> Vector Value
forall a. Semigroup a => a -> a -> a
<> Vector Value
mounts)
        Value -> (Value -> Value) -> Value
forall a b. a -> (a -> b) -> b
& Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"process" ((Value -> Identity Value) -> Value -> Identity Value)
-> ((Value -> Identity Value) -> Value -> Identity Value)
-> (Value -> Identity Value)
-> Value
-> Identity Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"terminal" ((Value -> Identity Value) -> Value -> Identity Value)
-> Value -> Value -> Value
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool -> Value
forall a. ToJSON a => a -> Value
toJSON Bool
True
        Value -> (Value -> Value) -> Value
forall a b. a -> (a -> b) -> b
& Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"process" ((Value -> Identity Value) -> Value -> Identity Value)
-> ((Value -> Identity Value) -> Value -> Identity Value)
-> (Value -> Identity Value)
-> Value
-> Identity Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"env" ((Value -> Identity Value) -> Value -> Identity Value)
-> Value -> Value -> Value
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Text] -> Value
forall a. ToJSON a => a -> Value
toJSON (Config
config Config -> (Config -> Map Text Text) -> Map Text Text
forall a b. a -> (a -> b) -> b
& Config -> Map Text Text
environment Map Text Text
-> (Map Text Text -> [(Text, Text)]) -> [(Text, Text)]
forall a b. a -> (a -> b) -> b
& Map Text Text -> [(Text, Text)]
forall k a. Map k a -> [(k, a)]
M.toList [(Text, Text)] -> ((Text, Text) -> Text) -> [Text]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(Text
k, Text
v) -> Text
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
v)
        Value -> (Value -> Value) -> Value
forall a b. a -> (a -> b) -> b
& Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"process" ((Value -> Identity Value) -> Value -> Identity Value)
-> ((Value -> Identity Value) -> Value -> Identity Value)
-> (Value -> Identity Value)
-> Value
-> Identity Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"cwd" ((Value -> Identity Value) -> Value -> Identity Value)
-> Value -> Value -> Value
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Config
config Config -> (Config -> Text) -> Text
forall a b. a -> (a -> b) -> b
& Config -> Text
workingDirectory)
        Value -> (Value -> Value) -> Value
forall a b. a -> (a -> b) -> b
& Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"process" ((Value -> Identity Value) -> Value -> Identity Value)
-> ((Value -> Identity Value) -> Value -> Identity Value)
-> (Value -> Identity Value)
-> Value
-> Identity Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"user" ((Value -> Identity Value) -> Value -> Identity Value)
-> ((Value -> Identity Value) -> Value -> Identity Value)
-> (Value -> Identity Value)
-> Value
-> Identity Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"uid" ((Value -> Identity Value) -> Value -> Identity Value)
-> Value -> Value -> Value
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Int -> Value
forall a. ToJSON a => a -> Value
toJSON (Config -> Int
virtualUID Config
config)
        Value -> (Value -> Value) -> Value
forall a b. a -> (a -> b) -> b
& Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"process" ((Value -> Identity Value) -> Value -> Identity Value)
-> ((Value -> Identity Value) -> Value -> Identity Value)
-> (Value -> Identity Value)
-> Value
-> Identity Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"user" ((Value -> Identity Value) -> Value -> Identity Value)
-> ((Value -> Identity Value) -> Value -> Identity Value)
-> (Value -> Identity Value)
-> Value
-> Identity Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"gid" ((Value -> Identity Value) -> Value -> Identity Value)
-> Value -> Value -> Value
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Int -> Value
forall a. ToJSON a => a -> Value
toJSON (Config -> Int
virtualGID Config
config)
        Value -> (Value -> Value) -> Value
forall a b. a -> (a -> b) -> b
& Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"process" ((Value -> Identity Value) -> Value -> Identity Value)
-> ((Value -> Identity Value) -> Value -> Identity Value)
-> (Value -> Identity Value)
-> Value
-> Identity Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"user" ((Value -> Identity Value) -> Value -> Identity Value)
-> ((Value -> Identity Value) -> Value -> Identity Value)
-> (Value -> Identity Value)
-> Value
-> Identity Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"umask" ((Value -> Identity Value) -> Value -> Identity Value)
-> Value -> Value -> Value
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Int -> Value
forall a. ToJSON a => a -> Value
toJSON (Int
0o077 :: Int)
        Value -> (Value -> Value) -> Value
forall a b. a -> (a -> b) -> b
& Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"process" ((Value -> Identity Value) -> Value -> Identity Value)
-> ((Vector Value -> Identity (Vector Value))
    -> Value -> Identity Value)
-> (Vector Value -> Identity (Vector Value))
-> Value
-> Identity Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"user" ((Value -> Identity Value) -> Value -> Identity Value)
-> ((Vector Value -> Identity (Vector Value))
    -> Value -> Identity Value)
-> (Vector Value -> Identity (Vector Value))
-> Value
-> Identity Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"additionalGids" ((Value -> Identity Value) -> Value -> Identity Value)
-> ((Vector Value -> Identity (Vector Value))
    -> Value -> Identity Value)
-> (Vector Value -> Identity (Vector Value))
-> Value
-> Identity Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Vector Value -> Identity (Vector Value))
-> Value -> Identity Value
forall t. AsValue t => Prism' t (Vector Value)
Prism' Value (Vector Value)
_Array ((Vector Value -> Identity (Vector Value))
 -> Value -> Identity Value)
-> Vector Value -> Value -> Value
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Value] -> Vector Value
forall a. [a] -> Vector a
V.fromList []
        Value -> (Value -> Value) -> Value
forall a b. a -> (a -> b) -> b
& Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"linux" ((Value -> Identity Value) -> Value -> Identity Value)
-> ((Maybe (IxValue (KeyMap Value)) -> Identity (Maybe Value))
    -> Value -> Identity Value)
-> (Maybe (IxValue (KeyMap Value)) -> Identity (Maybe Value))
-> Value
-> Identity Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KeyMap Value -> Identity (KeyMap Value))
-> Value -> Identity Value
forall t. AsValue t => Prism' t (KeyMap Value)
Prism' Value (KeyMap Value)
_Object ((KeyMap Value -> Identity (KeyMap Value))
 -> Value -> Identity Value)
-> ((Maybe (IxValue (KeyMap Value)) -> Identity (Maybe Value))
    -> KeyMap Value -> Identity (KeyMap Value))
-> (Maybe (IxValue (KeyMap Value)) -> Identity (Maybe Value))
-> Value
-> Identity Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (KeyMap Value)
-> Lens' (KeyMap Value) (Maybe (IxValue (KeyMap Value)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Key
Index (KeyMap Value)
"uidMappings"
          ((Maybe (IxValue (KeyMap Value)) -> Identity (Maybe Value))
 -> Value -> Identity Value)
-> Value -> Value -> Value
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ [Value] -> Value
forall a. ToJSON a => a -> Value
toJSON
            [ [Pair] -> Value
object
                [ (Key
"containerID", Int -> Value
forall a. ToJSON a => a -> Value
toJSON (Config -> Int
virtualUID Config
config)),
                  (Key
"hostID", Int -> Value
forall a. ToJSON a => a -> Value
toJSON (Config -> Int
hostUID Config
config)),
                  (Key
"size", Int -> Value
forall a. ToJSON a => a -> Value
toJSON (Int
1 :: Int))
                ]
            ]
        Value -> (Value -> Value) -> Value
forall a b. a -> (a -> b) -> b
& Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"linux" ((Value -> Identity Value) -> Value -> Identity Value)
-> ((Maybe (IxValue (KeyMap Value)) -> Identity (Maybe Value))
    -> Value -> Identity Value)
-> (Maybe (IxValue (KeyMap Value)) -> Identity (Maybe Value))
-> Value
-> Identity Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KeyMap Value -> Identity (KeyMap Value))
-> Value -> Identity Value
forall t. AsValue t => Prism' t (KeyMap Value)
Prism' Value (KeyMap Value)
_Object ((KeyMap Value -> Identity (KeyMap Value))
 -> Value -> Identity Value)
-> ((Maybe (IxValue (KeyMap Value)) -> Identity (Maybe Value))
    -> KeyMap Value -> Identity (KeyMap Value))
-> (Maybe (IxValue (KeyMap Value)) -> Identity (Maybe Value))
-> Value
-> Identity Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (KeyMap Value)
-> Lens' (KeyMap Value) (Maybe (IxValue (KeyMap Value)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Key
Index (KeyMap Value)
"gidMappings"
          ((Maybe (IxValue (KeyMap Value)) -> Identity (Maybe Value))
 -> Value -> Identity Value)
-> Value -> Value -> Value
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ [Value] -> Value
forall a. ToJSON a => a -> Value
toJSON
            [ [Pair] -> Value
object
                [ (Key
"containerID", Int -> Value
forall a. ToJSON a => a -> Value
toJSON (Config -> Int
virtualGID Config
config)),
                  (Key
"hostID", Int -> Value
forall a. ToJSON a => a -> Value
toJSON (Config -> Int
hostGID Config
config)),
                  (Key
"size", Int -> Value
forall a. ToJSON a => a -> Value
toJSON (Int
1 :: Int))
                ]
            ]
        Value -> (Value -> Value) -> Value
forall a b. a -> (a -> b) -> b
& Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"hostname" ((Value -> Identity Value) -> Value -> Identity Value)
-> Value -> Value -> Value
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Config
config Config -> (Config -> Text) -> Text
forall a b. a -> (a -> b) -> b
& Config -> Text
hostname)
        Value -> (Value -> Value) -> Value
forall a b. a -> (a -> b) -> b
& Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"root" ((Value -> Identity Value) -> Value -> Identity Value)
-> ((Value -> Identity Value) -> Value -> Identity Value)
-> (Value -> Identity Value)
-> Value
-> Identity Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"readonly" ((Value -> Identity Value) -> Value -> Identity Value)
-> Value -> Value -> Value
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool -> Value
forall a. ToJSON a => a -> Value
toJSON (Config
config Config -> (Config -> Bool) -> Bool
forall a b. a -> (a -> b) -> b
& Config -> Bool
rootReadOnly)
        -- TODO Use slirp? e.g. https://github.com/rootless-containers/slirp4netns or might kernel offer bridging (in the future?)
        Value -> (Value -> Value) -> Value
forall a b. a -> (a -> b) -> b
& Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"linux" ((Value -> Identity Value) -> Value -> Identity Value)
-> ((Vector Value -> Identity (Vector Value))
    -> Value -> Identity Value)
-> (Vector Value -> Identity (Vector Value))
-> Value
-> Identity Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"namespaces" ((Value -> Identity Value) -> Value -> Identity Value)
-> ((Vector Value -> Identity (Vector Value))
    -> Value -> Identity Value)
-> (Vector Value -> Identity (Vector Value))
-> Value
-> Identity Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Vector Value -> Identity (Vector Value))
-> Value -> Identity Value
forall t. AsValue t => Prism' t (Vector Value)
Prism' Value (Vector Value)
_Array ((Vector Value -> Identity (Vector Value))
 -> Value -> Identity Value)
-> (Vector Value -> Vector Value) -> Value -> Value
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Value -> Bool) -> Vector Value -> Vector Value
forall a. (a -> Bool) -> Vector a -> Vector a
V.filter (\Value
x -> Value
x Value -> Getting (First Text) Value Text -> Maybe Text
forall s a. s -> Getting (First a) s a -> Maybe a
^? Key -> Traversal' Value Value
forall t. AsValue t => Key -> Traversal' t Value
key Key
"type" ((Value -> Const (First Text) Value)
 -> Value -> Const (First Text) Value)
-> Getting (First Text) Value Text
-> Getting (First Text) Value Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First Text) Value Text
forall t. AsValue t => Prism' t Text
Prism' Value Text
_String Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"network")

run :: FilePath -> Config -> IO ExitCode
run :: FilePath -> Config -> IO ExitCode
run FilePath
dir Config
config = do
  let containerRuntimeExe :: FilePath
containerRuntimeExe = FilePath
"crun"
      createConfigJsonSpec :: CreateProcess
createConfigJsonSpec =
        (FilePath -> [FilePath] -> CreateProcess
System.Process.proc FilePath
containerRuntimeExe [FilePath
"spec", FilePath
"--rootless"])
          { cwd :: Maybe FilePath
cwd = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
dir
          }
      configJsonPath :: FilePath
configJsonPath = FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
"config.json"
      runtimeRootPath :: FilePath
runtimeRootPath = FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
"container-root"
      rootfsPath :: FilePath
rootfsPath = FilePath
dir FilePath -> FilePath -> FilePath
</> FilePath
"rootfs"
  (ExitCode
exit, ByteString
_out, ByteString
err) <- CreateProcess
-> ByteString -> IO (ExitCode, ByteString, ByteString)
readCreateProcessWithExitCode CreateProcess
createConfigJsonSpec ByteString
""
  case ExitCode
exit of
    ExitCode
ExitSuccess -> IO ()
forall (f :: * -> *). Applicative f => f ()
pass
    ExitFailure Int
e -> do
      Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText (OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode ByteString
err)
      Text -> IO ()
forall a. HasCallStack => Text -> a
panic (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Could not create container configuration template. " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
forall a b. ConvertText a b => a -> b
toS FilePath
containerRuntimeExe Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" terminated with exit code " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a b. (Show a, StringConv FilePath b) => a -> b
show Int
e
  ByteString
templateBytes <- FilePath -> IO ByteString
BS.readFile FilePath
configJsonPath
  Value
template <- case ByteString -> Either FilePath Value
forall a. FromJSON a => ByteString -> Either FilePath a
eitherDecode (ByteString -> ByteString
BL.fromStrict ByteString
templateBytes) of
    Right Value
a -> Value -> IO Value
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
a
    Left FilePath
e -> FatalError -> IO Value
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (Text -> FatalError
FatalError (Text -> FatalError) -> Text -> FatalError
forall a b. (a -> b) -> a -> b
$ Text
"decoding container config.json template: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
forall a b. (Show a, StringConv FilePath b) => a -> b
show FilePath
e)
  let configJson :: Value
configJson = Config -> Value -> Value
effectToOCIRuntimeSpec Config
config Value
template
  FilePath -> ByteString -> IO ()
BS.writeFile FilePath
configJsonPath (ByteString -> ByteString
BL.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode Value
configJson)
  FilePath -> IO ()
createDirectory FilePath
rootfsPath
  FilePath -> IO ()
createDirectory FilePath
runtimeRootPath
  FilePath
name <- do
    UUID
uuid <- IO UUID
UUID.nextRandom
    FilePath -> IO FilePath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
"hercules-ci-" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> UUID -> FilePath
forall a b. (Show a, StringConv FilePath b) => a -> b
show UUID
uuid
  (ExitCode
exitCode, ()
_) <- ((Handle, Handle) -> IO (ExitCode, ())) -> IO (ExitCode, ())
forall a. ((Handle, Handle) -> IO a) -> IO a
withPseudoTerminalHandles (((Handle, Handle) -> IO (ExitCode, ())) -> IO (ExitCode, ()))
-> ((Handle, Handle) -> IO (ExitCode, ())) -> IO (ExitCode, ())
forall a b. (a -> b) -> a -> b
$
    \(Handle
master, Handle
terminal) -> do
      IO ExitCode -> IO () -> IO (ExitCode, ())
forall a b. IO a -> IO b -> IO (a, b)
concurrently
        ( do
            let createProcSpec :: CreateProcess
createProcSpec =
                  (FilePath -> [FilePath] -> CreateProcess
System.Process.proc FilePath
containerRuntimeExe [FilePath
"--root", FilePath
runtimeRootPath, FilePath
"run", FilePath
name])
                    { std_in :: StdStream
std_in = Handle -> StdStream
UseHandle Handle
terminal, -- can't pass /dev/null :(
                      std_out :: StdStream
std_out = Handle -> StdStream
UseHandle Handle
terminal,
                      std_err :: StdStream
std_err = Handle -> StdStream
UseHandle Handle
terminal,
                      cwd :: Maybe FilePath
cwd = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
dir
                    }
            CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO ExitCode)
-> IO ExitCode
forall a.
CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
withCreateProcess CreateProcess
createProcSpec \Maybe Handle
_subStdin Maybe Handle
_noOut Maybe Handle
_noErr ProcessHandle
processHandle -> do
              ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
processHandle
                IO ExitCode -> IO () -> IO ExitCode
forall a b. IO a -> IO b -> IO a
`onException` ( do
                                  Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText Text
"Terminating effect process..."
                                  ExitCode
_ <- CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO ExitCode)
-> IO ExitCode
forall a.
CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
System.Process.withCreateProcess (FilePath -> [FilePath] -> CreateProcess
System.Process.proc FilePath
containerRuntimeExe [FilePath
"kill", FilePath
name]) \Maybe Handle
_ Maybe Handle
_ Maybe Handle
_ ProcessHandle
kh ->
                                    ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
kh
                                  Int -> IO ()
threadDelay Int
3_000_000
                                  ExitCode
_ <- CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO ExitCode)
-> IO ExitCode
forall a.
CreateProcess
-> (Maybe Handle
    -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
System.Process.withCreateProcess (FilePath -> [FilePath] -> CreateProcess
System.Process.proc FilePath
containerRuntimeExe [FilePath
"kill", FilePath
name, FilePath
"KILL"]) \Maybe Handle
_ Maybe Handle
_ Maybe Handle
_ ProcessHandle
kh ->
                                    ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
kh
                                  Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText Text
"Killed effect process."
                              )
        )
        ( do
            let shovel :: IO ()
shovel =
                  IO ByteString -> IO ByteString
handleEOF (Handle -> IO ByteString
BS.hGetLine Handle
master) IO ByteString -> (ByteString -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                    ByteString
"" -> IO ()
forall (f :: * -> *). Applicative f => f ()
pass
                    ByteString
someBytes | ByteString
"@nix" ByteString -> ByteString -> Bool
`BS.isPrefixOf` ByteString
someBytes -> do
                      -- TODO use it (example @nix { "action": "setPhase", "phase": "effectPhase" })
                      IO ()
shovel
                    ByteString
someBytes -> do
                      Handle -> ByteString -> IO ()
BS.hPut Handle
stderr (ByteString
someBytes ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\n")
                      IO ()
shovel
                handleEOF :: IO ByteString -> IO ByteString
handleEOF = (IOError -> IO ByteString) -> IO ByteString -> IO ByteString
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle \IOError
e -> if IOError -> IOErrorType
ioeGetErrorType IOError
e IOErrorType -> IOErrorType -> Bool
forall a. Eq a => a -> a -> Bool
== IOErrorType
HardwareFault then ByteString -> IO ByteString
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
"" else IOError -> IO ByteString
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO IOError
e
            IO ()
shovel
        )
  ExitCode -> IO ExitCode
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExitCode
exitCode

-- | Like 'openPseudoTerminalHandles' but closes the handles after the
-- function is done.
withPseudoTerminalHandles :: ((Handle, Handle) -> IO a) -> IO a
withPseudoTerminalHandles :: forall a. ((Handle, Handle) -> IO a) -> IO a
withPseudoTerminalHandles =
  IO (Handle, Handle)
-> ((Handle, Handle) -> IO ())
-> ((Handle, Handle) -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
    IO (Handle, Handle)
openPseudoTerminalHandles
    ( \(Handle
master, Handle
terminal) -> do
        Handle -> IO ()
hClose Handle
master IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(SomeException
_ :: SomeException) -> IO ()
forall (f :: * -> *). Applicative f => f ()
pass
        Handle -> IO ()
hClose Handle
terminal IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(SomeException
_ :: SomeException) -> IO ()
forall (f :: * -> *). Applicative f => f ()
pass
    )

-- | Like 'openPseudoTerminal' but returning handles, in a resource-safe manner.
openPseudoTerminalHandles :: IO (Handle, Handle)
openPseudoTerminalHandles :: IO (Handle, Handle)
openPseudoTerminalHandles =
  IO (Handle, Handle) -> IO (Handle, Handle)
forall a. IO a -> IO a
mask_ do
    (Fd
masterFd, Fd
terminalFd) <- IO (Fd, Fd)
openPseudoTerminal

    ( do
        Handle
master <- Fd -> IO Handle
fdToHandle Fd
masterFd
        Handle
terminal <- Fd -> IO Handle
fdToHandle Fd
terminalFd
        (Handle, Handle) -> IO (Handle, Handle)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Handle
master, Handle
terminal)
      )
      IO (Handle, Handle) -> IO () -> IO (Handle, Handle)
forall a b. IO a -> IO b -> IO a
`onException` do
        Fd -> IO ()
closeFd Fd
masterFd
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Fd
terminalFd Fd -> Fd -> Bool
forall a. Eq a => a -> a -> Bool
/= Fd
masterFd) (Fd -> IO ()
closeFd Fd
terminalFd)