module Ribosome.Control.Concurrent.Wait where

import Control.Exception.Lifted (try)
import qualified Text.Show

import Ribosome.System.Time (sleep)

-- |Specifies the maximum number of retries and the interval in seconds for 'waitIO'.
data Retry =
  Retry Int Double
  deriving Int -> Retry -> ShowS
[Retry] -> ShowS
Retry -> String
(Int -> Retry -> ShowS)
-> (Retry -> String) -> ([Retry] -> ShowS) -> Show Retry
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Retry] -> ShowS
$cshowList :: [Retry] -> ShowS
show :: Retry -> String
$cshow :: Retry -> String
showsPrec :: Int -> Retry -> ShowS
$cshowsPrec :: Int -> Retry -> ShowS
Show

instance Default Retry where
  def :: Retry
def = Int -> Double -> Retry
Retry Int
20 Double
0.25

-- |Error description for 'waitIO'
data WaitError e =
  NotStarted
  |
  ConditionUnmet e
  |
  ∀ excp. Exception excp => Thrown excp

instance Show e => Show (WaitError e) where
  show :: WaitError e -> String
show WaitError e
NotStarted =
    String
"NotStarted"
  show (ConditionUnmet e
reason) =
    String
"ConditionUnmet(" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> e -> String
forall b a. (Show a, IsString b) => a -> b
show e
reason String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")"
  show (Thrown excp
_) =
    String
"Thrown"

-- |Execute an IO thunk repeatedly until either the supplied condition produces a 'Right' or the maximum number of
-- retries specified in the `Retry` parameter has been reached.
-- Returns the value produced by the condition.
waitIO ::
  MonadIO m =>
  MonadBaseControl IO m =>
  Retry ->
  m a ->
  (a -> m (Either e b)) ->
  m (Either (WaitError e) b)
waitIO :: Retry -> m a -> (a -> m (Either e b)) -> m (Either (WaitError e) b)
waitIO (Retry Int
maxRetry Double
interval) m a
thunk a -> m (Either e b)
cond =
  Int -> Either (WaitError e) b -> m (Either (WaitError e) b)
wait Int
maxRetry (WaitError e -> Either (WaitError e) b
forall a b. a -> Either a b
Left WaitError e
forall e. WaitError e
NotStarted)
  where
    wait :: Int -> Either (WaitError e) b -> m (Either (WaitError e) b)
wait Int
0 Either (WaitError e) b
reason = Either (WaitError e) b -> m (Either (WaitError e) b)
forall (m :: * -> *) a. Monad m => a -> m a
return Either (WaitError e) b
reason
    wait Int
count Either (WaitError e) b
_ = do
      Either SomeException a
ea <- m a -> m (Either SomeException a)
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> m (Either e a)
try m a
thunk
      Either SomeException (Either (WaitError e) b)
result <- m (Either (WaitError e) b)
-> m (Either SomeException (Either (WaitError e) b))
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> m (Either e a)
try (m (Either (WaitError e) b)
 -> m (Either SomeException (Either (WaitError e) b)))
-> m (Either (WaitError e) b)
-> m (Either SomeException (Either (WaitError e) b))
forall a b. (a -> b) -> a -> b
$ Either SomeException a -> m (Either (WaitError e) b)
check Either SomeException a
ea
      case Either SomeException (Either (WaitError e) b)
result of
        Right (Right b
a) ->
          Either (WaitError e) b -> m (Either (WaitError e) b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (WaitError e) b -> m (Either (WaitError e) b))
-> Either (WaitError e) b -> m (Either (WaitError e) b)
forall a b. (a -> b) -> a -> b
$ b -> Either (WaitError e) b
forall a b. b -> Either a b
Right b
a
        Right (Left WaitError e
reason) ->
          WaitError e -> Int -> m (Either (WaitError e) b)
recurse WaitError e
reason Int
count
        Left (SomeException e
e) ->
          WaitError e -> Int -> m (Either (WaitError e) b)
recurse (e -> WaitError e
forall e excp. Exception excp => excp -> WaitError e
Thrown e
e) Int
count
    recurse :: WaitError e -> Int -> m (Either (WaitError e) b)
