{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE CPP #-}

{- |
  This module contains data structures to describe the
  "warming-up" of componnts in order to ensure that they
   are properly configured:

   - createWarmup creates a warmup from an action
     returning a 'Result'

   - warmupOf takes a component name and unit action
     then just checks that the action executes without
     exception
-}
module Data.Registry.Warmup where

import qualified Control.Monad.Catch as Catch
import           Data.Semigroup      ((<>))
#if MIN_VERSION_GLASGOW_HASKELL(8,10,1,0)
import           Protolude           as P hiding ((<>))
#else
import           Protolude           as P hiding ((<>))
import           Data.Typeable
#endif

-- | A list of actions to run at startup
newtype Warmup =
  Warmup
  { Warmup -> [IO Result]
_warmUp :: [IO Result]
  } deriving (Semigroup Warmup
Warmup
Semigroup Warmup
-> Warmup
-> (Warmup -> Warmup -> Warmup)
-> ([Warmup] -> Warmup)
-> Monoid Warmup
[Warmup] -> Warmup
Warmup -> Warmup -> Warmup
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Warmup] -> Warmup
$cmconcat :: [Warmup] -> Warmup
mappend :: Warmup -> Warmup -> Warmup
$cmappend :: Warmup -> Warmup -> Warmup
mempty :: Warmup
$cmempty :: Warmup
$cp1Monoid :: Semigroup Warmup
Monoid, b -> Warmup -> Warmup
NonEmpty Warmup -> Warmup
Warmup -> Warmup -> Warmup
(Warmup -> Warmup -> Warmup)
-> (NonEmpty Warmup -> Warmup)
-> (forall b. Integral b => b -> Warmup -> Warmup)
-> Semigroup Warmup
forall b. Integral b => b -> Warmup -> Warmup
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> Warmup -> Warmup
$cstimes :: forall b. Integral b => b -> Warmup -> Warmup
sconcat :: NonEmpty Warmup -> Warmup
$csconcat :: NonEmpty Warmup -> Warmup
<> :: Warmup -> Warmup -> Warmup
$c<> :: Warmup -> Warmup -> Warmup
Semigroup)

-- * Creation functions

-- | Create a warmup action for a given component
--   The type of the component is used as the description for
--   the action to execute
warmupOf :: Typeable a => a -> IO () -> Warmup
warmupOf :: a -> IO () -> Warmup
warmupOf a
a IO ()
action = IO Result -> Warmup
createWarmup (IO Result -> Warmup) -> IO Result -> Warmup
forall a b. (a -> b) -> a -> b
$
  do Either SomeException ()
res <- IO () -> IO (Either SomeException ())
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
Catch.try IO ()
action :: IO (Either SomeException ())
     Result -> IO Result
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$
       case Either SomeException ()
res of
         Left SomeException
e  -> Text -> Result
failed (Text -> Result) -> Text -> Result
forall a b. (a -> b) -> a -> b
$ Text
"KO: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TypeRep -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show (a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf a
a) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" -> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SomeException -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show SomeException
e
         Right ()
_ -> Text -> Result
ok (Text -> Result) -> Text -> Result
forall a b. (a -> b) -> a -> b
$ Text
"OK: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TypeRep -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show (a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf a
a)

-- | Create a 'Warmup' from an 'IO' action returning a 'Result'
createWarmup :: IO Result -> Warmup
createWarmup :: IO Result -> Warmup
createWarmup IO Result
t = [IO Result] -> Warmup
Warmup [IO Result
t]

-- | The empty 'Warmup'
noWarmup :: Warmup
noWarmup :: Warmup
noWarmup = [IO Result] -> Warmup
Warmup [Result -> IO Result
forall (f :: * -> *) a. Applicative f => a -> f a
pure Result
Empty]

