{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE OverloadedRecordDot #-}

{-|
Module      : Stack.Docker.Handlers
License     : BSD-3-Clause

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
  run <- RIO env (RIO env () -> IO ())
forall (m :: * -> *) a. MonadUnliftIO m => m (m a -> IO a)
askRunInIO
  oldHandlers <- forM signals $ \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
            -- Give the container 30 seconds to exit gracefully, then send a

            -- sigKILL to force it

            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]
    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
    pure (sig, oldHandler)
  let 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]
        ]
  finally
    (try $ proc "docker" args' $ runProcess_ . setDelegateCtlc False)
    ( do unless (docker.persist || docker.detach) $
           readProcessNull "docker" ["rm", "-f", containerID]
             `catch` (\(ExitCodeException
_ :: ExitCodeException) -> () -> RIO env ()
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
         forM_ oldHandlers $ \(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]