module Hydra.Chain.BlockfrostSpec where

import Hydra.Prelude
import Test.Hspec

import Blockfrost.Client qualified as Client
import Control.Concurrent.Class.MonadSTM (newTVarIO, takeTMVar, writeTQueue)
import Control.Retry (RetryPolicyM, limitRetries)
import Control.Tracer (nullTracer)
import Control.Tracer.JSON (Tracer)
import Data.Text qualified as T
import Hydra.Cardano.Api (serialiseToRawBytesHexText)
import Hydra.Chain.Blockfrost (blockfrostSubmissionClient, memoizeIO, retryOnBlockfrostError)
import Hydra.Chain.Blockfrost.Client (APIBlockfrostError (..), BlockfrostException (..), TxHash (..), isRetryable, toCardanoAssetName)
import Hydra.Chain.Blockfrost.Client qualified as Blockfrost
import Hydra.Chain.Direct.Handlers (CardanoChainLog)
import Test.Hydra.Prelude (failAfter)
import Test.Hydra.Tx.Gen ()
import Test.QuickCheck (arbitrary, generate)

retry :: RetryPolicyM IO
retry :: RetryPolicyM IO
retry = Int -> RetryPolicy
limitRetries Int
3

spec :: Spec
spec :: Spec
spec = do
  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"toCardanoAssetName" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    -- Regression for #2923: getAssetDetails decodes asset_name: null as Nothing.
    String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"decodes a null asset name as empty" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
      AssetName
assetName <- Maybe Text -> IO AssetName
forall (m :: * -> *). MonadIO m => Maybe Text -> m AssetName
toCardanoAssetName Maybe Text
forall a. Maybe a
Nothing
      AssetName -> Text
forall a. SerialiseAsRawBytes a => a -> Text
serialiseToRawBytesHexText AssetName
assetName Text -> Text -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Text
""

    String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"decodes an explicitly empty asset name" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
      AssetName
assetName <- Maybe Text -> IO AssetName
forall (m :: * -> *). MonadIO m => Maybe Text -> m AssetName
toCardanoAssetName (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"")
      AssetName -> Text
forall a. SerialiseAsRawBytes a => a -> Text
serialiseToRawBytesHexText AssetName
assetName Text -> Text -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Text
""

    String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"decodes a nonempty asset name" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
      AssetName
assetName <- Maybe Text -> IO AssetName
forall (m :: * -> *). MonadIO m => Maybe Text -> m AssetName
toCardanoAssetName (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"6e7574636f696e")
      AssetName -> Text
forall a. SerialiseAsRawBytes a => a -> Text
serialiseToRawBytesHexText AssetName
assetName Text -> Text -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Text
"6e7574636f696e"

    String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"decodes binary asset names without treating them as text" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
      AssetName
assetName <- Maybe Text -> IO AssetName
forall (m :: * -> *). MonadIO m => Maybe Text -> m AssetName
toCardanoAssetName (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"00ff80")
      AssetName -> Text
forall a. SerialiseAsRawBytes a => a -> Text
serialiseToRawBytesHexText AssetName
assetName Text -> Text -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Text
"00ff80"

    String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"decodes a 32-byte asset name" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
      let nameHex :: Text
nameHex = Int -> Text -> Text
T.replicate Int
64 Text
"f"
      AssetName
assetName <- Maybe Text -> IO AssetName
forall (m :: * -> *). MonadIO m => Maybe Text -> m AssetName
toCardanoAssetName (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
nameHex)
      AssetName -> Text
forall a. SerialiseAsRawBytes a => a -> Text
serialiseToRawBytesHexText AssetName
assetName Text -> Text -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Text
nameHex

    [(String, Text)] -> ((String, Text) -> Spec) -> Spec
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_
      [ (String
"odd-length asset hex", Text
"a")
      , (String
"invalid asset hex", Text
"zz")
      , (String
"asset name longer than 32 bytes", Int -> Text -> Text
T.replicate Int
66 Text
"f")
      ]
      (((String, Text) -> Spec) -> Spec)
