Merge #1854

1854:  assign correct network discrimination to withdrawals r=KtorZ a=KtorZ

# Issue Number

<!-- Put here a reference to the issue this PR relates to and which requirements it tackles -->

#1821 

# Overview

<!-- Detail in a few bullet points the work accomplished in this PR -->

- [ ] I have assigned correct network discrimination to withdrawals. This was hard-coded to mainnet, for some reasons.

# Comments

<!-- Additional comments or screenshots to attach if any -->

<!-- 
Don't forget to:

 ✓ Self-review your changes to make sure nothing unexpected slipped through
 ✓ Assign yourself to the PR
 ✓ Assign one or several reviewer(s)
 ✓ Once created, link this PR to its corresponding ticket
 ✓ Assign the PR to a corresponding milestone
 ✓ Acknowledge any changes required to the Wiki
-->


Co-authored-by: KtorZ <matthias.benkort@gmail.com>

Author: iohk-bors[bot]

lib/core/src/Cardano/Wallet/Primitive/AddressDerivation.hs

@@ -472,7 +472,7 @@ instance MonadRandom ((->) (Passphrase "salt")) where
 -------------------------------------------------------------------------------}
 
 -- | Available network options.
-data NetworkDiscriminant = Mainnet | Testnet Nat
+data NetworkDiscriminant = Mainnet | Testnet Nat deriving Typeable
 
 class NetworkDiscriminantVal (n :: NetworkDiscriminant) where
     networkDiscriminantVal :: Text

lib/shelley/src/Cardano/Wallet/Shelley.hs

@@ -153,6 +153,8 @@ import System.Exit
     ( ExitCode (..) )
 import System.IOManager
     ( withIOManager )
+import Type.Reflection
+    ( Typeable )
 
 import qualified Cardano.Pool.DB.Sqlite as Pool
 import qualified Cardano.Wallet.Api.Server as Server
@@ -172,6 +174,7 @@ data SomeNetworkDiscriminant where
             , DelegationAddress n ShelleyKey
             , DecodeAddress n
             , EncodeAddress n
+            , Typeable n
             )
         => Proxy n
         -> SomeNetworkDiscriminant

lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs

@@ -77,6 +77,7 @@ module Cardano.Wallet.Shelley.Compatibility
     , fromTip
     , fromTip'
     , fromPParams
+    , fromNetworkDiscriminant
 
       -- * Internal Conversions
     , decentralizationLevelFromPParams
@@ -132,12 +133,16 @@ import Data.Map.Strict
     ( Map )
 import Data.Maybe
     ( fromMaybe, isJust, mapMaybe )
+import Data.Proxy
+    ( Proxy )
 import Data.Quantity
     ( Percentage, Quantity (..), mkPercentage )
 import Data.Text
     ( Text )
 import Data.Text.Class
     ( TextDecodingError (..) )
+import Data.Type.Equality
+    ( testEquality )
 import Data.Word
     ( Word16, Word32, Word64 )
 import Fmt
@@ -175,6 +180,8 @@ import Ouroboros.Network.Point
     ( WithOrigin (..) )
 import Shelley.Spec.Ledger.BaseTypes
     ( strictMaybeToMaybe, urlToText )
+import Type.Reflection
+    ( Typeable, typeRep )
 
 import qualified Cardano.Api as Cardano
 import qualified Cardano.Byron.Codec.Cbor as CBOR
@@ -741,6 +748,15 @@ fromUnitInterval x =
         , show x
         ]
 
