Add mock NetworkEnv implementation

lib/customer-deposit-wallet/customer-deposit-wallet.cabal

@@ -57,6 +57,7 @@ library
     , contra-tracer
     , delta-store
     , delta-types
+    , io-classes
     , iohk-monitoring-extra              ^>=0.1
     , persistent                         >= 2.13 && < 2.15
     , sqlite-simple                      >= 0.4.19.0 && < 0.5
@@ -66,6 +67,7 @@ library
   exposed-modules:
     Cardano.Wallet.Deposit.IO
     Cardano.Wallet.Deposit.IO.DB
+    Cardano.Wallet.Deposit.IO.Network.Mock
     Cardano.Wallet.Deposit.IO.Network.Type
     Cardano.Wallet.Deposit.Pure
     Cardano.Wallet.Deposit.Pure.Balance

lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO/Network/Mock.hs

@@ -0,0 +1,114 @@
+{-|
+Copyright: © 2024 Cardano Foundation
+License: Apache-2.0
+
+Mock implementation of a 'NetworkEnv'.
+-}
+module Cardano.Wallet.Deposit.IO.Network.Mock
+    ( newNetworkEnvMock
+    ) where
+
+import Prelude
+
+import Cardano.Wallet.Deposit.IO.Network.Type
+    ( NetworkEnv (..)
+    )
+import Cardano.Wallet.Network
+    ( ChainFollower (..)
+    )
+import Control.Concurrent.Class.MonadSTM
+    ( MonadSTM
+    , atomically
+    , modifyTVar
+    , newTVarIO
+    , readTVar
+    , readTVarIO
+    , writeTVar
+    )
+import Control.Monad
+    ( forever
+    )
+import Control.Monad.Class.MonadTimer
+    ( MonadDelay
+    , threadDelay
+    )
+import Data.Foldable
+    ( for_
+    )
+import Data.List.NonEmpty
+    ( NonEmpty ((:|))
+    )
+
+import qualified Cardano.Wallet.Deposit.Read as Read
+import qualified Cardano.Wallet.Deposit.Write as Write
+
+{-----------------------------------------------------------------------------
+    Mock implementation of 'NetworkEnv'
+------------------------------------------------------------------------------}
+newNetworkEnvMock
+    :: (MonadDelay m, MonadSTM m)
+    => m (NetworkEnv m Read.Block)
+newNetworkEnvMock = do
+    mchain <- newTVarIO []
+    mtip <- newTVarIO genesis
+    mfollowers <- newTVarIO []
+
+    let registerAndUpdate follower = do
+            _ <- rollBackward follower genesis
+            (chain, tip) <- atomically $ do
+                modifyTVar mfollowers (follower:)
+                (,) <$> readTVar mchain <*> readTVar mtip
+            case reverse chain of
+                [] -> pure ()
+                (b:bs) -> rollForward follower (b :| bs) tip
+
+    let forgeBlock tx = atomically $ do
+            tipOld <- readTVar mtip
+            let txRead = Write.toReadTx (Write.mockTxId tipOld) tx
+                blockNew = mkNextBlock tipOld [txRead]
+                tipNew = getBlockPoint blockNew
+            writeTVar mtip tipNew
+            modifyTVar mchain (blockNew:)
+            pure (blockNew, tipNew)
+
+    let broadcast block tip = do
+            followers <- readTVarIO mfollowers
+            for_ followers $ \follower ->
+                rollForward follower (block :| []) tip
+
+    pure NetworkEnv
+        { chainSync = \_ follower -> do
+            registerAndUpdate follower
+            forever $ threadDelay 1000000
+        , postTx = \tx -> do
+            (block, tip) <- forgeBlock tx
+            broadcast block tip
+            -- brief delay to account for asynchronous chain followers
+            threadDelay 10
+            pure $ Right ()
+        }
+
+genesis :: Read.ChainPoint
+genesis = Read.Origin
+
+getBlockPoint :: Read.Block -> Read.ChainPoint
+getBlockPoint = Read.At . Read.slot . Read.blockHeaderBody . Read.blockHeader
+
+mkNextBlock :: Read.ChainPoint -> [Read.Tx] -> Read.Block
+mkNextBlock tipOld txs =
+    Read.Block
+        { Read.blockHeader = Read.BHeader
+            { Read.blockHeaderBody = Read.BHBody
+                { Read.prev = Nothing
+                , Read.blockno = toEnum $ fromEnum slotNext
+                , Read.slot = slotNext
+                , Read.bhash = ()
+                }
+            , Read.blockHeaderSignature = ()
+            }
+        , Read.transactions = txs
+        }
+ where
+    slotNext = case tipOld of
+        Read.Origin -> 1
+        Read.At n -> succ n

lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO/Network/Type.hs

@@ -26,6 +26,7 @@ import GHC.Generics
     )
 
 import qualified Cardano.Wallet.Deposit.Read as Read
+import qualified Cardano.Wallet.Deposit.Write as Write
 
 {-----------------------------------------------------------------------------
     Type
@@ -39,7 +40,7 @@ data NetworkEnv m block = NetworkEnv
         -- ^ Run the chain-sync mini-protocol (forever).
 
     , postTx
-        :: Read.Tx -> m (Either ErrPostTx ())
+        :: Write.Tx -> m (Either ErrPostTx ())
         -- ^ Post a transaction to the Cardano network.
 
     }

lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Read.hs

@@ -72,7 +72,10 @@ data Network = Testnet | Mainnet
 -- Spec: type Slot = Natural
 type Slot = W.SlotNo
 
-data ChainPoint = Origin | At Slot
+data ChainPoint
+    = Origin
+    | At Slot
+    deriving (Eq, Ord, Show)
 
 -- newtype Addr = Addr { getAddressBytes :: ByteString }
 --    deriving (Eq, Show)

lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Write.hs

@@ -1,3 +1,6 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TupleSections #-}
+
 -- | Indirection module that re-exports types
 -- used for writing transactions to the blockchain,
 -- in the most recent and the next future eras.
@@ -11,22 +14,43 @@ module Cardano.Wallet.Deposit.Write
     , TxId
     , Tx (..)
     , TxBody (..)
+    , TxIn
+    , TxOut
     , TxWitness
+
+    -- * Helper functions
+    , mkAda
+    , mkTxOut
+    , mockTxId
+    , toReadTx
     ) where
 
 import Prelude
 
+import Cardano.Wallet.Deposit.Read
+    ( Address
+    , TxId
+    , TxIn
+    , TxOut
+    , TxWitness
+    , Value
+    )
 import Data.Map
     ( Map
     )
 import Data.Set
     ( Set
     )
 
-import Cardano.Wallet.Deposit.Read hiding
-    ( Tx
-    , TxBody
-    )
+import qualified Cardano.Wallet.Deposit.Read as Read
+import qualified Cardano.Wallet.Primitive.Types.Coin as W
+import qualified Cardano.Wallet.Primitive.Types.Hash as W
+import qualified Cardano.Wallet.Primitive.Types.TokenBundle as W
+import qualified Cardano.Wallet.Primitive.Types.Tx as W
+import qualified Cardano.Wallet.Primitive.Types.Tx.TxOut as W
+import qualified Data.ByteString.Char8 as B8
+import qualified Data.Map.Strict as Map
+import qualified Data.Set as Set
 
 {-----------------------------------------------------------------------------
     Type definitions
@@ -41,7 +65,41 @@ data Tx = Tx
 data TxBody = TxBody
     { spendInputs :: Set TxIn
     , collInputs :: Set TxIn
-    , txouts :: Map Ix TxOut
+    , txouts :: Map Read.Ix TxOut
     , collRet :: Maybe TxOut
     }
     deriving (Eq, Ord, Show)
+
+mkAda :: Integer -> Value
+mkAda = W.fromCoin . W.unsafeFromIntegral
+
+mkTxOut :: Address -> Value -> TxOut
+mkTxOut = W.TxOut
+
+toReadTx :: TxId -> Tx -> Read.Tx
+toReadTx txid Tx{txbody=TxBody{..}} =
+    W.Tx
+        { W.txId =
+            W.Hash txid
+        , W.txCBOR =
+            Nothing
+        , W.fee =
+            Nothing
+        , W.resolvedInputs =
+            map (,Nothing) $ Set.toList spendInputs
+        , W.resolvedCollateralInputs =
+            map (,Nothing) $ Set.toList collInputs
+        , W.outputs =
+            map snd $ Map.toAscList txouts
+        , W.collateralOutput =
+            collRet
+        , W.withdrawals =
+            mempty
+        , W.metadata =
+            Nothing
+        , W.scriptValidity =
+            Nothing
+        }
+
+mockTxId :: Show a => a -> TxId
+mockTxId = B8.pack . show