-> ((String, Text) -> Spec) -> Spec
forall a b. (a -> b) -> a -> b
$ \(String
caseName, Text
nameHex) ->
        String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it (String
"rejects " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
caseName) (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
          Maybe Text -> IO AssetName
forall (m :: * -> *). MonadIO m => Maybe Text -> m AssetName
toCardanoAssetName (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
nameHex) IO AssetName -> Selector APIBlockfrostError -> IO ()
forall e a.
(HasCallStack, Exception e) =>
IO a -> Selector e -> IO ()
`shouldThrow` \case
            BlockfrostClientError DeserialiseError{} -> Bool
True
            APIBlockfrostError
_ -> Bool
False

  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"rate-limit monitoring" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"counts every HTTP 429 including the response that exhausts retries" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
      IORef Int
responses <- Int -> IO (IORef Int)
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef (Int
0 :: Int)
      let onRateLimit :: IO ()
onRateLimit = IORef Int -> (Int -> Int) -> IO ()
forall (m :: * -> *) a. MonadIO m => IORef a -> (a -> a) -> m ()
modifyIORef' IORef Int
responses (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
          action :: Client.BlockfrostClientT IO ()
          action :: BlockfrostClientT IO ()
action = ExceptT BlockfrostError (ReaderT ClientConfig IO) ()
-> BlockfrostClientT IO ()
forall (m :: * -> *) a.
ExceptT BlockfrostError (ReaderT ClientConfig m) a
-> BlockfrostClientT m a
Client.BlockfrostClientT (ExceptT BlockfrostError (ReaderT ClientConfig IO) ()
 -> BlockfrostClientT IO ())
-> ExceptT BlockfrostError (ReaderT ClientConfig IO) ()
-> BlockfrostClientT IO ()
forall a b. (a -> b) -> a -> b
$ ReaderT ClientConfig IO (Either BlockfrostError ())
-> ExceptT BlockfrostError (ReaderT ClientConfig IO) ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (ReaderT ClientConfig IO (Either BlockfrostError ())
 -> ExceptT BlockfrostError (ReaderT ClientConfig IO) ())
-> ReaderT ClientConfig IO (Either BlockfrostError ())
-> ExceptT BlockfrostError (ReaderT ClientConfig IO) ()
forall a b. (a -> b) -> a -> b
$ Either BlockfrostError ()
-> ReaderT ClientConfig IO (Either BlockfrostError ())
forall a. a -> ReaderT ClientConfig IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either BlockfrostError ()
 -> ReaderT ClientConfig IO (Either BlockfrostError ()))
-> Either BlockfrostError ()
-> ReaderT ClientConfig IO (Either BlockfrostError ())
forall a b. (a -> b) -> a -> b
$ BlockfrostError -> Either BlockfrostError ()
forall a b. a -> Either a b
Left BlockfrostError
Client.BlockfrostUsageLimitReached
      IO ()
-> RetryPolicyM IO -> Project -> BlockfrostClientT IO () -> IO ()
forall (m :: * -> *) a.
(MonadIO m, MonadThrow m) =>
m () -> RetryPolicyM m -> Project -> BlockfrostClientT IO a -> m a
Blockfrost.runBlockfrostMWithObserver IO ()
onRateLimit RetryPolicyM IO
retry (Env -> Text -> Project
Client.Project Env
Client.Localhost Text
"unused") BlockfrostClientT IO ()
action
        IO () -> Selector APIBlockfrostError -> IO ()
forall e a.
(HasCallStack, Exception e) =>
IO a -> Selector e -> IO ()
`shouldThrow` \case
          APIBlockfrostError
BlockfrostRateLimited -> Bool
True
          APIBlockfrostError
_ -> Bool
False
      IORef Int -> IO Int
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef Int
responses IO Int -> Int -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` Int
4

    String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"counts rate limits without counting the eventual successful response" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
      IORef Int
responses <- Int -> IO (IORef Int)
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef (Int
0 :: Int)
      IORef Int
attempts <- Int -> IO (IORef Int)
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef (Int
0 :: Int)
      let onRateLimit :: IO ()
onRateLimit = IORef Int -> (Int -> Int) -> IO ()
forall (m :: * -> *) a. MonadIO m => IORef a -> (a -> a) -> m ()
modifyIORef' IORef Int
responses (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
          action :: BlockfrostClientT IO ()
action = ExceptT BlockfrostError (ReaderT ClientConfig IO) ()
-> BlockfrostClientT IO ()
forall (m :: * -> *) a.
ExceptT BlockfrostError (ReaderT ClientConfig m) a
-> BlockfrostClientT m a
Client.BlockfrostClientT (ExceptT BlockfrostError (ReaderT ClientConfig IO) ()
 -> BlockfrostClientT IO ())
-> ExceptT BlockfrostError (ReaderT ClientConfig IO) ()
-> BlockfrostClientT IO ()
forall a b. (a -> b) -> a -> b
$ ReaderT ClientConfig IO (Either BlockfrostError ())
-> ExceptT BlockfrostError (ReaderT ClientConfig IO) ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (ReaderT ClientConfig IO (Either BlockfrostError ())
 -> ExceptT BlockfrostError (ReaderT ClientConfig IO) ())
-> ReaderT ClientConfig IO (Either BlockfrostError ())
-> ExceptT BlockfrostError (ReaderT ClientConfig IO) ()
forall a b. (a -> b) -> a -> b
$ IO (Either BlockfrostError ())
-> ReaderT ClientConfig IO (Either BlockfrostError ())
forall a. IO a -> ReaderT ClientConfig IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either BlockfrostError ())
 -> ReaderT ClientConfig IO (Either BlockfrostError ()))
-> IO (Either BlockfrostError ())
-> ReaderT ClientConfig IO (Either BlockfrostError ())
forall a b. (a -> b) -> a -> b
$ do
            Int
n <- IORef Int -> (Int -> (Int, Int)) -> IO Int
forall (m :: * -> *) a b.
MonadIO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' IORef Int
attempts ((Int -> (Int, Int)) -> IO Int) -> (Int -> (Int, Int)) -> IO Int
forall a b. (a -> b) -> a -> b
$ \Int
previous -> (Int
previous Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
previous)
            Either BlockfrostError () -> IO (Either BlockfrostError ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either BlockfrostError () -> IO (Either BlockfrostError ()))
-> Either BlockfrostError () -> IO (Either BlockfrostError ())
forall a b. (a -> b) -> a -> b
$ if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 then BlockfrostError -> Either BlockfrostError ()
forall a b. a -> Either a b
Left BlockfrostError
Client.BlockfrostUsageLimitReached else () -> Either BlockfrostError ()
forall a b. b -> Either a b
Right ()
      IO ()
-> RetryPolicyM IO -> Project -> BlockfrostClientT IO () -> IO ()
forall (m :: * -> *) a.
(MonadIO m, MonadThrow m) =>
m () -> RetryPolicyM m -> Project -> BlockfrostClientT IO a -> m a
Blockfrost.runBlockfrostMWithObserver IO ()
onRateLimit RetryPolicyM IO
retry (Env -> Text -> Project
Client.Project Env
Client.Localhost Text
"unused") BlockfrostClientT IO ()
action
      IORef Int -> IO Int
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef Int
responses IO Int -> Int -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` Int
2
      IORef Int -> IO Int
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef Int
attempts IO Int -> Int -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` Int
3

  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"isRetryable" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"treats DecodeError as non-retryable" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
      Selector APIBlockfrostError
isRetryable (Text -> APIBlockfrostError
DecodeError Text
"some decode error") Bool -> Bool -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Bool
False

    String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"treats BlockfrostError as retryable" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
      Selector APIBlockfrostError
isRetryable (Text -> APIBlockfrostError
BlockfrostError Text
"some API error") Bool -> Bool -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Bool
True

    String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"treats BlockfrostRateLimited as retryable" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
      Selector APIBlockfrostError
isRetryable APIBlockfrostError
BlockfrostRateLimited Bool -> Bool -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Bool
True

  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"retryOnBlockfrostError" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"retries on transient APIBlockfrostError and eventually succeeds" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
      IORef Int
attemptsRef <- Int -> IO (IORef Int)
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef (Int
0 :: Int)
      Text
result <-
        Tracer IO CardanoChainLog
-> RetryPolicyM IO -> (RetryStatus -> IO Text) -> IO Text
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Tracer m CardanoChainLog
-> RetryPolicyM m -> (RetryStatus -> m a) -> m a
retryOnBlockfrostError (Tracer IO CardanoChainLog
forall (m :: * -> *) a. Monad m => Tracer m a
nullTracer :: Tracer IO CardanoChainLog) RetryPolicyM IO
retry ((RetryStatus -> IO Text) -> IO Text)
-> (RetryStatus -> IO Text) -> IO Text
forall a b. (a -> b) -> a -> b
$ IO Text -> RetryStatus -> IO Text
forall a b. a -> b -> a
const (IO Text -> RetryStatus -> IO Text)
-> IO Text -> RetryStatus -> IO Text
forall a b. (a -> b) -> a -> b
$ do
          Int
attempts <- IORef Int -> IO Int
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef Int
attemptsRef
          IORef Int -> Int -> IO ()
forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
writeIORef IORef Int
attemptsRef (Int
attempts Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
          if Int
attempts Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2
            then APIBlockfrostError -> IO Text
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (APIBlockfrostError -> IO Text) -> APIBlockfrostError -> IO Text
forall a b. (a -> b) -> a -> b
$ Text -> APIBlockfrostError
BlockfrostError Text
"transient error"
            else Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
"success" :: Text)
      Text
result Text -> Text -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Text
"success"
      Int
finalAttempts <- IORef Int -> IO Int
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef Int
attemptsRef
      Int
finalAttempts Int -> Int -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Int
3

    String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"gives up after max retries" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
      IORef Int
attemptsRef <- Int -> IO (IORef Int)
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef (Int
0 :: Int)
      let action :: IO Any
action = do
            IORef Int -> (Int -> Int) -> IO ()
forall (m :: * -> *) a. MonadIO m => IORef a -> (a -> a) -> m ()
modifyIORef IORef Int
attemptsRef (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
            APIBlockfrostError -> IO Any
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (APIBlockfrostError -> IO Any) -> APIBlockfrostError -> IO Any
forall a b. (a -> b) -> a -> b
$ Text -> APIBlockfrostError
BlockfrostError Text
"persistent error"
      Tracer IO CardanoChainLog
-> RetryPolicyM IO -> (RetryStatus -> IO Any) -> IO Any
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Tracer m CardanoChainLog
-> RetryPolicyM m -> (RetryStatus -> m a) -> m a
retryOnBlockfrostError (Tracer IO CardanoChainLog
forall (m :: * -> *) a. Monad m => Tracer m a
nullTracer :: Tracer IO CardanoChainLog) RetryPolicyM IO
retry (IO Any -> RetryStatus -> IO Any
forall a b. a -> b -> a
const IO Any
action)
        IO Any -> Selector APIBlockfrostError -> IO ()
forall e a.
(HasCallStack, Exception e) =>
IO a -> Selector e -> IO ()
`shouldThrow` \case
          BlockfrostError{} -> Bool
True
          APIBlockfrostError
_ -> Bool
False
      Int
finalAttempts <- IORef Int -> IO Int
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef Int
attemptsRef
      Int
finalAttempts Int -> Int -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Int
4

    String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"retries on HTTP error (BlockfrostError Text) and eventually succeeds" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
      IORef Int
attemptsRef <- Int -> IO (IORef Int)
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef (Int
0 :: Int)
      Text
result <-
        Tracer IO CardanoChainLog
-> RetryPolicyM IO -> (RetryStatus -> IO Text) -> IO Text
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Tracer m CardanoChainLog
-> RetryPolicyM m -> (RetryStatus -> m a) -> m a
retryOnBlockfrostError (Tracer IO CardanoChainLog
forall (m :: * -> *) a. Monad m => Tracer m a
nullTracer :: Tracer IO CardanoChainLog) RetryPolicyM IO
retry ((RetryStatus -> IO Text) -> IO Text)
-> (RetryStatus -> IO Text) -> IO Text
forall a b. (a -> b) -> a -> b
$ IO Text -> RetryStatus -> IO Text
forall a b. a -> b -> a
const (IO Text -> RetryStatus -> IO Text)
-> IO Text -> RetryStatus -> IO Text
forall a b. (a -> b) -> a -> b
$ do
          Int
attempts <- IORef Int -> IO Int
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef Int
attemptsRef
          IORef Int -> (Int -> Int) -> IO ()
forall (m :: * -> *) a. MonadIO m => IORef a -> (a -> a) -> m ()
modifyIORef IORef Int
attemptsRef (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
          if Int
attempts Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2
            then APIBlockfrostError -> IO Text
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (APIBlockfrostError -> IO Text) -> APIBlockfrostError -> IO Text
forall a b. (a -> b) -> a -> b
$ Text -> APIBlockfrostError
BlockfrostError Text
"HTTP 403 Forbidden"
            else Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
"success" :: Text)
      Text
result Text -> Text -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Text
"success"
      Int
finalAttempts <- IORef Int -> IO Int
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef Int
attemptsRef
      Int
finalAttempts Int -> Int -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Int
3

    String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"gives up after max retries on persistent HTTP error" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
      IORef Int
attemptsRef <- Int -> IO (IORef Int)
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef (Int
0 :: Int)
      let action :: IO Any
action = do
            IORef Int -> (Int -> Int) -> IO ()
forall (m :: * -> *) a. MonadIO m => IORef a -> (a -> a) -> m ()
modifyIORef IORef Int
attemptsRef (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
            APIBlockfrostError -> IO Any
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (APIBlockfrostError -> IO Any) -> APIBlockfrostError -> IO Any
forall a b. (a -> b) -> a -> b
$ Text -> APIBlockfrostError
BlockfrostError Text
"HTTP 403 Forbidden"
      Tracer IO CardanoChainLog
-> RetryPolicyM IO -> (RetryStatus -> IO Any) -> IO Any
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Tracer m CardanoChainLog
-> RetryPolicyM m -> (RetryStatus -> m a) -> m a
retryOnBlockfrostError (Tracer IO CardanoChainLog
forall (m :: * -> *) a. Monad m => Tracer m a
nullTracer :: Tracer IO CardanoChainLog) RetryPolicyM IO
retry (IO Any -> RetryStatus -> IO Any
forall a b. a -> b -> a
const IO Any
action)
        IO Any -> Selector APIBlockfrostError -> IO ()
forall e a.
(HasCallStack, Exception e) =>
IO a -> Selector e -> IO ()
`shouldThrow` \case
          BlockfrostError Text
_ -> Bool
True
          APIBlockfrostError
_ -> Bool
False
      Int
finalAttempts <- IORef Int -> IO Int
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef Int
attemptsRef
      Int
finalAttempts Int -> Int -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Int
4

    String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"does not retry on BlockfrostClientError" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
      IORef Int
attemptsRef <- Int -> IO (IORef Int)
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef (Int
0 :: Int)
      let action :: IO Any
action = do
            IORef Int -> (Int -> Int) -> IO ()
forall (m :: * -> *) a. MonadIO m => IORef a -> (a -> a) -> m ()
modifyIORef IORef Int
attemptsRef (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
            APIBlockfrostError -> IO Any
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (APIBlockfrostError -> IO Any) -> APIBlockfrostError -> IO Any
forall a b. (a -> b) -> a -> b
$ BlockfrostException -> APIBlockfrostError
BlockfrostClientError BlockfrostException
ByronAddressNotSupported
      Tracer IO CardanoChainLog
-> RetryPolicyM IO -> (RetryStatus -> IO Any) -> IO Any
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Tracer m CardanoChainLog
-> RetryPolicyM m -> (RetryStatus -> m a) -> m a
retryOnBlockfrostError (Tracer IO CardanoChainLog
forall (m :: * -> *) a. Monad m => Tracer m a
nullTracer :: Tracer IO CardanoChainLog) RetryPolicyM IO
retry (IO Any -> RetryStatus -> IO Any
forall a b. a -> b -> a
const IO Any
action)
        IO Any -> Selector APIBlockfrostError -> IO ()
forall e a.
(HasCallStack, Exception e) =>
IO a -> Selector e -> IO ()
`shouldThrow` \case
          BlockfrostClientError{} -> Bool
True
          APIBlockfrostError
_ -> Bool
False
      Int
finalAttempts <- IORef Int -> IO Int
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef Int
attemptsRef
      Int
finalAttempts Int -> Int -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Int
1

  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"memoizeIO" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"runs the action only once" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
      IORef Int
calls <- Int -> IO (IORef Int)
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef (Int
0 :: Int)
      TVar (Maybe Text)
var <- Maybe Text -> IO (TVar IO (Maybe Text))
forall a. a -> IO (TVar IO a)
forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a)
newTVarIO Maybe Text
forall a. Maybe a
Nothing
      [Text]
results <-
        Int -> IO Text -> IO [Text]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
5 (IO Text -> IO [Text]) -> IO Text -> IO [Text]
forall a b. (a -> b) -> a -> b
$
          TVar IO (Maybe Text) -> IO Text -> IO Text
forall a. TVar IO (Maybe a) -> IO a -> IO a
memoizeIO TVar (Maybe Text)
TVar IO (Maybe Text)
var (IO Text -> IO Text) -> IO Text -> IO Text
forall a b. (a -> b) -> a -> b
$ do
            IORef Int -> (Int -> Int) -> IO ()
forall (m :: * -> *) a. MonadIO m => IORef a -> (a -> a) -> m ()
modifyIORef' IORef Int
calls (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
            Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
"genesis" :: Text)
      [Text]
results [Text] -> [Text] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Int -> Text -> [Text]
forall a. Int -> a -> [a]
replicate Int
5 Text
"genesis"
      IORef Int -> IO Int
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef Int
calls IO Int -> Int -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` Int
1

    String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"does not run the action when the cache is already filled" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
      IORef Int
calls <- Int -> IO (IORef Int)
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef (Int
0 :: Int)
      TVar (Maybe Text)
var <- Maybe Text -> IO (TVar IO (Maybe Text))
forall a. a -> IO (TVar IO a)
forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a)
newTVarIO (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text
"cached" :: Text))
      Text