-- | Create a 'Warmup' with no action but just the type of a component
declareWarmup :: Typeable a => a -> Warmup
declareWarmup :: a -> Warmup
declareWarmup a
a = a -> IO () -> Warmup
forall a. Typeable a => a -> IO () -> Warmup
warmupOf a
a (() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

-- | Result of a 'Warmup'
data Result =
    Empty
  | Ok [Text]
  | Failed [Text]
  deriving (Result -> Result -> Bool
(Result -> Result -> Bool)
-> (Result -> Result -> Bool) -> Eq Result
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Result -> Result -> Bool
$c/= :: Result -> Result -> Bool
== :: Result -> Result -> Bool
$c== :: Result -> Result -> Bool
Eq, Int -> Result -> ShowS
[Result] -> ShowS
Result -> String
(Int -> Result -> ShowS)
-> (Result -> String) -> ([Result] -> ShowS) -> Show Result
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Result] -> ShowS
$cshowList :: [Result] -> ShowS
show :: Result -> String
$cshow :: Result -> String
showsPrec :: Int -> Result -> ShowS
$cshowsPrec :: Int -> Result -> ShowS
Show)

-- | Return 'True' if a 'Warmup' was successful
isSuccess :: Result -> Bool
isSuccess :: Result -> Bool
isSuccess Result
Empty      = Bool
True
isSuccess (Ok [Text]
_)     = Bool
True
isSuccess (Failed [Text]
_) = Bool
False

-- | Create a successful 'Result'
ok :: Text -> Result
ok :: Text -> Result
ok Text
t = [Text] -> Result
Ok [Text
t]

-- | Create a failed 'Result'
failed :: Text -> Result
failed :: Text -> Result
failed Text
t = [Text] -> Result
Failed [Text
t]

-- | Extract the list of all the messages from a 'Result'
messages :: Result -> [Text]
messages :: Result -> [Text]
messages Result
Empty       = []
messages (Ok [Text]
ms)     = [Text]
ms
messages (Failed [Text]
ms) = [Text]
ms

instance Monoid Result where
  mempty :: Result
mempty = Result
Empty
  mappend :: Result -> Result -> Result
mappend = Result -> Result -> Result
forall a. Semigroup a => a -> a -> a
(<>)

instance Semigroup Result where
  Result
r         <> :: Result -> Result -> Result
<> Result
Empty      = Result
r
  Result
Empty     <> Result
r          = Result
r
  Failed [Text]
ts <> Result
r          = [Text] -> Result
Failed ([Text]
ts [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Result -> [Text]
messages Result
r)
  Result
r         <> Failed [Text]
ts  = [Text] -> Result
Failed (Result -> [Text]
messages Result
r [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
ts)
  Ok [Text]
ts1    <> Ok [Text]
ts2     = [Text] -> Result
Ok ([Text]
ts1 [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
ts2)


-- * Run functions

-- | Simple sequential warmup strategy
runWarmup :: Warmup -> IO Result
runWarmup :: Warmup -> IO Result
runWarmup (Warmup [IO Result]
as) = (IO Result -> IO Result -> IO Result)
-> IO Result -> [IO Result] -> IO Result
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr' IO Result -> IO Result -> IO Result
runBoth (Result -> IO Result
forall (f :: * -> *) a. Applicative f => a -> f a
pure Result
Empty) [IO Result]
as

-- | 'runBoth' runs both tasks and cumulate the results
--   exceptions are being transformed into Failed results
runBoth :: IO Result -> IO Result -> IO Result
runBoth :: IO Result -> IO Result -> IO Result
runBoth IO Result
io1 IO Result
io2 = do
  Either SomeException Result
res1 <- IO Result -> IO (Either SomeException Result)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
Catch.try IO Result
io1 :: IO (Either SomeException Result)
  Either SomeException Result
res2 <- IO Result -> IO (Either SomeException Result)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
Catch.try IO Result
io2 :: IO (Either SomeException Result)
  Result -> IO Result
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$
    case (Either SomeException Result
res1, Either SomeException Result
res2) of
      (Right Result
r1, Right Result
r2) -> Result
r1               Result -> Result -> Result
forall a. Monoid a => a -> a -> a
`mappend` Result
r2
      (Left  SomeException
r1, Right Result
r2) -> Text -> Result
failed (SomeException -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show SomeException
r1) Result -> Result -> Result
forall a. Monoid a => a -> a -> a
`mappend` Result
r2
      (Right Result
r1, Left  SomeException
r2) -> Result
r1               Result -> Result -> Result
forall a. Monoid a => a -> a -> a
`mappend` Text -> Result
failed (SomeException -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show SomeException
r2)
      (Left  SomeException
r1, Left  SomeException
r2) -> [Text] -> Result
Failed [SomeException -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show SomeException
r1, SomeException -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show SomeException
r2]