recurse WaitError e
reason Int
count = do
      Double -> m ()
forall (m :: * -> *). MonadIO m => Double -> m ()
sleep Double
interval
      Int -> Either (WaitError e) b -> m (Either (WaitError e) b)
wait (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (WaitError e -> Either (WaitError e) b
forall a b. a -> Either a b
Left WaitError e
reason)
    check :: Either SomeException a -> m (Either (WaitError e) b)
check (Right a
a) =
      a -> m (Either e b)
cond a
a m (Either e b)
-> (Either e b -> Either (WaitError e) b)
-> m (Either (WaitError e) b)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
        Right b
b -> b -> Either (WaitError e) b
forall a b. b -> Either a b
Right b
b
        Left e
reason -> WaitError e -> Either (WaitError e) b
forall a b. a -> Either a b
Left (e -> WaitError e
forall e. e -> WaitError e
ConditionUnmet e
reason)
    check (Left (SomeException e
e)) =
      Either (WaitError e) b -> m (Either (WaitError e) b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (WaitError e) b -> m (Either (WaitError e) b))
-> Either (WaitError e) b -> m (Either (WaitError e) b)
forall a b. (a -> b) -> a -> b
$ WaitError e -> Either (WaitError e) b
forall a b. a -> Either a b
Left (e -> WaitError e
forall e excp. Exception excp => excp -> WaitError e
Thrown e
e)

-- |Calls 'waitIO' with the default configuration of 30 retries every 100ms.
waitIODef ::
  MonadIO m =>
  MonadBaseControl IO m =>
  m a ->
  (a -> m (Either e b)) ->
  m (Either (WaitError e) b)
waitIODef :: m a -> (a -> m (Either e b)) -> m (Either (WaitError e) b)
waitIODef =
  Retry -> m a -> (a -> m (Either e b)) -> m (Either (WaitError e) b)
forall (m :: * -> *) a e b.
(MonadIO m, MonadBaseControl IO m) =>
Retry -> m a -> (a -> m (Either e b)) -> m (Either (WaitError e) b)
waitIO Retry
forall a. Default a => a
def

-- |Same as 'waitIO', but the condition returns 'Bool' and the result is the result of the thunk.
waitIOPred ::
  MonadIO m =>
  MonadBaseControl IO m =>
  Retry ->
  m a ->
  (a -> m Bool) ->
  m (Either (WaitError Text) a)
waitIOPred :: Retry -> m a -> (a -> m Bool) -> m (Either (WaitError Text) a)
waitIOPred Retry
retry m a
thunk a -> m Bool
pred' =
  Retry
-> m a -> (a -> m (Either Text a)) -> m (Either (WaitError Text) a)
forall (m :: * -> *) a e b.
(MonadIO m, MonadBaseControl IO m) =>
Retry -> m a -> (a -> m (Either e b)) -> m (Either (WaitError e) b)
waitIO Retry
retry m a
thunk a -> m (Either Text a)
cond
  where
    cond :: a -> m (Either Text a)
cond a
a = a -> m Bool
pred' a
a m Bool -> (Bool -> Either Text a) -> m (Either Text a)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
      Bool
True -> a -> Either Text a
forall a b. b -> Either a b
Right a
a
      Bool
False -> Text -> Either Text a
forall a b. a -> Either a b
Left (Text
"predicate returned False" :: Text)

-- |Calls 'waitIOPred' with the default configuration of 30 retries every 100ms.
waitIOPredDef ::
  MonadIO m =>
  MonadBaseControl IO m =>
  m a ->
  (a -> m Bool) ->
  m (Either (WaitError Text) a)
waitIOPredDef :: m a -> (a -> m Bool) -> m (Either (WaitError Text) a)
waitIOPredDef =
  Retry -> m a -> (a -> m Bool) -> m (Either (WaitError Text) a)
forall (m :: * -> *) a.
(MonadIO m, MonadBaseControl IO m) =>
Retry -> m a -> (a -> m Bool) -> m (Either (WaitError Text) a)
waitIOPred Retry
forall a. Default a => a
def