Hell.hs

runWithAsaModes
  :: ( AsaMode
      -> ( String
          -> YT.SIO (YT.YesodExampleData App) (AsaTestState Identity)
          -> SpecWith (Arg (YT.SIO (YT.YesodExampleData App) (AsaTestState Identity)))
         )
      -> SpecWith (Arg (YT.SIO (YT.YesodExampleData App) ()))
     )
  -> SpecWith (Arg (YT.SIO (YT.YesodExampleData App) ()))
runWithAsaModes cb = do
  -- The tmvar scheme is required because hspec tests cant communicate results to each other.
  -- The tests are run concurrently anyway so this makes sense from that perspective.
  nominalVar <- runIO $ newEmptyTMVarIO
  degradedVar <- runIO $ newEmptyTMVarIO
  let mkIt
        :: TMVar AsaTestResult
        -> String
        -> YT.SIO (YT.YesodExampleData App) (AsaTestState Identity)
        -> SpecWith (Arg (YT.SIO (YT.YesodExampleData App) (AsaTestState Identity)))
      mkIt var name action =
        it name $ do
          res <- try action
          case res of
            Left (err :: SomeException) -> do
              atomically $ putTMVar var TestFailed
              throwWithCallStack err
            Right ts -> do
              atomically $ putTMVar var $ TestFinished ts
              pure ts
  describe "ASA Fallback: Nominal" $ cb NominalPath (mkIt nominalVar)
  describe "ASA Fallback: Degraded" $ cb DegradedPath (mkIt degradedVar)
  it "ASA Fallback agreement" $ do
    (nomRes, degRes) <- atomically $ (,) <$> takeTMVar nominalVar <*> takeTMVar degradedVar
    nomState <- case nomRes of
      TestFailed -> assertFailure "Nominal test didn't pass"
      TestFinished nomState -> pure nomState
    degState <- case degRes of
      TestFailed -> assertFailure "Degraded test didn't pass"
      TestFinished degState -> pure degState
    YT.assertEq
      "Nominal and Degraded asa fallback modes disagree on lithic transaction state"
      (asaTestStateLithicTransactionState nomState)
      (asaTestStateLithicTransactionState degState)