{-# 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 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
{ :: [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
}
effectToRuncSpec :: Config -> Value -> Value
effectToRuncSpec :: Config -> Value -> Value
effectToRuncSpec Config
config Value
spec =
let defaultMounts :: [BindMount]
defaultMounts = [Text -> BindMount
defaultBindMount Text
"/nix/store"]
mounts :: Vector Value
mounts =
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
( \BindMount
bindMount ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
[Pair] -> Value
object
[ (Key
"destination", Text -> Value
String forall a b. (a -> b) -> a -> b
$ BindMount -> Text
pathInContainer BindMount
bindMount),
(Key
"source", Text -> Value
String forall a b. (a -> b) -> a -> b
$ BindMount -> Text
pathInHost BindMount
bindMount),
(Key
"type", Value
"bind"),
( Key
"options",
forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$
[Text
"bind" :: Text]
forall a. Semigroup a => a -> a -> a
<> [Text
"ro" | BindMount -> Bool
readOnly BindMount
bindMount]
)
]
)
([BindMount]
defaultMounts forall a. Semigroup a => a -> a -> a
<> Config -> [BindMount]
extraBindMounts Config
config)
in Value
spec
forall a b. a -> (a -> b) -> b
& forall t. AsValue t => Key -> Traversal' t Value
key Key
"process" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. AsValue t => Key -> Traversal' t Value
key Key
"args" forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. ToJSON a => a -> Value
toJSON ([Config -> Text
executable Config
config] forall a. Semigroup a => a -> a -> a
<> Config -> [Text]
arguments Config
config)
forall a b. a -> (a -> b) -> b
& forall t. AsValue t => Key -> Traversal' t Value
key Key
"mounts" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. AsValue t => Prism' t (Vector Value)
_Array forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall a. Semigroup a => a -> a -> a
<> Vector Value
mounts)
forall a b. a -> (a -> b) -> b
& forall t. AsValue t => Key -> Traversal' t Value
key Key
"process" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. AsValue t => Key -> Traversal' t Value
key Key
"terminal" forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. ToJSON a => a -> Value
toJSON Bool
True
forall a b. a -> (a -> b) -> b
& forall t. AsValue t => Key -> Traversal' t Value
key Key
"process" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. AsValue t => Key -> Traversal' t Value
key Key
"env" forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. ToJSON a => a -> Value
toJSON (Config
config forall a b. a -> (a -> b) -> b
& Config -> Map Text Text
environment forall a b. a -> (a -> b) -> b
& forall k a. Map k a -> [(k, a)]
M.toList forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(Text
k, Text
v) -> Text
k forall a. Semigroup a => a -> a -> a
<> Text
"=" forall a. Semigroup a => a -> a -> a
<> Text
v)
forall a b. a -> (a -> b) -> b
& forall t. AsValue t => Key -> Traversal' t Value
key Key
"process" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. AsValue t => Key -> Traversal' t Value
key Key
"cwd" forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. ToJSON a => a -> Value
toJSON (Config
config forall a b. a -> (a -> b) -> b
& Config -> Text
workingDirectory)
forall a b. a -> (a -> b) -> b
& forall t. AsValue t => Key -> Traversal' t Value
key Key
"hostname" forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. ToJSON a => a -> Value
toJSON (Config
config forall a b. a -> (a -> b) -> b
& Config -> Text
hostname)
forall a b. a -> (a -> b) -> b
& forall t. AsValue t => Key -> Traversal' t Value
key Key
"root" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. AsValue t => Key -> Traversal' t Value
key Key
"readonly" forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. ToJSON a => a -> Value
toJSON (Config
config forall a b. a -> (a -> b) -> b
& Config -> Bool
rootReadOnly)
run :: FilePath -> Config -> IO ExitCode
run :: String -> Config -> IO ExitCode
run String
dir Config
config = do
let runcExe :: String
runcExe = String
"runc"
createConfigJsonSpec :: CreateProcess
createConfigJsonSpec =
(String -> [String] -> CreateProcess
System.Process.proc String
runcExe [String
"spec", String
"--rootless"])
{ cwd :: Maybe String
cwd = forall a. a -> Maybe a
Just String
dir
}
configJsonPath :: String
configJsonPath = String
dir String -> String -> String
</> String
"config.json"
runcRootPath :: String
runcRootPath = String
dir String -> String -> String
</> String
"runc-root"
rootfsPath :: String
rootfsPath = String
dir String -> String -> String
</> String
"rootfs"
(ExitCode
exit, ByteString
_out, ByteString
err) <- CreateProcess
-> ByteString -> IO (ExitCode, ByteString, ByteString)
readCreateProcessWithExitCode CreateProcess
createConfigJsonSpec ByteString
""
case ExitCode
exit of
ExitCode
ExitSuccess -> forall (f :: * -> *). Applicative f => f ()
pass
ExitFailure Int
e -> do
forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText (OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode ByteString
err)
forall a. HasCallStack => Text -> a
panic forall a b. (a -> b) -> a -> b
$ Text
"Could not create container configuration template. runc terminated with exit code " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show Int
e
ByteString
templateBytes <- String -> IO ByteString
BS.readFile String
configJsonPath
Value
template <- case forall a. FromJSON a => ByteString -> Either String a
eitherDecode (ByteString -> ByteString
BL.fromStrict ByteString
templateBytes) of
Right Value
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
a
Left String
e -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (Text -> FatalError
FatalError forall a b. (a -> b) -> a -> b
$ Text
"decoding runc config.json template: " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show String
e)
let configJson :: Value
configJson = Config -> Value -> Value
effectToRuncSpec Config
config Value
template
String -> ByteString -> IO ()
BS.writeFile String
configJsonPath (ByteString -> ByteString
BL.toStrict forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> ByteString
encode Value
configJson)
String -> IO ()
createDirectory String
rootfsPath
String -> IO ()
createDirectory String
runcRootPath
String
name <- do
UUID
uuid <- IO UUID
UUID.nextRandom
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String
"hercules-ci-" forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show UUID
uuid
(ExitCode
exitCode, ()
_) <- forall a. ((Handle, Handle) -> IO a) -> IO a
withPseudoTerminalHandles forall a b. (a -> b) -> a -> b
$
\(Handle
master, Handle
terminal) -> do
forall a b. IO a -> IO b -> IO (a, b)
concurrently
( do
let createProcSpec :: CreateProcess
createProcSpec =
(String -> [String] -> CreateProcess
System.Process.proc String
runcExe [String
"--root", String
runcRootPath, String
"run", String
name])
{ std_in :: StdStream
std_in = Handle -> StdStream
UseHandle Handle
terminal,
std_out :: StdStream
std_out = Handle -> StdStream
UseHandle Handle
terminal,
std_err :: StdStream
std_err = Handle -> StdStream
UseHandle Handle
terminal,
cwd :: Maybe String
cwd = forall a. a -> Maybe a
Just String
dir
}
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
forall a b. IO a -> IO b -> IO a
`onException` ( do
forall (m :: * -> *). MonadIO m => Text -> m ()
putErrText Text
"Terminating effect process..."
ExitCode
_ <- forall a.
CreateProcess
-> (Maybe Handle
-> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
System.Process.withCreateProcess (String -> [String] -> CreateProcess
System.Process.proc String
runcExe [String
"kill", String
name]) \Maybe Handle
_ Maybe Handle
_ Maybe Handle
_ ProcessHandle
kh ->
ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
kh
Int -> IO ()
threadDelay Int
3_000_000
ExitCode
_ <- forall a.
CreateProcess
-> (Maybe Handle
-> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-> IO a
System.Process.withCreateProcess (String -> [String] -> CreateProcess
System.Process.proc String
runcExe [String
"kill", String
name, String
"KILL"]) \Maybe Handle
_ Maybe Handle
_ Maybe Handle
_ ProcessHandle
kh ->
ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
kh
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) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
ByteString
"" -> forall (f :: * -> *). Applicative f => f ()
pass
ByteString
someBytes | ByteString
"@nix" ByteString -> ByteString -> Bool
`BS.isPrefixOf` ByteString
someBytes -> do
IO ()
shovel
ByteString
someBytes -> do
Handle -> ByteString -> IO ()
BS.hPut Handle
stderr (ByteString
someBytes forall a. Semigroup a => a -> a -> a
<> ByteString
"\n")
IO ()
shovel
handleEOF :: IO ByteString -> IO ByteString
handleEOF = forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle \IOError
e -> if IOError -> IOErrorType
ioeGetErrorType IOError
e forall a. Eq a => a -> a -> Bool
== IOErrorType
HardwareFault then forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
"" else forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO IOError
e
IO ()
shovel
)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExitCode
exitCode
withPseudoTerminalHandles :: ((Handle, Handle) -> IO a) -> IO a
withPseudoTerminalHandles :: forall a. ((Handle, Handle) -> IO a) -> IO a
withPseudoTerminalHandles =
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 forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(SomeException
_ :: SomeException) -> forall (f :: * -> *). Applicative f => f ()
pass
Handle -> IO ()
hClose Handle
terminal forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(SomeException
_ :: SomeException) -> forall (f :: * -> *). Applicative f => f ()
pass
)
openPseudoTerminalHandles :: IO (Handle, Handle)
openPseudoTerminalHandles :: IO (Handle, Handle)
openPseudoTerminalHandles =
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
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Handle
master, Handle
terminal)
)
forall a b. IO a -> IO b -> IO a
`onException` do
Fd -> IO ()
closeFd Fd
masterFd
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Fd
terminalFd forall a. Eq a => a -> a -> Bool
/= Fd
masterFd) (Fd -> IO ()
closeFd Fd
terminalFd)