{-# 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
  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
            -- 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]
    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]