Rebase fixups

lib/core-integration/src/Test/Integration/Framework/DSL.hs

@@ -256,7 +256,7 @@ import Control.Exception
 import Control.Monad
     ( forM_, join, unless, void )
 import Control.Monad.Catch
-    ( MonadCatch, catch )
+    ( MonadCatch, catch, throwM )
 import Control.Monad.IO.Class
     ( MonadIO, liftIO )
 import Control.Monad.Trans.Resource
@@ -1396,16 +1396,17 @@ quitStakePool ctx (w, pass) = do
         (Link.quitStakePool w) Default payload
 
 quitStakePoolUnsigned
-    :: forall n style t w.
+    :: forall n style t w m.
         ( HasType (ApiT WalletId) w
         , DecodeAddress n
         , EncodeAddress n
+        , MonadIO m
         , Link.Discriminate style
         )
     => Context t
     -> w
-    -> IO (HTTP.Status, Either RequestException (ApiCoinSelection n))
-quitStakePoolUnsigned ctx w = do
+    -> m (HTTP.Status, Either RequestException (ApiCoinSelection n))
+quitStakePoolUnsigned ctx w = liftIO $ do
     let payload = Json [aesonQQ| {
             "delegation_action": { "action": "quit" }
         } |]
@@ -1620,7 +1621,7 @@ wantedErrorButSuccess = liftIO
     . show
 
 -- | Apply 'a' to all actions in sequence
-verify :: Show a => a -> [a -> IO ()] -> IO ()
+verify :: (Show a, MonadIO m, MonadCatch m) => a -> [a -> m ()] -> m ()
 verify a = counterexample msg . mapM_ (a &)
   where
     msg = "While verifying " ++ show a
@@ -1631,8 +1632,8 @@ verify a = counterexample msg . mapM_ (a &)
 -- >>>  (Status {statusCode = 200, statusMessage = "OK"},Right [])
 -- >>>        expected: 3
 -- >>>         but got: 0
-counterexample :: String -> IO a -> IO a
-counterexample msg = (`catch` (throwIO . appendFailureReason msg))
+counterexample :: (MonadIO m, MonadCatch m) => String -> m a -> m a
+counterexample msg = (`catch` (throwM . appendFailureReason msg))
 
 appendFailureReason :: String -> HUnitFailure -> HUnitFailure
 appendFailureReason message = wrap

lib/core-integration/src/Test/Integration/Scenario/API/Shelley/StakePools.hs

@@ -564,7 +564,7 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do
                 ]
 
     describe "STAKE_POOLS_JOIN_UNSIGNED_01" $ do
-        it "Can join a pool that's not retiring" $ \ctx -> do
+        it "Can join a pool that's not retiring" $ \ctx -> runResourceT $ do
             nonRetiredPools <- eventually "One of the pools should retire." $ do
                 response <- listPools ctx arbitraryStake
 
@@ -589,7 +589,7 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do
 
             -- Join Pool
             w <- fixtureWallet ctx
-            joinStakePoolUnsigned @n @'Shelley ctx w nonRetiringPoolId >>= \o -> do
+            liftIO $ joinStakePoolUnsigned @n @'Shelley ctx w nonRetiringPoolId >>= \o -> do
                 verify o
                     [ expectResponseCode HTTP.status200
                     , expectField #inputs (`shouldSatisfy` (not . null))
@@ -598,7 +598,7 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do
                     ]
 
     describe "STAKE_POOLS_JOIN_UNSIGNED_02"
-        $ it "Can join a pool that's retiring" $ \ctx -> do
+        $ it "Can join a pool that's retiring" $ \ctx -> runResourceT $ do
             nonRetiredPools <- eventually "One of the pools should retire." $ do
                 response <- listPools ctx arbitraryStake
 
@@ -618,7 +618,7 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do
                     $ nonRetiredPools
             -- Join Pool
             w <- fixtureWallet ctx
-            joinStakePoolUnsigned @n @'Shelley ctx w retiringPoolId >>= \o -> do
+            liftIO $ joinStakePoolUnsigned @n @'Shelley ctx w retiringPoolId >>= \o -> do
                 verify o
                     [ expectResponseCode HTTP.status200
                     , expectField #inputs (`shouldSatisfy` (not . null))
@@ -627,7 +627,7 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do
                     ]
 
     describe "STAKE_POOLS_JOIN_UNSIGNED_03"
-        $ it "Cannot join a pool that's retired" $ \ctx -> do
+        $ it "Cannot join a pool that's retired" $ \ctx -> runResourceT $ do
             nonRetiredPoolIds <- eventually "One of the pools should retire." $ do
                 response <- listPools ctx arbitraryStake
                 verify response [ expectListSize 3 ]
@@ -647,27 +647,27 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do
             let retiredPoolId =
                     fromMaybe reportError $ listToMaybe $ Set.toList retiredPoolIds
             w <- fixtureWallet ctx
-            r <- joinStakePoolUnsigned @n @'Shelley ctx w (ApiT retiredPoolId)
+            r <- liftIO $ joinStakePoolUnsigned @n @'Shelley ctx w (ApiT retiredPoolId)
             expectResponseCode HTTP.status404 r
             expectErrorMessage (errMsg404NoSuchPool (toText retiredPoolId)) r
 
     describe "STAKE_POOLS_JOIN_UNSIGNED_04"
-        $ it "Cannot join a pool that's never existed" $ \ctx -> do
+        $ it "Cannot join a pool that's never existed" $ \ctx -> runResourceT $ do
             (Right non_existing_pool_id) <- pure $ decodePoolIdBech32
                 "pool1y25deq9kldy9y9gfvrpw8zt05zsrfx84zjhugaxrx9ftvwdpua2"
             w <- fixtureWallet ctx
