{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- |
-- Module      : CLI.MonadCLI
-- License     : BSD3
-- Maintainer  : tbidne@gmail.com
-- The MonadCLI class.
module CLI.MonadCLI
  ( MonadCLI (..),
    runCLI,
  )
where

import App
import CLI.Internal
import CLI.Types.Env
import Common.IO
import Common.MonadLogger
import Common.RefinedUtils
import Common.Utils
import qualified Control.Concurrent.Async as A
import Control.Monad ((>=>))
import qualified Control.Monad.Loops as L
import qualified Control.Monad.Reader as R
import qualified Data.Maybe as May
import qualified Data.Text as T
import qualified System.Clock as C

-- | The 'MonadCLI' class is used to describe running a list
-- of 'T.Text' commands.
class Monad m => MonadCLI m where
  -- | Runs the list of commands.
  runCommands :: [T.Text] -> Maybe (RNonNegative Int) -> m ()

-- | `MonadCLI` instance for `IO`. Runs each command concurrently,
-- timing each one, and printing the outcome as success/failure.
instance MonadCLI IO where
  runCommands :: [T.Text] -> Maybe (RNonNegative Int) -> IO ()
  runCommands :: [Text] -> Maybe (RNonNegative Int) -> IO ()
runCommands commands :: [Text]
commands timeout :: Maybe (RNonNegative Int)
timeout = do
    TimeSpec
start <- Clock -> IO TimeSpec
C.getTime Clock
C.Monotonic
    Async ()
actionAsync <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
A.async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ (Text -> IO ()) -> [Text] -> IO ()
forall (f :: * -> *) a b. Foldable f => (a -> IO b) -> f a -> IO ()
A.mapConcurrently_ Text -> IO ()
runCommand [Text]
commands
    Async () -> Maybe (RNonNegative Int) -> IO ()
forall a. Async a -> Maybe (RNonNegative Int) -> IO ()
counter Async ()
actionAsync Maybe (RNonNegative Int)
timeout
    TimeSpec
end <- Clock -> IO TimeSpec
C.getTime Clock
C.Monotonic
    let totalTime :: RNonNegative Int
totalTime = TimeSpec -> TimeSpec -> RNonNegative Int
diffTime TimeSpec
start TimeSpec
end
    IO ()
forall (m :: * -> *). MonadLogger m => m ()
clearLine
    Text -> IO ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logInfoBlue "Finished!"
    Text -> IO ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logInfoBlue (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ "Total time elapsed: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> RNonNegative Int -> Text
formatSeconds RNonNegative Int
totalTime

instance MonadCLI m => MonadCLI (AppT Env m) where
  runCommands :: [Text] -> Maybe (RNonNegative Int) -> AppT Env m ()
runCommands cmds :: [Text]
cmds = m () -> AppT Env m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
R.lift (m () -> AppT Env m ())
-> (Maybe (RNonNegative Int) -> m ())
-> Maybe (RNonNegative Int)
-> AppT Env m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Maybe (RNonNegative Int) -> m ()
forall (m :: * -> *).
MonadCLI m =>
[Text] -> Maybe (RNonNegative Int) -> m ()
runCommands [Text]
cmds

-- | High level logic of `MonadCLI` usage. This function is the
-- entrypoint for any `MonadCLI` instance.
runCLI :: (R.MonadReader Env m, MonadCLI m) => m ()
runCLI :: m ()
runCLI = do
  Env {Map Text Text
legend :: Env -> Map Text Text
legend :: Map Text Text
legend, Maybe (RNonNegative Int)
timeout :: Env -> Maybe (RNonNegative Int)
timeout :: Maybe (RNonNegative Int)
timeout, [Text]
commands :: Env -> [Text]
commands :: [Text]
commands} <- m Env
forall r (m :: * -> *). MonadReader r m => m r
R.ask
  let commands' :: [Text]
commands' = Map Text Text -> [Text] -> [Text]
translateCommands Map Text Text
legend [Text]
commands
  [Text] -> Maybe (RNonNegative Int) -> m ()
forall (m :: * -> *).
MonadCLI m =>
[Text] -> Maybe (RNonNegative Int) -> m ()
runCommands [Text]
commands' Maybe (RNonNegative Int)
timeout

runCommand :: T.Text -> IO ()
runCommand :: Text -> IO ()
runCommand cmd :: Text
cmd = do
  Either (RNonNegative Int, Text) (RNonNegative Int, Text)
res <- Text
-> Maybe FilePath
-> IO (Either (RNonNegative Int, Text) (RNonNegative Int, Text))
tryTimeSh Text
cmd Maybe FilePath
forall a. Maybe a
Nothing
  (seconds :: RNonNegative Int
seconds, logFn :: Text -> IO ()
logFn, msg :: Text
msg) <- case Either (RNonNegative Int, Text) (RNonNegative Int, Text)
res of
    Left (t :: RNonNegative Int
t, err :: Text
err) -> (RNonNegative Int, Text -> IO (), Text)
-> IO (RNonNegative Int, Text -> IO (), Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RNonNegative Int
t, Text -> IO ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logError, Text
err)
    Right (t :: RNonNegative Int
t, _) -> (RNonNegative Int, Text -> IO (), Text)
-> IO (RNonNegative Int, Text -> IO (), Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RNonNegative Int
t, Text -> IO ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logInfoSuccess, "Successfully ran `" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cmd Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "`")
  IO ()
forall (m :: * -> *). MonadLogger m => m ()
clearLine
  Text -> IO ()
logFn Text
msg
  Text -> IO ()
logFn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ "Time elapsed: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> RNonNegative Int -> Text
formatSeconds RNonNegative Int
seconds Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\n"

counter :: A.Async a -> Maybe (RNonNegative Int) -> IO ()
counter :: Async a -> Maybe (RNonNegative Int) -> IO ()
counter asyn :: Async a
asyn timeout :: Maybe (RNonNegative Int)
timeout = do
  TimeSpec
start <- Clock -> IO TimeSpec
C.getTime Clock
C.Monotonic
  IO Bool -> IO () -> IO ()
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m ()
L.whileM_ (Async a -> TimeSpec -> Maybe (RNonNegative Int) -> IO Bool
forall a.
Async a -> TimeSpec -> Maybe (RNonNegative Int) -> IO Bool
keepRunning Async a
asyn TimeSpec
start Maybe (RNonNegative Int)
timeout) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Text -> Maybe FilePath -> IO ()
sh_ "sleep 1" Maybe FilePath
forall a. Maybe a
Nothing
    TimeSpec
elapsed <- Clock -> IO TimeSpec
C.getTime Clock
C.Monotonic
    let diff :: RNonNegative Int
diff = TimeSpec -> TimeSpec -> RNonNegative Int
diffTime TimeSpec
start TimeSpec
elapsed
    IO ()
forall (m :: * -> *). MonadLogger m => m ()
resetCR
    Text -> IO ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logNoLine (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ "Running time: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> RNonNegative Int -> Text
formatSeconds RNonNegative Int
diff

keepRunning :: A.Async a -> C.TimeSpec -> Maybe (RNonNegative Int) -> IO Bool
keepRunning :: Async a -> TimeSpec -> Maybe (RNonNegative Int) -> IO Bool
keepRunning asyn :: Async a
asyn start :: TimeSpec
start to :: Maybe (RNonNegative Int)
to = do
  Bool
running <- Async a -> IO Bool
forall a. Async a -> IO Bool
unfinished Async a
asyn
  TimeSpec
currTime <- Clock -> IO TimeSpec
C.getTime Clock
C.Monotonic
  let hasTimedOut :: Bool
hasTimedOut = TimeSpec -> TimeSpec -> Maybe (RNonNegative Int) -> Bool
timedOut TimeSpec
start TimeSpec
currTime Maybe (RNonNegative Int)
to
  if Bool
running Bool -> Bool -> Bool
&& Bool
hasTimedOut
    then do
      Async a -> IO ()
forall a. Async a -> IO ()
A.cancel Async a
asyn
      IO ()
forall (m :: * -> *). MonadLogger m => m ()
clearLine
      Text -> IO ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logWarn "Timed out, cancelling remaining tasks."
      Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    else Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
running

timedOut :: C.TimeSpec -> C.TimeSpec -> Maybe (RNonNegative Int) -> Bool
timedOut :: TimeSpec -> TimeSpec -> Maybe (RNonNegative Int) -> Bool
timedOut start :: TimeSpec
start curr :: TimeSpec
curr =
  \case
    Nothing -> Bool
False
    Just t :: RNonNegative Int
t ->
      let timeSoFar :: RNonNegative Int
timeSoFar = TimeSpec -> TimeSpec -> RNonNegative Int
diffTime TimeSpec
start TimeSpec
curr
       in RNonNegative Int
timeSoFar RNonNegative Int -> RNonNegative Int -> Bool
forall a. Ord a => a -> a -> Bool
> RNonNegative Int
t

unfinished :: A.Async a -> IO Bool
unfinished :: Async a -> IO Bool
unfinished = Async a -> IO (Maybe (Either SomeException a))
forall a. Async a -> IO (Maybe (Either SomeException a))
A.poll (Async a -> IO (Maybe (Either SomeException a)))
-> (Maybe (Either SomeException a) -> IO Bool)
-> Async a
-> IO Bool
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> IO Bool)
-> (Maybe (Either SomeException a) -> Bool)
-> Maybe (Either SomeException a)
-> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Either SomeException a) -> Bool
forall a. Maybe a -> Bool
May.isNothing