{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedRecordDot #-}
module Stack.Docker.Handlers
( handleSetGroups
, handleSignals
) where
import RIO.Process
( ExitCodeException, proc, runProcess_, setDelegateCtlc )
import Stack.Prelude
import Stack.Types.Config ( HasConfig )
import Stack.Types.Docker ( DockerOpts (..) )
import System.Posix.Signals
( Handler (..), installHandler, sigABRT, sigHUP, sigINT
, sigPIPE, sigTERM, sigUSR1, sigUSR2
)
import qualified System.Posix.User as PosixUser
import System.PosixCompat.Types ( GroupID )
handleSetGroups :: [GroupID] -> IO ()
handleSetGroups :: [GroupID] -> IO ()
handleSetGroups = [GroupID] -> IO ()
PosixUser.setGroups
handleSignals ::
(Exception e, HasConfig env)
=> DockerOpts
-> Bool
-> String
-> RIO env (Either e ())
handleSignals :: forall e env.
(Exception e, HasConfig env) =>
DockerOpts -> Bool -> String -> RIO env (Either e ())
handleSignals DockerOpts
docker Bool
keepStdinOpen String
containerID = do
RIO env () -> IO ()
run <- RIO env (RIO env () -> IO ())
forall (m :: * -> *) a. MonadUnliftIO m => m (m a -> IO a)
askRunInIO
[(CInt, Handler)]
oldHandlers <- [CInt]
-> (CInt -> RIO env (CInt, Handler)) -> RIO env [(CInt, Handler)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [CInt]
signals ((CInt -> RIO env (CInt, Handler)) -> RIO env [(CInt, Handler)])
-> (CInt -> RIO env (CInt, Handler)) -> RIO env [(CInt, Handler)]
forall a b. (a -> b) -> a -> b
$ \CInt
sig -> do
let sigHandler :: IO ()
sigHandler = RIO env () -> IO ()
run (RIO env () -> IO ()) -> RIO env () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
String -> [String] -> RIO env ()
forall env.
(HasProcessContext env, HasLogFunc env, HasCallStack) =>
String -> [String] -> RIO env ()
readProcessNull
String
"docker"
[String
"kill", String
"--signal=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ CInt -> String
forall a. Show a => a -> String
show CInt
sig, String
containerID]
Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
sig CInt -> [CInt] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CInt
sigTERM, CInt
sigABRT]) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ do
Int -> RIO env ()
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay Int
30000000
String -> [String] -> RIO env ()
forall env.
(HasProcessContext env, HasLogFunc env, HasCallStack) =>
String -> [String] -> RIO env ()
readProcessNull String
"docker" [String
"kill", String
containerID]
Handler
oldHandler <- IO Handler -> RIO env Handler
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Handler -> RIO env Handler) -> IO Handler -> RIO env Handler
forall a b. (a -> b) -> a -> b
$ CInt -> Handler -> Maybe SignalSet -> IO Handler
installHandler CInt
sig (IO () -> Handler
Catch IO ()
sigHandler) Maybe SignalSet
forall a. Maybe a
Nothing
(CInt, Handler) -> RIO env (CInt, Handler)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CInt
sig, Handler
oldHandler)
let args' :: [String]
args' = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [String
"start"]
, [String
"-a" | Bool -> Bool
not DockerOpts
docker.detach]
, [String
"-i" | Bool
keepStdinOpen]
, [String
containerID]
]
RIO env (Either e ()) -> RIO env () -> RIO env (Either e ())
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
finally
(RIO env () -> RIO env (Either e ())
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (RIO env () -> RIO env (Either e ()))
-> RIO env () -> RIO env (Either e ())
forall a b. (a -> b) -> a -> b
$ String
-> [String] -> (ProcessConfig () () () -> RIO env ()) -> RIO env ()
forall env (m :: * -> *) a.
(HasProcessContext env, HasLogFunc env, MonadReader env m,
MonadIO m, HasCallStack) =>
String -> [String] -> (ProcessConfig () () () -> m a) -> m a
proc String
"docker" [String]
args' ((ProcessConfig () () () -> RIO env ()) -> RIO env ())
-> (ProcessConfig () () () -> RIO env ()) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ ProcessConfig () () () -> RIO env ()
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ()
runProcess_ (ProcessConfig () () () -> RIO env ())
-> (ProcessConfig () () () -> ProcessConfig () () ())
-> ProcessConfig () () ()
-> RIO env ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> ProcessConfig () () () -> ProcessConfig () () ()
forall stdin stdout stderr.
Bool
-> ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
setDelegateCtlc Bool
False)
( do Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (DockerOpts
docker.persist Bool -> Bool -> Bool
|| DockerOpts
docker.detach) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$
String -> [String] -> RIO env ()
forall env.
(HasProcessContext env, HasLogFunc env, HasCallStack) =>
String -> [String] -> RIO env ()
readProcessNull String
"docker" [String
"rm", String
"-f", String
containerID]
RIO env () -> (ExitCodeException -> RIO env ()) -> RIO env ()
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` (\(ExitCodeException
_ :: ExitCodeException) -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
[(CInt, Handler)]
-> ((CInt, Handler) -> RIO env Handler) -> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(CInt, Handler)]
oldHandlers (((CInt, Handler) -> RIO env Handler) -> RIO env ())
-> ((CInt, Handler) -> RIO env Handler) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ \(CInt
sig, Handler
oldHandler) ->
IO Handler -> RIO env Handler
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Handler -> RIO env Handler) -> IO Handler -> RIO env Handler
forall a b. (a -> b) -> a -> b
$ CInt -> Handler -> Maybe SignalSet -> IO Handler
installHandler CInt
sig Handler
oldHandler Maybe SignalSet
forall a. Maybe a
Nothing
)
where
signals :: [CInt]
signals = [CInt
sigINT, CInt
sigABRT, CInt
sigHUP, CInt
sigPIPE, CInt
sigTERM, CInt
sigUSR1, CInt
sigUSR2]