-            r <- joinStakePoolUnsigned @n @'Shelley ctx w (ApiT non_existing_pool_id)
+            r <- liftIO $ joinStakePoolUnsigned @n @'Shelley ctx w (ApiT non_existing_pool_id)
             expectResponseCode HTTP.status404 r
             expectErrorMessage (errMsg404NoSuchPool (toText non_existing_pool_id)) r
 
     describe "STAKE_POOLS_QUIT_UNSIGNED_01"
-        $ it "Can quit a joined pool" $ \ctx -> do
+        $ it "Can quit a joined pool" $ \ctx -> runResourceT $ do
             w <- fixtureWallet ctx
 
             pool:_ <- map (view #id) . snd <$> unsafeRequest @[ApiStakePool]
                 ctx (Link.listStakePools arbitraryStake) Empty
 
-            joinStakePool @n ctx pool (w, fixturePassphrase) >>= flip verify
+            liftIO $ joinStakePool @n ctx pool (w, fixturePassphrase) >>= flip verify
                 [ expectResponseCode HTTP.status202
                 , expectField (#status . #getApiT) (`shouldBe` Pending)
                 , expectField (#direction . #getApiT) (`shouldBe` Outgoing)
@@ -683,7 +683,7 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do
                 isValidCerts _ = False
 
             -- Quit Pool
-            quitStakePoolUnsigned @n @'Shelley ctx w >>= \o -> do
+            liftIO $ quitStakePoolUnsigned @n @'Shelley ctx w >>= \o -> do
                 verify o
                     [ expectResponseCode HTTP.status200
                     , expectField #inputs (`shouldSatisfy` (not . null))
@@ -693,7 +693,7 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do
                     ]
 
     describe "STAKE_POOLS_QUIT_UNSIGNED_02"
-        $ it "Cannot quit if not delegating" $ \ctx -> do
+        $ it "Cannot quit if not delegating" $ \ctx -> runResourceT $ do
             w <- fixtureWallet ctx
 
             quitStakePoolUnsigned @n @'Shelley ctx w >>= \r -> do

lib/core-integration/src/Test/Integration/Scenario/API/Shelley/Transactions.hs

@@ -603,7 +603,7 @@ spec = describe "SHELLEY_TRANSACTIONS" $ do
                 (#balance . #available)
                 (`shouldBe` Quantity (faucetAmt - feeEstMax - amt)) ra2
 
-    it "TRANS_CREATE_10 - Pending transaction expiry" $ \ctx -> do
+    it "TRANS_CREATE_10 - Pending transaction expiry" $ \ctx -> runResourceT $ do
         (wa, wb) <- (,) <$> fixtureWallet ctx <*> fixtureWallet ctx
         let amt = minUTxOValue :: Natural
 
@@ -869,7 +869,7 @@ spec = describe "SHELLEY_TRANSACTIONS" $ do
                 (`shouldBe` Quantity (faucetAmt - feeMin - amtSrc)) r''
 
         -- #2238 quick fix to reduce likelihood of rollback.
-        threadDelay $ 10 * oneSecond
+        liftIO $ threadDelay $ 10 * oneSecond
 
         let amtDest = (2_000_000 :: Natural)
 
@@ -1037,7 +1037,7 @@ spec = describe "SHELLEY_TRANSACTIONS" $ do
                 (`shouldBe` Quantity (faucetAmt - feeMin - amtSrc)) r''
 
         -- #2238 quick fix to reduce likelihood of rollback.
-        threadDelay $ 10 * oneSecond
+        liftIO $ threadDelay $ 10 * oneSecond
 
         let amtDest = (7_000_000 :: Natural)
 
@@ -1216,7 +1216,7 @@ spec = describe "SHELLEY_TRANSACTIONS" $ do
                     (`shouldBe` Quantity amtSrc) r'
 
             -- #2232 quick fix to reduce likelihood of rollback.
-            threadDelay $ 10 * oneSecond
+            liftIO $ threadDelay $ 10 * oneSecond
 
             let shelleyMnemonics =
                   [ "broken", "pass", "shrug", "pause", "crush"
@@ -1246,7 +1246,7 @@ spec = describe "SHELLEY_TRANSACTIONS" $ do
                     "passphrase": #{fixturePassphrase}
                     } |]
             r3 <- request @ApiWallet ctx (Link.postWallet @'Shelley) Default walletPostData
-            expectResponseCode @IO HTTP.status201 r3
+            expectResponseCode HTTP.status201 r3
             let wShelley = getFromResponse Prelude.id r3
 
             addrs <- listAddresses @n ctx wShelley
@@ -1292,7 +1292,7 @@ spec = describe "SHELLEY_TRANSACTIONS" $ do
                     (#balance . #available)
                     (`shouldBe` Quantity outChange) r''
 
-        it "Icarus wallet" $ \ctx -> do
+        it "Icarus wallet" $ \ctx -> runResourceT $ do
             -- Prepare src wIcarus wallet for external transaction
             wFaucet <- fixtureWallet ctx
 
@@ -1372,7 +1372,7 @@ spec = describe "SHELLEY_TRANSACTIONS" $ do
                     (`shouldBe` Quantity amtSrc) r'
 
             -- #2232 quick fix to reduce likelihood of rollback.
-            threadDelay $ 10 * oneSecond
+            liftIO $ threadDelay $ 10 * oneSecond
 
             -- Create Shelley destination wallet for external tx
             wShelley <- emptyWallet ctx

lib/shelley/bench/Latency.hs

@@ -108,7 +108,6 @@ import Test.Integration.Framework.DSL
     ( Context (..)
     , Headers (..)
     , Payload (..)
-    , deleteAllWallets
     , eventually
     , expectField
     , expectResponseCode