{-# LANGUAGE NoImplicitPrelude   #-}

-- | The module of this name differs as between Windows and non-Windows builds.

-- This is the non-Windows version.

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

-- MSS 2018-08-30 can the CPP below be removed entirely, and instead exec the

-- `docker` process so that it can handle the signals directly?

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 <- forall (m :: * -> *) a. MonadUnliftIO m => m (m a -> IO a)
askRunInIO
  [(CInt, Handler)]
oldHandlers <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [CInt]
signals forall a b. (a -> b) -> a -> b
$ \CInt
sig -> do
    let sigHandler :: IO ()
sigHandler = RIO env () -> IO ()
run forall a b. (a -> b) -> a -> b
$ do
          forall env.
(HasProcessContext env, HasLogFunc env, HasCallStack) =>
String -> [String] -> RIO env ()
readProcessNull
            String
"docker"
            [String
"kill", String
"--signal=" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show CInt
sig, String
containerID]
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt
sig forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CInt
sigTERM, CInt
sigABRT]) forall a b. (a -> b) -> a -> b
$ do
            -- Give the container 30 seconds to exit gracefully, then send a

            -- sigKILL to force it

            forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay Int
30000000
            forall env.
(HasProcessContext env, HasLogFunc env, HasCallStack) =>
String -> [String] -> RIO env ()
readProcessNull String
"docker" [String
"kill", String
containerID]
    Handler
oldHandler <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ CInt -> Handler -> Maybe SignalSet -> IO Handler
installHandler CInt
sig (IO () -> Handler
Catch IO ()
sigHandler) forall a. Maybe a
Nothing
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (CInt
sig, Handler
oldHandler)
  let args' :: [String]
args' = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [String
"start"]
        , [String
"-a" | Bool -> Bool
not (DockerOpts -> Bool
dockerDetach DockerOpts
docker)]
        , [String
"-i" | Bool
keepStdinOpen]
        , [String
containerID]
        ]
  forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
finally
    (forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try forall a b. (a -> b) -> a -> b
$ 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' forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ()
runProcess_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall stdin stdout stderr.
Bool
-> ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
setDelegateCtlc Bool
False)
    ( do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (DockerOpts -> Bool
dockerPersist DockerOpts
docker Bool -> Bool -> Bool
|| DockerOpts -> Bool
dockerDetach DockerOpts
docker) forall a b. (a -> b) -> a -> b
$
           forall env.
(HasProcessContext env, HasLogFunc env, HasCallStack) =>
String -> [String] -> RIO env ()
readProcessNull String
"docker" [String
"rm", String
"-f", String
containerID]
             forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` (\(ExitCodeException
_ :: ExitCodeException) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
         forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(CInt, Handler)]
oldHandlers forall a b. (a -> b) -> a -> b
$ \(CInt
sig, Handler
oldHandler) ->
           forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ CInt -> Handler -> Maybe SignalSet -> IO Handler
installHandler CInt
sig Handler
oldHandler forall a. Maybe a
Nothing
    )
 where
  signals :: [CInt]
signals = [CInt
sigINT, CInt
sigABRT, CInt
sigHUP, CInt
sigPIPE, CInt
sigTERM, CInt
sigUSR1, CInt
sigUSR2]