+fromNetworkDiscriminant
+    :: forall (n :: NetworkDiscriminant). (Typeable n)
+    => Proxy n
+    -> SL.Network
+fromNetworkDiscriminant _ =
+    case testEquality (typeRep @n) (typeRep @'Mainnet) of
+        Just{}  -> SL.Mainnet
+        Nothing -> SL.Testnet
+
 -- NOTE: Arguably breaks naming conventions. Perhaps fromCardanoSignedTx instead
 toSealed :: SL.Tx TPraosStandardCrypto -> (W.Tx, W.SealedTx)
 toSealed tx =

lib/shelley/src/Cardano/Wallet/Shelley/Transaction.hs

@@ -73,6 +73,7 @@ import Cardano.Wallet.Primitive.Types
 import Cardano.Wallet.Shelley.Compatibility
     ( Shelley
     , TPraosStandardCrypto
+    , fromNetworkDiscriminant
     , toCardanoLovelace
     , toCardanoTxIn
     , toCardanoTxOut
@@ -111,6 +112,8 @@ import Ouroboros.Consensus.Shelley.Protocol.Crypto
     ( Crypto (..) )
 import Ouroboros.Network.Block
     ( SlotNo )
+import Type.Reflection
+    ( Typeable )
 
 import qualified Cardano.Api as Cardano
 import qualified Cardano.Byron.Codec.Cbor as CBOR
@@ -157,17 +160,19 @@ emptyTxPayload :: Crypto c => TxPayload c
 emptyTxPayload = TxPayload mempty mempty
 
 mkTx
-    :: WalletKey k
-    => TxPayload TPraosStandardCrypto
+    :: forall (n :: NetworkDiscriminant) k. (Typeable n, WalletKey k)
+    => Proxy n
+    -> TxPayload TPraosStandardCrypto
     -> SlotNo
     -- ^ Time to Live
     -> (k 'AddressK XPrv, Passphrase "encryption")
     -- ^ Reward account
     -> (Address -> Maybe (k 'AddressK XPrv, Passphrase "encryption"))
     -> CoinSelection
     -> Either ErrMkTx (Tx, SealedTx)
-mkTx (TxPayload certs mkExtraWits) timeToLive (rewardAcnt, pwdAcnt) keyFrom cs = do
+mkTx proxy (TxPayload certs mkExtraWits) timeToLive (rewardAcnt, pwdAcnt) keyFrom cs = do
     let withdrawals = mkWithdrawals
+            proxy
             (toChimericAccountRaw . getRawKey . publicKey $ rewardAcnt)
             (withdrawal cs)
 
@@ -193,24 +198,25 @@ newTransactionLayer
     :: forall (n :: NetworkDiscriminant) k t.
         ( t ~ IO Shelley
         , WalletKey k
+        , Typeable n
         )
     => Proxy n
     -> ProtocolMagic
     -> EpochLength
     -> TransactionLayer t k
-newTransactionLayer _proxy _protocolMagic epochLength = TransactionLayer
-    { mkStdTx = \acc ks tip -> mkTx emptyTxPayload (defaultTTL epochLength tip) acc ks
+newTransactionLayer proxy _protocolMagic epochLength = TransactionLayer
+    { mkStdTx = \acc ks tip ->
+        mkTx proxy emptyTxPayload (defaultTTL epochLength tip) acc ks
     , initDelegationSelection = _initDelegationSelection
     , mkDelegationJoinTx = _mkDelegationJoinTx
     , mkDelegationQuitTx = _mkDelegationQuitTx
     , decodeSignedTx = _decodeSignedTx
-    , minimumFee = _minimumFee
-    , estimateMaxNumberOfInputs = _estimateMaxNumberOfInputs
+    , minimumFee = _minimumFee proxy
+    , estimateMaxNumberOfInputs = _estimateMaxNumberOfInputs proxy
     , validateSelection = const $ return ()
     , allowUnbalancedTx = True
     }
   where
-
     _initDelegationSelection
         :: FeePolicy
             -- Current fee policy
@@ -254,7 +260,7 @@ newTransactionLayer _proxy _protocolMagic epochLength = TransactionLayer
 
         let payload = TxPayload certs mkWits
         let ttl = defaultTTL epochLength tip
-        mkTx payload ttl acc keyFrom cs
+        mkTx proxy payload ttl acc keyFrom cs
 
     _mkDelegationQuitTx
         :: (k 'AddressK XPrv, Passphrase "encryption")
@@ -277,15 +283,17 @@ newTransactionLayer _proxy _protocolMagic epochLength = TransactionLayer
 
         let payload = TxPayload certs mkWits
         let ttl = defaultTTL epochLength tip
-        mkTx payload ttl acc keyFrom cs
+        mkTx proxy payload ttl acc keyFrom cs
 
 _estimateMaxNumberOfInputs
-    :: Quantity "byte" Word16
+    :: forall (n :: NetworkDiscriminant). Typeable n
+    => Proxy n
+    -> Quantity "byte" Word16
      -- ^ Transaction max size in bytes
     -> Word8
     -- ^ Number of outputs in transaction
     -> Word8
-_estimateMaxNumberOfInputs (Quantity maxSize) nOuts =
+_estimateMaxNumberOfInputs proxy (Quantity maxSize) nOuts =
       fromIntegral $ bisect (lowerBound, upperBound)
   where
     bisect (!inf, !sup)
@@ -306,7 +314,7 @@ _estimateMaxNumberOfInputs (Quantity maxSize) nOuts =
 
     isTooBig nInps = size > fromIntegral maxSize
       where
-        size = computeTxSize Nothing sel
+        size = computeTxSize proxy Nothing sel
         sel  = dummyCoinSel nInps (fromIntegral nOuts)
 
 dummyCoinSel :: Int -> Int -> CoinSelection
@@ -346,12 +354,14 @@ _decodeSignedTx bytes = do
             Left $ ErrDecodeSignedTxWrongPayload (Cardano.renderApiError apiErr)
 
 _minimumFee
-    :: FeePolicy
+    :: forall (n :: NetworkDiscriminant). Typeable n
+    => Proxy (n :: NetworkDiscriminant)
+    -> FeePolicy
     -> Maybe DelegationAction
     -> CoinSelection
     -> Fee
-_minimumFee policy action cs =
-    computeFee $ computeTxSize action cs
+_minimumFee proxy policy action cs =
+    computeFee $ computeTxSize proxy action cs
   where
     computeFee :: Integer -> Fee
     computeFee size =
@@ -360,10 +370,12 @@ _minimumFee policy action cs =
         LinearFee (Quantity a) (Quantity b) _unused = policy
 
 computeTxSize
-    :: Maybe DelegationAction
+    :: forall (n :: NetworkDiscriminant). Typeable n
+    => Proxy (n :: NetworkDiscriminant)
+    -> Maybe DelegationAction
     -> CoinSelection
     -> Integer
-computeTxSize action cs =
+computeTxSize proxy action cs =
     SL.txsize $ SL.Tx unsigned wits metadata
  where
     metadata = SL.SNothing
@@ -397,6 +409,7 @@ computeTxSize action cs =
     dummyKeyHashRaw = BS.pack (replicate 28 0)
 
     withdrawals = mkWithdrawals
+        proxy
         (ChimericAccount dummyKeyHashRaw)
         (withdrawal cs)
 
@@ -459,20 +472,21 @@ mkUnsignedTx ttl cs withdrawals certs =
         unsigned
 
 mkWithdrawals
-    :: ChimericAccount
+    :: forall (n :: NetworkDiscriminant). (Typeable n)
+    => Proxy n
+    -> ChimericAccount
     -> Word64
     -> Map (SL.RewardAcnt TPraosStandardCrypto) SL.Coin
-mkWithdrawals (ChimericAccount keyHash) amount
+mkWithdrawals proxy (ChimericAccount keyHash) amount
     | amount == 0 = mempty
     | otherwise = Map.fromList
-        [ ( SL.RewardAcnt SL.Mainnet keyHashObj
+        [ ( SL.RewardAcnt (fromNetworkDiscriminant proxy) keyHashObj
           , SL.Coin $ fromIntegral amount
           )
         ]
   where
     keyHashObj = SL.KeyHashObj $ SL.KeyHash $ Hash.UnsafeHash keyHash
 
-
 -- TODO: The SlotId-SlotNo conversion based on epoch length would not
 -- work if the epoch length changed in a hard fork.
 

lib/shelley/test/integration/Main.hs

@@ -266,7 +266,7 @@ mkFeeEstimator policy = \case
             mempty { inputs = inps, change = outs }
 
     computeFee selection action =
-        fromIntegral $ getFee $ _minimumFee policy action selection
+        fromIntegral $ getFee $ _minimumFee (Proxy @'Mainnet) policy action selection
 
 {-------------------------------------------------------------------------------
                                     Logging

lib/shelley/test/unit/Cardano/Wallet/Shelley/TransactionSpec.hs

@@ -113,14 +113,15 @@ spec = do
         prop "roundtrip" prop_decodeSignedTxRoundtrip
 
     describe "estimateMaxNumberOfInputs" $ do
+        let proxy = Proxy @'Mainnet
         it "order of magnitude, nOuts = 1" $
-            _estimateMaxNumberOfInputs (Quantity 4096) 1 `shouldBe` 27
+            _estimateMaxNumberOfInputs proxy (Quantity 4096) 1 `shouldBe` 27
         it "order of magnitude, nOuts = 10" $
-            _estimateMaxNumberOfInputs (Quantity 4096) 10 `shouldBe` 19
+            _estimateMaxNumberOfInputs proxy (Quantity 4096) 10 `shouldBe` 19
         it "order of magnitude, nOuts = 20" $
-            _estimateMaxNumberOfInputs (Quantity 4096) 20 `shouldBe` 10
+            _estimateMaxNumberOfInputs proxy (Quantity 4096) 20 `shouldBe` 10
         it "order of magnitude, nOuts = 30" $
-            _estimateMaxNumberOfInputs (Quantity 4096) 30 `shouldBe` 1
+            _estimateMaxNumberOfInputs proxy (Quantity 4096) 30 `shouldBe` 1
 
         prop "more outputs ==> less inputs" prop_moreOutputsMeansLessInputs
         prop "less outputs ==> more inputs" prop_lessOutputsMeansMoreInputs
@@ -187,9 +188,11 @@ prop_moreOutputsMeansLessInputs
     -> Property
 prop_moreOutputsMeansLessInputs size nOuts = withMaxSuccess 1000 $
     nOuts < maxBound ==>
-        _estimateMaxNumberOfInputs size nOuts
+        _estimateMaxNumberOfInputs proxy size nOuts
         >=
-        _estimateMaxNumberOfInputs size (nOuts + 1)
+        _estimateMaxNumberOfInputs proxy size (nOuts + 1)
+  where
+    proxy = Proxy @'Mainnet
 
 -- | REducing the number of outputs increases the number of inputs.
 prop_lessOutputsMeansMoreInputs
@@ -198,10 +201,11 @@ prop_lessOutputsMeansMoreInputs
     -> Property
 prop_lessOutputsMeansMoreInputs size nOuts = withMaxSuccess 1000 $
     nOuts > minBound ==>
-        _estimateMaxNumberOfInputs size (nOuts - 1)
+        _estimateMaxNumberOfInputs proxy size (nOuts - 1)
         >=
-        _estimateMaxNumberOfInputs size nOuts
-
+        _estimateMaxNumberOfInputs proxy size nOuts
+  where
+    proxy = Proxy @'Mainnet
 
 -- | Increasing the max size automatically increased the number of inputs
 prop_biggerMaxSizeMeansMoreInputs
@@ -210,9 +214,11 @@ prop_biggerMaxSizeMeansMoreInputs
     -> Property
 prop_biggerMaxSizeMeansMoreInputs (Quantity size) nOuts = withMaxSuccess 1000 $
     size < maxBound `div` 2 ==>
-        _estimateMaxNumberOfInputs (Quantity size) nOuts
+        _estimateMaxNumberOfInputs proxy (Quantity size) nOuts
         <=
-        _estimateMaxNumberOfInputs (Quantity (size * 2)) nOuts
+        _estimateMaxNumberOfInputs proxy (Quantity (size * 2)) nOuts
+  where
+    proxy = Proxy @'Mainnet
 
 testCoinSelOpts :: CoinSelectionOptions ()
 testCoinSelOpts = coinSelOpts testTxLayer (Quantity 4096)