{-# LANGUAGE CPP #-}

module Test.Sandwich.WebDriver.Internal.Util where

import Control.Exception
import qualified Control.Exception.Lifted as E
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Trans.Control (MonadBaseControl)
import Control.Retry
import Data.Maybe
import Data.String.Interpolate
import qualified Data.Text as T
import System.Directory
import System.Process
import qualified System.Random as R
import Test.Sandwich.Logging

#ifdef mingw32_HOST_OS
import System.IO
#endif


-- * Truncating log files

moveAndTruncate :: FilePath -> String -> IO ()
moveAndTruncate :: String -> String -> IO ()
moveAndTruncate String
from String
to = do
  Bool
exists <- String -> IO Bool
doesFileExist String
from
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists forall a b. (a -> b) -> a -> b
$ do
    String -> String -> IO ()
copyFile String
from String
to
    String -> IO ()
tryTruncateFile String
from

  where
    tryTruncateFile :: FilePath -> IO ()
    tryTruncateFile :: String -> IO ()
tryTruncateFile String
path = forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
E.catch (String -> IO ()
truncateFile String
path)
                                   (\(SomeException
e :: E.SomeException) -> String -> IO ()
putStrLn [i|Failed to truncate file #{path}: #{e}|])

    truncateFile :: FilePath -> IO ()
#ifdef mingw32_HOST_OS
    truncateFile path = withFile path WriteMode $ flip hPutStr "\n" -- Not exactly truncation, but close enough?
#else
    truncateFile :: String -> IO ()
truncateFile String
path = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ CreateProcess -> String -> IO String
readCreateProcess (String -> CreateProcess
shell [i|> #{path}|]) String
""
#endif

-- * Exceptions

leftOnException :: (MonadIO m, MonadBaseControl IO m) => m (Either T.Text a) -> m (Either T.Text a)
leftOnException :: forall (m :: * -> *) a.
(MonadIO m, MonadBaseControl IO m) =>
m (Either Text a) -> m (Either Text a)
leftOnException = forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
(e -> m a) -> m a -> m a
E.handle (\(SomeException
e :: SomeException) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show SomeException
e)

leftOnException' :: (MonadIO m, MonadBaseControl IO m) => m a -> m (Either T.Text a)
leftOnException' :: forall (m :: * -> *) a.
(MonadIO m, MonadBaseControl IO m) =>
m a -> m (Either Text a)
leftOnException' m a
action = forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
E.catch (forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
action) (\(SomeException
e :: SomeException) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show SomeException
e)

-- * Util

whenJust :: (Monad m) => Maybe a -> (a -> m b) -> m ()
whenJust :: forall (m :: * -> *) a b. Monad m => Maybe a -> (a -> m b) -> m ()
whenJust Maybe a
Nothing a -> m b
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
whenJust (Just a
x) a -> m b
action = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ a -> m b
action a
x

whenLeft :: (Monad m) => Either a b -> (a -> m ()) -> m ()
whenLeft :: forall (m :: * -> *) a b.
Monad m =>
Either a b -> (a -> m ()) -> m ()
whenLeft (Left a
x) a -> m ()
action = a -> m ()
action a
x
whenLeft (Right b
_) a -> m ()
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()

whenRight :: (Monad m) => Either a b -> (b -> m ()) -> m ()
whenRight :: forall (m :: * -> *) a b.
Monad m =>
Either a b -> (b -> m ()) -> m ()
whenRight (Left a
_) b -> m ()
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
whenRight (Right b
x) b -> m ()
action = b -> m ()
action b
x

makeUUID :: IO T.Text
makeUUID :: IO Text
makeUUID = (String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
take Int
10 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a g. (Random a, RandomGen g) => (a, a) -> g -> [a]
R.randomRs (Char
'a',Char
'z')) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadIO m => m StdGen
R.newStdGen

-- * Stopping processes

gracefullyStopProcess :: (MonadIO m, MonadLogger m) => ProcessHandle -> Int -> m ()
gracefullyStopProcess :: forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
ProcessHandle -> Int -> m ()
gracefullyStopProcess ProcessHandle
p Int
gracePeriodUs = do
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ProcessHandle -> IO ()
interruptProcessGroupOf ProcessHandle
p
  forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
ProcessHandle -> Int -> m ()
gracefullyWaitForProcess ProcessHandle
p Int
gracePeriodUs

gracefullyWaitForProcess :: (MonadIO m, MonadLogger m) => ProcessHandle -> Int -> m ()
gracefullyWaitForProcess :: forall (m :: * -> *).
(MonadIO m, MonadLogger m) =>
ProcessHandle -> Int -> m ()
gracefullyWaitForProcess ProcessHandle
p Int
gracePeriodUs = do
  let waitForExit :: m (Maybe ExitCode)
waitForExit = do
        let policy :: RetryPolicyM m
policy = forall (m :: * -> *).
Monad m =>
Int -> RetryPolicyM m -> RetryPolicyM m
limitRetriesByCumulativeDelay Int
gracePeriodUs forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
Monad m =>
Int -> RetryPolicyM m -> RetryPolicyM m
capDelay Int
200_000 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Monad m => Int -> RetryPolicyM m
exponentialBackoff Int
1_000
        forall (m :: * -> *) b.
MonadIO m =>
RetryPolicyM m
-> (RetryStatus -> b -> m Bool) -> (RetryStatus -> m b) -> m b
retrying RetryPolicyM m
policy (\RetryStatus
_ Maybe ExitCode
x -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Maybe a -> Bool
isNothing Maybe ExitCode
x) forall a b. (a -> b) -> a -> b
$ \RetryStatus
_ -> do
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ProcessHandle -> IO (Maybe ExitCode)
getProcessExitCode ProcessHandle
p

  m (Maybe ExitCode)
waitForExit forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just ExitCode
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Maybe ExitCode
Nothing -> do
      Maybe Pid
pid <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ProcessHandle -> IO (Maybe Pid)
getPid ProcessHandle
p
      forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
warn [i|(#{pid}) Process didn't stop after #{gracePeriodUs}us; trying to interrupt|]

      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ProcessHandle -> IO ()
interruptProcessGroupOf ProcessHandle
p
      m (Maybe ExitCode)
waitForExit forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just ExitCode
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Maybe ExitCode
Nothing -> forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ do
          forall (m :: * -> *). (HasCallStack, MonadLogger m) => Text -> m ()
warn [i|(#{pid}) Process didn't stop after a further #{gracePeriodUs}us; going to kill|]
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ProcessHandle -> IO ()
terminateProcess ProcessHandle
p
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
p