diff --git a/lib/customer-deposit-wallet/customer-deposit-wallet.cabal b/lib/customer-deposit-wallet/customer-deposit-wallet.cabal index 2594b0f85df..eeb1f2cd7b2 100644 --- a/lib/customer-deposit-wallet/customer-deposit-wallet.cabal +++ b/lib/customer-deposit-wallet/customer-deposit-wallet.cabal @@ -257,6 +257,7 @@ test-suite unit Cardano.Wallet.Deposit.HTTP.OpenAPISpec Cardano.Wallet.Deposit.Map.TimedSpec Cardano.Wallet.Deposit.Pure.API.AddressSpec + Cardano.Wallet.Deposit.Pure.API.TransactionSpec Cardano.Wallet.Deposit.PureSpec Cardano.Wallet.Deposit.RESTSpec Cardano.Wallet.Deposit.Write.KeysSpec diff --git a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Testing/DSL.hs b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Testing/DSL.hs index dee2578c84d..750dcbbfb71 100644 --- a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Testing/DSL.hs +++ b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Testing/DSL.hs @@ -23,6 +23,11 @@ module Cardano.Wallet.Deposit.Testing.DSL , assert , interpret , InterpreterState (..) + , spend + , sign + , utxo + , wallet + , balance ) where @@ -30,6 +35,7 @@ import Prelude import Cardano.Wallet.Deposit.Pure ( Customer + , ResolvedTx (..) , WalletState , getTxHistoryByTime ) @@ -38,10 +44,18 @@ import Cardano.Wallet.Deposit.Pure.API.TxHistory , ByTime , LookupTimeFromSlot ) +import Cardano.Wallet.Deposit.Pure.State.Creation + ( createMnemonicFromWords + , credentialsFromMnemonics + ) +import Cardano.Wallet.Deposit.Pure.State.Payment + ( createPaymentTxBody + ) import Cardano.Wallet.Deposit.Read ( Address , ChainPoint (..) , EraValue (..) + , UTxO , getChainPoint , mockNextBlock , slotFromChainPoint @@ -65,7 +79,9 @@ import Cardano.Wallet.Deposit.Write , mkAda , mkTx , mkTxOut + , txOutsL ) +import qualified Cardano.Wallet.Deposit.Write as Write import Cardano.Wallet.Read ( Coin (..) , Slot @@ -76,16 +92,17 @@ import Cardano.Wallet.Read ) import Control.Lens ( At (..) + , Field1 (_1) + , Field2 (_2) , Ixed (..) , Lens' - , _1 - , _2 , lens , use , uses , zoom , (%=) , (.=) + , (^?) ) import Control.Monad ( void @@ -115,18 +132,28 @@ import Data.List import Data.Map ( Map ) +import Data.Maybe + ( fromJust + ) +import Data.Text + ( Text + ) import Data.Time ( UTCTime ) import qualified Cardano.Wallet.Deposit.Pure as Wallet +import qualified Cardano.Wallet.Deposit.Time as Time +import qualified Cardano.Wallet.Read as Read import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map import qualified Data.Set as Set data Scenario p a where + ResetWallet :: Int -> Text -> Text -> Scenario p () ExistsTx :: Scenario p TxI Deposit :: TxI -> Customer -> Int -> Scenario p UnspentI + Spend :: TxI -> Address -> Int -> Scenario p () Withdrawal :: TxI -> UnspentI -> Scenario p () CreateBlock :: [TxI] -> Scenario p (BlockI) RollForward :: [BlockI] -> Scenario p () @@ -135,10 +162,17 @@ data Scenario p a where HistoryByCustomer :: Scenario p ByCustomer NewHistoryByTime :: ByTimeM ByTime -> Scenario p ByTime AvailableBalance :: Scenario p Int + Sign :: Tx -> Text -> Scenario p Tx + Balance :: TxI -> Scenario p Tx + UTxO :: UnspentI -> Scenario p UTxO Assert :: p -> Scenario p () type ScenarioP p m = ProgramT (Scenario p) m +wallet :: Int -> Text -> Text -> ScenarioP p m () +wallet users seed passphrase = + singleton (ResetWallet users seed passphrase) + existsTx :: ScenarioP p m TxI existsTx = singleton ExistsTx @@ -148,6 +182,9 @@ deposit tx customer value = singleton (Deposit tx customer value) deposit_ :: Monad m => TxI -> Customer -> Int -> ScenarioP p m () deposit_ tx customer value = void $ deposit tx customer value +spend :: TxI -> Address -> Int -> ScenarioP p m () +spend tx addr value = singleton (Spend tx addr value) + withdrawal :: TxI -> UnspentI -> ScenarioP p m () withdrawal tx unspent = singleton (Withdrawal tx unspent) @@ -172,6 +209,15 @@ newHistoryByTime = singleton . NewHistoryByTime availableBalance :: ScenarioP p m Int availableBalance = singleton AvailableBalance +sign :: Tx -> Text -> ScenarioP p m Write.Tx +sign tx pass = singleton (Sign tx pass) + +balance :: TxI -> ScenarioP p m Tx +balance tx = singleton (Balance tx) + +utxo :: UnspentI -> ScenarioP p m UTxO +utxo = singleton . UTxO + assert :: p -> ScenarioP p m () assert = singleton . Assert @@ -260,32 +306,48 @@ newBlockId = zoom iBlockContentsL $ do put $ Map.insert blockId [] blocks return blockId +freshInterpreterState :: InterpreterState +freshInterpreterState = InterpreterState mempty mempty mempty mempty + +unsafeCustomerAddress + :: Wallet.WalletState -> Customer -> Write.Address +unsafeCustomerAddress w = fromJust . flip Wallet.customerAddress w + interpret :: (MonadIO m, MonadFail m) => WalletState -> (p -> m ()) - -> (Customer -> Address) -> (Slot -> WithOrigin UTCTime) -> ScenarioP p (StateT (WalletState, InterpreterState) m) () -> m () -interpret w runP customerAddresses slotTimes p = flip evalStateT w $ do +interpret w runP slotTimes p = flip evalStateT w $ do walletState <- get (walletState', _) <- lift $ execStateT (go p) - (walletState, InterpreterState mempty mempty mempty mempty) + (walletState, freshInterpreterState) put walletState' where go = viewT >=> eval + eval (ResetWallet users seed passphrase :>>= k) = do + Right mnemonics <- pure $ createMnemonicFromWords seed + let new = + Wallet.fromCredentialsAndGenesis + (credentialsFromMnemonics mnemonics passphrase) + (fromIntegral users) + Read.mockGenesisDataMainnet + id .= (new, freshInterpreterState) + go $ k () eval (Return x) = return x eval (ExistsTx :>>= k) = do txId <- zoom _2 newTxId go $ k txId eval (Deposit tx customer value :>>= k) = do + customerAddresses <- uses _1 unsafeCustomerAddress let v = mkAda $ fromIntegral value txOut = mkTxOut (customerAddresses customer) v Just txBody <- use (_2 . iTxsL . at tx) @@ -296,6 +358,12 @@ interpret w runP customerAddresses slotTimes p = flip evalStateT w $ do Just txId <- uses (_2 . iTxsL . at tx') $ fmap (getTxId . mkTx) _2 . iTxsL . ix tx %= \txBody -> addTxIn (TxIn txId tix) txBody go $ k () + eval (Spend tx address value :>>= k) = do + Just txBody <- use (_2 . iTxsL . at tx) + let (txBody', _tix) = + addTxOut (mkTxOut address (mkAda $ fromIntegral value)) txBody + _2 . iTxsL . ix tx .= txBody' + go $ k () eval (CreateBlock txs :>>= k) = do blockId <- zoom _2 newBlockId send <- @@ -317,6 +385,7 @@ interpret w runP customerAddresses slotTimes p = flip evalStateT w $ do v <- uses _1 Wallet.getTxHistoryByCustomer go $ k v eval (NewHistoryByTime m :>>= k) = do + customerAddresses <- uses _1 unsafeCustomerAddress txIds' <- uses (_2 . iTxsL) $ (Map.!) . fmap (getTxId . mkTx) blockSlots <- uses (_2 . iBlockPointsL) $ (Map.!) . fmap slotFromChainPoint @@ -327,6 +396,27 @@ interpret w runP customerAddresses slotTimes p = flip evalStateT w $ do eval (AvailableBalance :>>= k) = do ValueC (CoinC v) _ <- uses _1 Wallet.availableBalance go $ k $ fromIntegral v + eval (Sign tx pass :>>= k) = do + Just stx <- uses _1 $ Wallet.signTx tx pass + go $ k stx + eval (Balance tx :>>= k) = do + Just txBody <- use (_2 . iTxsL . at tx) + ws <- use _1 + let etx = + createPaymentTxBody + (Read.EraValue Read.mockPParamsConway) + (Time.toTimeTranslationPure Time.mockTimeInterpreter) + txBody + ws + ResolvedTx btx _ <- case etx of + Left e -> fail $ "createPaymentTxBody failed: " <> show e + Right tx' -> return tx' + go $ k btx + eval (UTxO (UnspentI (tx, tix)) :>>= k) = do + Just txBody <- use (_2 . iTxsL . at tx) + let txId = getTxId $ mkTx txBody + Just txOut <- pure $ txBody ^? txOutsL . ix tix + go $ k $ Map.singleton (TxIn txId tix) txOut eval (Assert assertion :>>= k) = do lift $ runP assertion go $ k () diff --git a/lib/customer-deposit-wallet/test/unit/Cardano/Wallet/Deposit/Pure/API/TransactionSpec.hs b/lib/customer-deposit-wallet/test/unit/Cardano/Wallet/Deposit/Pure/API/TransactionSpec.hs new file mode 100644 index 00000000000..ecd6572b698 --- /dev/null +++ b/lib/customer-deposit-wallet/test/unit/Cardano/Wallet/Deposit/Pure/API/TransactionSpec.hs @@ -0,0 +1,241 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module Cardano.Wallet.Deposit.Pure.API.TransactionSpec + ( spec + ) +where + +import Prelude + +import Cardano.Ledger.Api + ( ppMaxTxSizeL + , ppMaxValSizeL + ) +import Cardano.Ledger.BaseTypes + ( EpochSize (..) + ) +import qualified Cardano.Ledger.BaseTypes as Ledger +import qualified Cardano.Ledger.Core as Ledger +import qualified Cardano.Ledger.Shelley.API.Mempool as Ledger +import qualified Cardano.Ledger.Shelley.LedgerState as Ledger +import qualified Cardano.Ledger.Shelley.Rules as Ledger +import qualified Cardano.Slotting.EpochInfo as Slotting +import Cardano.Slotting.Time + ( SlotLength + , SystemStart (..) + , mkSlotLength + ) +import Cardano.Wallet.Deposit.Pure.Address + ( createAddress + ) +import qualified Cardano.Wallet.Deposit.Pure.Address as Address +import Cardano.Wallet.Deposit.Pure.API.Address + ( encodeAddress + ) +import Cardano.Wallet.Deposit.Pure.State.Creation + ( accountXPubFromCredentials + , createMnemonicFromWords + , credentialsFromMnemonics + ) +import Cardano.Wallet.Deposit.PureSpec + ( testOnWallet + ) +import Cardano.Wallet.Deposit.Read + ( Address + , Conway + , NetworkTag (..) + , UTxO + , mkEnterpriseAddress + ) +import Cardano.Wallet.Deposit.Testing.DSL + ( assert + , balance + , block + , deposit + , existsTx + , rollForward + , sign + , spend + , utxo + , wallet + ) +import Cardano.Wallet.Deposit.Write + ( Tx + ) +import qualified Cardano.Wallet.Deposit.Write as Write +import Cardano.Wallet.Read + ( NetworkId (..) + ) +import qualified Cardano.Wallet.Read as Read +import Control.Lens + ( (&) + , (.~) + ) +import qualified Data.ByteString.Short as SBS +import Data.Default + ( Default (..) + ) +import Data.Maybe + ( fromMaybe + ) +import Data.Text + ( Text + ) +import qualified Data.Text.Lazy as TL +import Data.Time.Clock.POSIX + ( posixSecondsToUTCTime + ) +import Test.Cardano.Ledger.Core.Arbitrary + () +import Test.Hspec + ( Spec + , describe + , it + , shouldBe + ) +import Text.Pretty.Simple + ( pShow + ) + +address :: Address +address = mockAddress + +mockAddress :: Address +mockAddress = + mkEnterpriseAddress + MainnetTag + (SBS.toShort "12345678901234567890123456789012") + +defaultPParams :: Ledger.PParams Conway +defaultPParams = + def + & ppMaxTxSizeL .~ 16_384 + & ppMaxValSizeL .~ 1_000_000_000 + +-- | Create a new ledger env from given protocol parameters. +newLedgerEnv :: Ledger.PParams Conway -> Ledger.LedgerEnv Conway +newLedgerEnv protocolParams = + Ledger.LedgerEnv + { Ledger.ledgerSlotNo = 0 + , -- NOTE: This can probably stay at 0 forever. This is used internally by the + -- node's mempool to keep track of transaction seen from peers. Transactions + -- in Hydra do not go through the node's mempool and follow a different + -- consensus path so this will remain unused. + Ledger.ledgerIx = minBound + , -- NOTE: This keeps track of the ledger's treasury and reserve which are + -- both unused in Hydra. There might be room for interesting features in the + -- future with these two but for now, we'll consider them empty. + Ledger.ledgerAccount = Ledger.AccountState mempty mempty + , Ledger.ledgerPp = protocolParams + , Ledger.ledgerMempool = False + } + +defaultLedgerEnv :: Ledger.LedgerEnv Conway +defaultLedgerEnv = newLedgerEnv defaultPParams + +defaultGlobals :: Ledger.Globals +defaultGlobals = + Ledger.Globals + { Ledger.epochInfo = Slotting.fixedEpochInfo epochSize slotLength + , Ledger.slotsPerKESPeriod = 20 + , Ledger.stabilityWindow = 33 + , Ledger.randomnessStabilisationWindow = 33 + , Ledger.securityParameter = 10 + , Ledger.maxKESEvo = 10 + , Ledger.quorum = 5 + , Ledger.maxLovelaceSupply = 45 * 1000 * 1000 * 1000 * 1000 * 1000 + , Ledger.activeSlotCoeff = + Ledger.mkActiveSlotCoeff . unsafeBoundRational $ 0.9 + , Ledger.networkId = Ledger.Mainnet + , Ledger.systemStart = SystemStart $ posixSecondsToUTCTime 0 + } + where + unsafeBoundRational r = + fromMaybe (error $ "Could not convert from Rational: " <> show r) + $ Ledger.boundRational r + +epochSize :: EpochSize +epochSize = EpochSize 100 + +slotLength :: SlotLength +slotLength = mkSlotLength 1 + +applyTx + :: UTxO + -> Write.Tx + -> Either + (Ledger.ApplyTxError Conway) + () +applyTx utxos (Read.Tx tx) = + case Ledger.applyTx defaultGlobals defaultLedgerEnv memPoolState tx of + Left err -> Left err + Right _ -> Right () + where + memPoolState = + Ledger.LedgerState + { Ledger.lsUTxOState = + def{Ledger.utxosUtxo = Write.toConwayUTxO utxos} + , Ledger.lsCertState = def + } +newtype Ledger = Ledger + { validate :: Tx -> Either (Ledger.ApplyTxError Conway) () + } + +ledgerFrom :: UTxO -> Ledger +ledgerFrom = Ledger . applyTx + +accepts :: Ledger -> Tx -> IO () +accepts l t = case validate l t of + Left err -> + error + $ TL.unpack + $ "Transaction was not accepted by the ledger: \n" + <> pShow defaultPParams + <> "\n" + <> pShow t + <> "\n" + <> pShow err + Right _ -> pure () + +mnemonics :: Text +mnemonics = "vital minimum victory start lunch find city peanut shiver soft hedgehog artwork mushroom loud found" + +spec :: Spec +spec = do + describe "balanced transaction" $ do + it "has correct witness for one tx-in" + $ testOnWallet + $ do + wallet 17 mnemonics "passphrase" + tx1 <- existsTx + u1 <- deposit tx1 1 100 + b1 <- block [tx1] + rollForward [b1] + spending <- existsTx + spend spending address 10 + balanced <- balance spending + utxos <- utxo u1 + signedTx <- sign balanced "passphrase" + assert $ ledgerFrom utxos `accepts` signedTx + + -- cat root1.prv + -- | cardano-address key child 1857H/1815H/0H/0/0 \ + -- | cardano-address key public --with-chain-code \ + -- | cardano-address address payment --network-tag mainnet + describe "generated address match golden cases" $ do + it "with empty passphrase in mainnet" $ do + let + Right seed = createMnemonicFromWords mnemonics + address0 = "addr1v8th5554xvd2us9hwh72p3yt9rg7uw9v7tk49t3yw3wrcgc3drxft" + creds = credentialsFromMnemonics seed mempty + xpub = accountXPubFromCredentials creds + addr = + encodeAddress + $ fst + $ createAddress 0 + $ Address.fromXPubAndCount Mainnet xpub 1 + + addr `shouldBe` address0 diff --git a/lib/customer-deposit-wallet/test/unit/Cardano/Wallet/Deposit/PureSpec.hs b/lib/customer-deposit-wallet/test/unit/Cardano/Wallet/Deposit/PureSpec.hs index 12aa495eb71..efb3844c038 100644 --- a/lib/customer-deposit-wallet/test/unit/Cardano/Wallet/Deposit/PureSpec.hs +++ b/lib/customer-deposit-wallet/test/unit/Cardano/Wallet/Deposit/PureSpec.hs @@ -19,7 +19,6 @@ import Cardano.Mnemonic ) import Cardano.Wallet.Deposit.Pure ( Credentials - , Customer ) import Cardano.Wallet.Deposit.Pure.API.TxHistory ( LookupTimeFromSlot @@ -92,10 +91,6 @@ timeFromSlot = unsafeUTCTimeOfSlot unsafeTimeForSlot :: Read.Slot -> Read.WithOrigin UTCTime unsafeTimeForSlot = fromJust . timeFromSlot -unsafeCustomerAddress - :: Wallet.WalletState -> Customer -> Write.Address -unsafeCustomerAddress w = fromJust . flip Wallet.customerAddress w - testOnWallet :: ScenarioP (IO ()) @@ -106,7 +101,6 @@ testOnWallet = interpret emptyWalletWith17Addresses id - (unsafeCustomerAddress emptyWalletWith17Addresses) unsafeTimeForSlot spec :: Spec