result <- TVar IO (Maybe Text) -> IO Text -> IO Text
forall a. TVar IO (Maybe a) -> IO a -> IO a
memoizeIO TVar (Maybe Text)
TVar IO (Maybe Text)
var (IORef Int -> (Int -> Int) -> IO ()
forall (m :: * -> *) a. MonadIO m => IORef a -> (a -> a) -> m ()
modifyIORef' IORef Int
calls (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) IO () -> Text -> IO Text
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Text
"fresh")
      Text
result Text -> Text -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Text
"cached"
      IORef Int -> IO Int
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef Int
calls IO Int -> Int -> IO ()
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> IO ()
`shouldReturn` Int
0

  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"blockfrostSubmissionClient" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$
    String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"reports submission failures immediately and keeps serving the queue" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
      NominalDiffTime -> IO () -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTimer m, MonadThrow m) =>
NominalDiffTime -> m a -> m a
failAfter NominalDiffTime
5 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        TQueue (Tx, TMVar (Maybe (PostTxError Tx)))
queue <- String -> IO (TQueue IO (Tx, TMVar (Maybe (PostTxError Tx))))
forall (m :: * -> *) a.
MonadLabelledSTM m =>
String -> m (TQueue m a)
newLabelledTQueueIO String
"test-submission-queue"
        IORef Int
