SCP-2380: Fixed Future trace in plutus-use-cases-scripts (IntersectMB…

…O#3457)
sarvex · Jul 1, 2021 · abbfd1c · abbfd1c
1 parent 8c42e1f
commit abbfd1c
Show file tree

Hide file tree

Showing 3 changed files with 62 additions and 46 deletions.
diff --git a/plutus-use-cases/scripts/Main.hs b/plutus-use-cases/scripts/Main.hs
@@ -1,15 +1,13 @@
 module Main(main) where
 
 import qualified Control.Foldl                  as L
-import           Control.Lens
 import           Control.Monad.Freer            (run)
 import qualified Data.ByteString.Lazy           as BSL
 import           Data.Default                   (Default (..))
 import           Data.Foldable                  (traverse_)
 import           Flat                           (flat)
 import           Ledger.Index                   (ScriptValidationEvent (sveScript))
-import           Plutus.Contract.Test           (Wallet (Wallet), defaultDist)
-import           Plutus.Trace.Emulator          (EmulatorTrace)
+import           Plutus.Trace.Emulator          (EmulatorConfig, EmulatorTrace)
 import qualified Plutus.Trace.Emulator          as Trace
 import           Plutus.V1.Ledger.Scripts       (Script (..))
 import qualified Streaming.Prelude              as S
@@ -48,31 +46,31 @@ main = do
 writeScripts :: FilePath -> IO ()
 writeScripts fp = do
     putStrLn $ "Writing scripts to: " <> fp
-    traverse_ (uncurry (writeScriptsTo fp))
-        [ ("auction_1", Auction.auctionTrace1)
-        , ("auction_2", Auction.auctionTrace2)
-        , ("crowdfunding-success", Crowdfunding.successfulCampaign)
-        , ("currency", Currency.currencyTrace)
-        , ("escrow-redeem_1", Escrow.redeemTrace)
-        , ("escrow-redeem_2", Escrow.redeem2Trace)
-        , ("escrow-refund", Escrow.refundTrace)
-        , ("future-increase-margin", Future.increaseMarginTrace)
-        , ("future-settle-early", Future.settleEarlyTrace)
-        , ("future-pay-out", Future.payOutTrace)
-        , ("game-sm-success", GameStateMachine.successTrace)
-        , ("game-sm-success_2", GameStateMachine.successTrace2)
-        , ("multisig-success", MultiSig.succeedingTrace)
-        , ("multisig-failure", MultiSig.failingTrace)
-        , ("multisig-sm", MultiSigStateMachine.lockProposeSignPay 3 2)
-        , ("ping-pong", PingPong.pingPongTrace)
-        , ("ping-pong_2", PingPong.twoPartiesTrace)
-        , ("prism", Prism.prismTrace)
-        , ("pubkey", PubKey.pubKeyTrace)
-        , ("stablecoin_1", Stablecoin.stablecoinTrace)
-        , ("stablecoin_2", Stablecoin.maxReservesExceededTrace)
-        , ("token-account", TokenAccount.tokenAccountTrace)
-        , ("vesting", Vesting.retrieveFundsTrace)
-        , ("uniswap", Uniswap.uniswapTrace)
+    traverse_ (uncurry3 (writeScriptsTo fp))
+        [ ("auction_1", Auction.auctionTrace1, Auction.auctionEmulatorCfg)
+        , ("auction_2", Auction.auctionTrace2, Auction.auctionEmulatorCfg)
+        , ("crowdfunding-success", Crowdfunding.successfulCampaign, def)
+        , ("currency", Currency.currencyTrace, def)
+        , ("escrow-redeem_1", Escrow.redeemTrace, def)
+        , ("escrow-redeem_2", Escrow.redeem2Trace, def)
+        , ("escrow-refund", Escrow.refundTrace, def)
+        , ("future-increase-margin", Future.increaseMarginTrace, def)
+        , ("future-settle-early", Future.settleEarlyTrace, def)
+        , ("future-pay-out", Future.payOutTrace, def)
+        , ("game-sm-success", GameStateMachine.successTrace, def)
+        , ("game-sm-success_2", GameStateMachine.successTrace2, def)
+        , ("multisig-success", MultiSig.succeedingTrace, def)
+        , ("multisig-failure", MultiSig.failingTrace, def)
+        , ("multisig-sm", MultiSigStateMachine.lockProposeSignPay 3 2, def)
+        , ("ping-pong", PingPong.pingPongTrace, def)
+        , ("ping-pong_2", PingPong.twoPartiesTrace, def)
+        , ("prism", Prism.prismTrace, def)
+        , ("pubkey", PubKey.pubKeyTrace, def)
+        , ("stablecoin_1", Stablecoin.stablecoinTrace, def)
+        , ("stablecoin_2", Stablecoin.maxReservesExceededTrace, def)
+        , ("token-account", TokenAccount.tokenAccountTrace, def)
+        , ("vesting", Vesting.retrieveFundsTrace, def)
+        , ("uniswap", Uniswap.uniswapTrace, def)
         ]
 
 {-| Run an emulator trace and write the applied scripts to a file in Flat format
@@ -82,13 +80,14 @@ writeScripts fp = do
     just use unwrapped Flat because that's more convenient for use with the
     `plc` command, for example.
 -}
-writeScriptsTo :: FilePath -> String -> EmulatorTrace a -> IO ()
-writeScriptsTo fp prefix trace = do
-    -- The token used for the auction needs to be part of the initial
-    -- distribution.
-    let initialDistribution = defaultDist & over (ix (Wallet 1)) ((<>) Auction.theToken)
-        emulatorCfg = def & Trace.initialChainState .~ Left initialDistribution
-        events =
+writeScriptsTo
+    :: FilePath
+    -> String
+    -> EmulatorTrace a
+    -> EmulatorConfig
+    -> IO ()
+writeScriptsTo fp prefix trace emulatorCfg = do
+    let events =
             S.fst'
             $ run
             $ foldEmulatorStreamM (L.generalize Folds.scriptEvents)
@@ -99,3 +98,7 @@ writeScriptsTo fp prefix trace = do
             BSL.writeFile filename (BSL.fromStrict . flat . unScript $ script)
     createDirectoryIfMissing True fp
     traverse_ (uncurry writeScript) (zip [1::Int ..] (sveScript <$> events))
+
+-- | `uncurry3` converts a curried function to a function on triples.
+uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
+uncurry3 f (a, b, c) = f a b c
diff --git a/plutus-use-cases/test/Spec/Auction.hs b/plutus-use-cases/test/Spec/Auction.hs
@@ -6,14 +6,21 @@
 {-# LANGUAGE TemplateHaskell    #-}
 {-# LANGUAGE TypeApplications   #-}
 {-# LANGUAGE TypeFamilies       #-}
-module Spec.Auction(tests, theToken, auctionTrace1, auctionTrace2,
-                    prop_Auction, prop_FinishAuction) where
+module Spec.Auction
+    ( tests
+    , auctionEmulatorCfg
+    , auctionTrace1
+    , auctionTrace2
+    , prop_Auction
+    , prop_FinishAuction
+    ) where
 
 import           Control.Lens
 import           Control.Monad                      (void, when)
 import qualified Control.Monad.Freer                as Freer
 import qualified Control.Monad.Freer.Error          as Freer
 import           Control.Monad.Freer.Extras.Log     (LogLevel (..))
+import           Data.Default                       (Default (def))
 import           Data.Monoid                        (Last (..))
 
 import           Ledger                             (Ada, Slot (..), Value, pubKeyHash)
@@ -40,7 +47,7 @@ import           Test.Tasty.QuickCheck              (testProperty)
 params :: AuctionParams
 params =
     AuctionParams
-        { apOwner   = pubKeyHash $ walletPubKey (Wallet 1)
+        { apOwner   = pubKeyHash $ walletPubKey w1
         , apAsset   = theToken
         , apEndTime = TimeSlot.slotToPOSIXTime 100
         }
@@ -53,11 +60,15 @@ theToken =
     -- This currency is created by the initial transaction.
     Value.singleton "ffff" "token" 1
 
--- | 'CheckOptions' that inclues 'theToken' in the initial distribution of wallet 1.
+-- | 'EmulatorConfig' that includes 'theToken' in the initial distribution of Wallet 1.
+auctionEmulatorCfg :: Trace.EmulatorConfig
+auctionEmulatorCfg =
+    let initialDistribution = defaultDist & over (ix w1) ((<>) theToken)
+    in def & Trace.initialChainState .~ Left initialDistribution
+
+-- | 'CheckOptions' that includes our own 'auctionEmulatorCfg'.
 options :: CheckOptions
-options =
-    let initialDistribution = defaultDist & over (at (Wallet 1) . _Just) ((<>) theToken)
-    in defaultCheckOptions & emulatorConfig . Trace.initialChainState .~ Left initialDistribution
+options = set emulatorConfig auctionEmulatorCfg defaultCheckOptions
 
 seller :: Contract AuctionOutput SellerSchema AuctionError ()
 seller = auctionSeller (apAsset params) (apEndTime params)
@@ -84,6 +95,7 @@ auctionTrace1 = do
     void $ Trace.waitUntilTime $ apEndTime params
     void $ Trace.waitNSlots 2
 
+
 trace2WinningBid :: Ada
 trace2WinningBid = 70
 

diff --git a/plutus-use-cases/test/Spec/Future.hs b/plutus-use-cases/test/Spec/Future.hs
@@ -71,7 +71,7 @@ setup :: FutureSetup
 setup =
     FutureSetup
         { shortPK = walletPubKey w1
-        , longPK = walletPubKey (Wallet 2)
+        , longPK = walletPubKey w2
         , contractStart = TimeSlot.slotToPOSIXTime 15
         }
 
@@ -81,6 +81,9 @@ w1 = Wallet 1
 w2 :: Wallet
 w2 = Wallet 2
 
+w10 :: Wallet
+w10 = Wallet 10
+
 -- | A futures contract over 187 units with a forward price of 1233 Lovelace,
 --   due at slot #100.
 theFuture :: Future
@@ -157,9 +160,7 @@ units :: Integer
 units = 187
 
 oracleKeys :: (PrivateKey, PubKey)
-oracleKeys =
-    let wllt = Wallet 10 in
-        (walletPrivKey wllt, walletPubKey wllt)
+oracleKeys = (walletPrivKey w10, walletPubKey w10)
 
 -- | Increase the margin of the 'Long' role by 100 lovelace
 increaseMargin :: ContractHandle () FutureSchema FutureError -> EmulatorTrace ()