calls <- Int -> IO (IORef Int)
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef (Int
0 :: Int)
        let submit :: Tx -> IO (Either Text TxHash)
submit Tx
_tx = do
              Int
n <- IORef Int -> (Int -> (Int, Int)) -> IO Int
forall (m :: * -> *) a b.
MonadIO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' IORef Int
calls ((Int -> (Int, Int)) -> IO Int) -> (Int -> (Int, Int)) -> IO Int
forall a b. (a -> b) -> a -> b
$ \Int
c -> (Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
c)
              Either Text TxHash -> IO (Either Text TxHash)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Text TxHash -> IO (Either Text TxHash))
-> Either Text TxHash -> IO (Either Text TxHash)
forall a b. (a -> b) -> a -> b
$
                if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
                  then Text -> Either Text TxHash
forall a b. a -> Either a b
Left Text
"submission failed"
                  else TxHash -> Either Text TxHash
forall a b. b -> Either a b
Right (Text -> TxHash
TxHash Text
"deadbeef")
        Tx
tx1 <- Gen Tx -> IO Tx
forall a. Gen a -> IO a
generate Gen Tx
forall a. Arbitrary a => Gen a
arbitrary
        Tx
tx2 <- Gen Tx -> IO Tx
forall a. Gen a -> IO a
generate Gen Tx
forall a. Arbitrary a => Gen a
arbitrary
        (String, IO ()) -> (Async IO () -> IO ()) -> IO ()
forall (m :: * -> *) a b.
MonadAsync m =>
(String, m a) -> (Async m a -> m b) -> m b
withAsyncLabelled (String
"blockfrost-submit", Tracer IO CardanoChainLog
-> (Tx -> IO (Either Text TxHash))
-> TQueue IO (Tx, TMVar IO (Maybe (PostTxError Tx)))
-> IO ()
forall (m :: * -> *).
MonadSTM m =>
Tracer m CardanoChainLog
-> (Tx -> m (Either Text TxHash))
-> TQueue m (Tx, TMVar m (Maybe (PostTxError Tx)))
-> m ()
blockfrostSubmissionClient (Tracer IO CardanoChainLog
forall (m :: * -> *) a. Monad m => Tracer m a
nullTracer :: Tracer IO CardanoChainLog) Tx -> IO (Either Text TxHash)
submit TQueue (Tx, TMVar (Maybe (PostTxError Tx)))
TQueue IO (Tx, TMVar IO (Maybe (PostTxError Tx)))
queue) ((Async IO () -> IO ()) -> IO ())
-> (Async IO () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Async IO ()
_ -> do
          Maybe (PostTxError Tx)
res1 <- TQueue IO (Tx, TMVar IO (Maybe (PostTxError Tx)))
-> Tx -> IO (Maybe (PostTxError Tx))
forall (m :: * -> *) a b.
MonadLabelledSTM m =>
TQueue m (a, TMVar m b) -> a -> m b
postViaQueue TQueue (Tx, TMVar (Maybe (PostTxError Tx)))
TQueue IO (Tx, TMVar IO (Maybe (PostTxError Tx)))
queue Tx
tx1
          Maybe (PostTxError Tx)
res1 Maybe (PostTxError Tx) -> (Maybe (PostTxError Tx) -> Bool) -> IO ()
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` Maybe (PostTxError Tx) -> Bool
forall a. Maybe a -> Bool
isJust
          Maybe (PostTxError Tx)
res2 <- TQueue IO (Tx, TMVar IO (Maybe (PostTxError Tx)))
-> Tx -> IO (Maybe (PostTxError Tx))
forall (m :: * -> *) a b.
MonadLabelledSTM m =>
TQueue m (a, TMVar m b) -> a -> m b
postViaQueue TQueue (Tx, TMVar (Maybe (PostTxError Tx)))
TQueue IO (Tx, TMVar IO (Maybe (PostTxError Tx)))
queue Tx
tx2
          Maybe (PostTxError Tx)
res2 Maybe (PostTxError Tx) -> (Maybe (PostTxError Tx) -> Bool) -> IO ()
forall a. (HasCallStack, Show a) => a -> (a -> Bool) -> IO ()
`shouldSatisfy` Maybe (PostTxError Tx) -> Bool
forall a. Maybe a -> Bool
isNothing
 where
  postViaQueue :: forall m a b. MonadLabelledSTM m => TQueue m (a, TMVar m b) -> a -> m b
  postViaQueue :: forall (m :: * -> *) a b.
MonadLabelledSTM m =>
TQueue m (a, TMVar m b) -> a -> m b
postViaQueue TQueue m (a, TMVar m b)
queue a
tx = do
    TMVar m b
response <- STM m (TMVar m b) -> m (TMVar m b)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (TMVar m b) -> m (TMVar m b))
-> STM m (TMVar m b) -> m (TMVar m b)
forall a b. (a -> b) -> a -> b
$ do
      TMVar m b
r <- String -> STM m (TMVar m b)
forall (m :: * -> *) a.
MonadLabelledSTM m =>
String -> STM m (TMVar m a)
newLabelledEmptyTMVar String
"test-response"
      TQueue m (a, TMVar m b) -> (a, TMVar m b) -> STM m ()
forall a. TQueue m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TQueue m a -> a -> STM m ()
writeTQueue TQueue m (a, TMVar m b)
queue (a
tx, TMVar m b
r)
      TMVar m b -> STM m (TMVar m b)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TMVar m b
r
    STM m b -> m b
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m b -> m b) -> STM m b -> m b
forall a b. (a -> b) -> a -> b
$ TMVar m b -> STM m b
forall a. TMVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TMVar m a -> STM m a
takeTMVar TMVar m b
response