diff --git a/lib/shelley/cardano-wallet.cabal b/lib/shelley/cardano-wallet.cabal index 47fa3096244..49f9f131903 100644 --- a/lib/shelley/cardano-wallet.cabal +++ b/lib/shelley/cardano-wallet.cabal @@ -111,6 +111,7 @@ library Cardano.Wallet.Shelley.Compatibility.Ledger Cardano.Wallet.Shelley.Network Cardano.Wallet.Shelley.Network.Blockfrost + Cardano.Wallet.Shelley.Network.Discriminant Cardano.Wallet.Shelley.Network.Node Cardano.Wallet.Shelley.Transaction Cardano.Wallet.Shelley.Launch diff --git a/lib/shelley/src/Cardano/Wallet/Shelley.hs b/lib/shelley/src/Cardano/Wallet/Shelley.hs index fd9a1e4ffb2..5d1c890b789 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley.hs @@ -1,16 +1,11 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -- | -- Copyright: © 2020 IOHK @@ -57,7 +52,6 @@ import Cardano.Wallet.Network import Cardano.Wallet.Primitive.AddressDerivation ( DelegationAddress (..) , Depth (..) - , NetworkDiscriminant (..) , NetworkDiscriminantVal , PaymentAddress , PersistPrivateKey @@ -110,11 +104,18 @@ import Cardano.Wallet.Shelley.Api.Server import Cardano.Wallet.Shelley.BlockchainSource ( BlockchainSource (..) ) import Cardano.Wallet.Shelley.Compatibility - ( CardanoBlock, HasNetworkId (..), StandardCrypto, fromCardanoBlock ) + ( CardanoBlock + , HasNetworkId (..) + , NetworkId + , StandardCrypto + , fromCardanoBlock + ) import Cardano.Wallet.Shelley.Logging as Logging ( ApplicationLog (..) ) import Cardano.Wallet.Shelley.Network ( withNetworkLayer ) +import Cardano.Wallet.Shelley.Network.Discriminant + ( SomeNetworkDiscriminant (..), networkDiscriminantToId ) import Cardano.Wallet.Shelley.Pools ( StakePoolLayer (..) , StakePoolLog (..) @@ -175,35 +176,12 @@ import UnliftIO.MVar import UnliftIO.STM ( newTVarIO ) -import qualified Cardano.Api.Shelley as Cardano import qualified Cardano.Pool.DB as PoolDb import qualified Cardano.Pool.DB.Sqlite as Pool import qualified Cardano.Wallet.Api.Server as Server import qualified Cardano.Wallet.DB.Sqlite as Sqlite import qualified Network.Wai.Handler.Warp as Warp --- | Encapsulate a network discriminant and the necessary constraints it should --- satisfy. -data SomeNetworkDiscriminant where - SomeNetworkDiscriminant - :: forall (n :: NetworkDiscriminant). - ( NetworkDiscriminantVal n - , PaymentAddress n IcarusKey - , PaymentAddress n ByronKey - , PaymentAddress n ShelleyKey - , DelegationAddress n ShelleyKey - , HasNetworkId n - , DecodeAddress n - , EncodeAddress n - , DecodeStakeAddress n - , EncodeStakeAddress n - , Typeable n - ) - => Proxy n - -> SomeNetworkDiscriminant - -deriving instance Show SomeNetworkDiscriminant - -- | The @cardano-wallet@ main function. It takes the configuration -- which was passed from the CLI and environment and starts all components of -- the wallet. @@ -245,7 +223,7 @@ serveWallet , genesisParameters , slottingParameters } - (SomeNetworkDiscriminant proxyNetwork) + network@(SomeNetworkDiscriminant proxyNetwork) Tracers{..} sTolerance databaseDir @@ -264,7 +242,7 @@ serveWallet netLayer <- withNetworkLayer networkTracer blockchainSource - net + network netParams sTolerance stakePoolDbLayer <- withStakePoolDbLayer @@ -303,20 +281,20 @@ serveWallet trace :: ApplicationLog -> IO () trace = traceWith applicationTracer - net :: Cardano.NetworkId - net = networkIdVal proxyNetwork + netId :: NetworkId + netId = networkDiscriminantToId network bindSocket :: ContT r IO (Either ListenError (Warp.Port, Socket)) bindSocket = ContT $ Server.withListeningSocket hostPref listen withRandomApi netLayer = - lift $ apiLayer (newTransactionLayer net) netLayer Server.idleWorker + lift $ apiLayer (newTransactionLayer netId) netLayer Server.idleWorker withIcarusApi netLayer = - lift $ apiLayer (newTransactionLayer net) netLayer Server.idleWorker + lift $ apiLayer (newTransactionLayer netId) netLayer Server.idleWorker withShelleyApi netLayer = - lift $ apiLayer (newTransactionLayer net) netLayer + lift $ apiLayer (newTransactionLayer netId) netLayer (Server.manageRewardBalance proxyNetwork) withMultisigApi netLayer = diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs index ffad1a2a08e..4e6e53b171a 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs @@ -1,4 +1,8 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} module Cardano.Wallet.Shelley.Network ( -- * Top-Level Interface @@ -10,7 +14,6 @@ module Cardano.Wallet.Shelley.Network import Prelude -import qualified Cardano.Api as Cardano import qualified Cardano.Wallet.Shelley.Network.Blockfrost as Blockfrost import qualified Cardano.Wallet.Shelley.Network.Node as Node @@ -24,6 +27,10 @@ import Cardano.Wallet.Primitive.Types ( NetworkParameters ) import Cardano.Wallet.Shelley.BlockchainSource ( BlockchainSource (..) ) +import Cardano.Wallet.Shelley.Compatibility + ( CardanoBlock, StandardCrypto ) +import Cardano.Wallet.Shelley.Network.Discriminant + ( SomeNetworkDiscriminant, networkDiscriminantToId ) import Control.Monad.Trans.Cont ( ContT (ContT) ) import Data.Functor.Contravariant @@ -32,8 +39,6 @@ import Data.Text.Class ( ToText (toText) ) import GHC.Stack ( HasCallStack ) -import Ouroboros.Consensus.Cardano.Block - ( CardanoBlock, StandardCrypto ) data NetworkLayerLog = NodeNetworkLog Node.Log @@ -55,7 +60,7 @@ withNetworkLayer :: HasCallStack => Tracer IO NetworkLayerLog -> BlockchainSource - -> Cardano.NetworkId + -> SomeNetworkDiscriminant -> NetworkParameters -> SyncTolerance -> ContT r IO (NetworkLayer IO (CardanoBlock StandardCrypto)) @@ -63,8 +68,8 @@ withNetworkLayer tr blockchainSrc net netParams tol = ContT $ case blockchainSrc of NodeSource nodeConn ver -> let tr' = NodeNetworkLog >$< tr - in Node.withNetworkLayer tr' net netParams nodeConn ver tol + netId = networkDiscriminantToId net + in Node.withNetworkLayer tr' netId netParams nodeConn ver tol BlockfrostSource project -> let tr' = BlockfrostNetworkLog >$< tr in Blockfrost.withNetworkLayer tr' net netParams project - diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Network/Blockfrost.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Network/Blockfrost.hs index 84bc3c1e45f..cabea5ce3ab 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Network/Blockfrost.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Network/Blockfrost.hs @@ -35,7 +35,9 @@ import Prelude import qualified Blockfrost.Client as BF import qualified Cardano.Api.Shelley as Node +import qualified Data.Map.Strict as Map import qualified Data.Sequence as Seq +import qualified Data.Set as Set import qualified Ouroboros.Consensus.HardFork.History.Qry as HF import Cardano.Api @@ -56,6 +58,8 @@ import Cardano.Pool.Rank ( RewardParams (..) ) import Cardano.Pool.Rank.Likelihood ( BlockProduction (..), PerformanceEstimate (..), estimatePoolPerformance ) +import Cardano.Wallet.Api.Types + ( encodeStakeAddress ) import Cardano.Wallet.Logging ( BracketLog, bracketTracer ) import Cardano.Wallet.Network @@ -93,8 +97,12 @@ import Cardano.Wallet.Primitive.Types.Coin ( Coin (Coin, unCoin) ) import Cardano.Wallet.Primitive.Types.Hash ( Hash ) +import Cardano.Wallet.Primitive.Types.RewardAccount + ( RewardAccount ) import Cardano.Wallet.Primitive.Types.Tx ( TxSize (..) ) +import Cardano.Wallet.Shelley.Network.Discriminant + ( SomeNetworkDiscriminant (..), networkDiscriminantToId ) import Control.Concurrent ( threadDelay ) import Control.Monad @@ -111,11 +119,19 @@ import Data.Functor.Contravariant ( (>$<) ) import Data.IntCast ( intCast, intCastMaybe ) +import Data.Map + ( Map ) +import Data.Maybe + ( fromMaybe ) +import Data.Proxy + ( Proxy (..) ) import Data.Quantity ( MkPercentageError (PercentageOutOfBoundsError) , Quantity (..) , mkPercentage ) +import Data.Set + ( Set ) import Data.Text.Class ( FromText (fromText), TextDecodingError (..), ToText (..) ) import Data.Traversable @@ -184,30 +200,33 @@ instance HasSeverityAnnotation Log where withNetworkLayer :: Tracer IO Log - -> NetworkId + -> SomeNetworkDiscriminant -> NetworkParameters -> BF.Project -> (NetworkLayer IO (CardanoBlock StandardCrypto) -> IO a) -> IO a -withNetworkLayer tr net np project k = k NetworkLayer - { chainSync = \_tr _chainFollower -> pure () - , lightSync = Nothing - , currentNodeTip - , currentNodeEra - , currentProtocolParameters - , currentSlottingParameters = undefined - , watchNodeTip - , postTx = undefined - , stakeDistribution = undefined - , getCachedRewardAccountBalance = undefined - , fetchRewardAccountBalances = undefined - , timeInterpreter = timeInterpreterFromStartTime getGenesisBlockDate - , syncProgress = undefined - } +withNetworkLayer tr network np project k = + k NetworkLayer + { chainSync = \_tr _chainFollower -> pure () + , lightSync = Nothing + , currentNodeTip + , currentNodeEra + , currentProtocolParameters + , currentSlottingParameters = undefined + , watchNodeTip + , postTx = undefined + , stakeDistribution = undefined + , getCachedRewardAccountBalance + , fetchRewardAccountBalances = fetchNetworkRewardAccountBalances network + , timeInterpreter = timeInterpreterFromStartTime getGenesisBlockDate + , syncProgress = undefined + } where NetworkParameters { genesisParameters = GenesisParameters { getGenesisBlockDate } } = np + networkId = networkDiscriminantToId network + currentNodeTip :: IO BlockHeader currentNodeTip = runBlockfrost BF.getLatestBlock -- ^ TODO: use cached value while retrying @@ -228,13 +247,32 @@ withNetworkLayer tr net np project k = k NetworkLayer currentNodeEra = handleBlockfrostError $ do BF.EpochInfo {_epochInfoEpoch} <- liftBlockfrost BF.getLatestEpoch epoch <- fromBlockfrostM _epochInfoEpoch - liftEither $ eraByEpoch net epoch + liftEither $ eraByEpoch networkId epoch timeInterpreterFromStartTime :: StartTime -> TimeInterpreter (ExceptT PastHorizonException IO) timeInterpreterFromStartTime startTime = mkTimeInterpreter (MsgTimeInterpreterLog >$< tr) startTime $ - pure $ HF.mkInterpreter $ networkSummary net + pure $ HF.mkInterpreter $ networkSummary networkId + + fetchNetworkRewardAccountBalances :: + SomeNetworkDiscriminant -> + Set RewardAccount -> + IO (Map RewardAccount Coin) + fetchNetworkRewardAccountBalances + (SomeNetworkDiscriminant (Proxy :: Proxy nd)) accounts = + handleBlockfrostError . fmap Map.fromList $ + for (Set.toList accounts) $ \rewardAccount -> do + BF.AccountInfo {..} <- liftBlockfrost $ BF.getAccount $ + BF.mkAddress $ encodeStakeAddress @nd rewardAccount + coin <- fromIntegral @_ @Integer _accountInfoRewardsSum + "AccountInfoRewardsSum" + pure (rewardAccount, Coin coin) + + getCachedRewardAccountBalance :: RewardAccount -> IO Coin + getCachedRewardAccountBalance account = + fromMaybe (Coin 0) . Map.lookup account <$> + fetchNetworkRewardAccountBalances network (Set.singleton account) handleBlockfrostError :: ExceptT BlockfrostError IO a -> IO a handleBlockfrostError = @@ -645,7 +683,7 @@ For the Mainnet: For the Testnet: -} eraByEpoch :: NetworkId -> EpochNo -> Either BlockfrostError AnyCardanoEra -eraByEpoch net epoch = +eraByEpoch networkId epoch = case dropWhile ((> epoch) . snd) (reverse eraBoundaries) of (era, _) : _ -> Right era _ -> Left $ UnknownEraForEpoch epoch @@ -657,7 +695,7 @@ eraByEpoch net epoch = -- When new era is added this function reminds to update itself: -- "Pattern match(es) are non-exhaustive" epochEraStartsAt :: Node.AnyCardanoEra -> EpochNo - epochEraStartsAt era = EpochNo $ case net of + epochEraStartsAt era = EpochNo $ case networkId of Mainnet -> case era of AnyCardanoEra AlonzoEra -> 290 diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Network/Discriminant.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Network/Discriminant.hs new file mode 100644 index 00000000000..1a0ff2b7839 --- /dev/null +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Network/Discriminant.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Cardano.Wallet.Shelley.Network.Discriminant + ( SomeNetworkDiscriminant (..) + , networkDiscriminantToId + ) where + +import Prelude + +import Cardano.Wallet.Api.Types + ( DecodeAddress, DecodeStakeAddress, EncodeAddress, EncodeStakeAddress ) +import Cardano.Wallet.Primitive.AddressDerivation + ( DelegationAddress + , NetworkDiscriminant + , NetworkDiscriminantVal + , PaymentAddress + ) +import Cardano.Wallet.Primitive.AddressDerivation.Byron + ( ByronKey ) +import Cardano.Wallet.Primitive.AddressDerivation.Icarus + ( IcarusKey ) +import Cardano.Wallet.Primitive.AddressDerivation.Shelley + ( ShelleyKey ) +import Cardano.Wallet.Shelley.Compatibility + ( HasNetworkId (..), NetworkId ) +import Data.Proxy + ( Proxy ) +import Data.Typeable + ( Typeable ) + +-- | Encapsulate a network discriminant and the necessary constraints it should +-- satisfy. +data SomeNetworkDiscriminant where + SomeNetworkDiscriminant + :: forall (n :: NetworkDiscriminant). + ( NetworkDiscriminantVal n + , PaymentAddress n IcarusKey + , PaymentAddress n ByronKey + , PaymentAddress n ShelleyKey + , DelegationAddress n ShelleyKey + , HasNetworkId n + , DecodeAddress n + , EncodeAddress n + , DecodeStakeAddress n + , EncodeStakeAddress n + , Typeable n + ) + => Proxy n + -> SomeNetworkDiscriminant + +deriving instance Show SomeNetworkDiscriminant + +networkDiscriminantToId :: SomeNetworkDiscriminant -> NetworkId +networkDiscriminantToId (SomeNetworkDiscriminant proxy) = networkIdVal proxy diff --git a/nix/materialized/stack-nix/cardano-wallet.nix b/nix/materialized/stack-nix/cardano-wallet.nix index 5d5566ff6d3..71dc98b9deb 100644 --- a/nix/materialized/stack-nix/cardano-wallet.nix +++ b/nix/materialized/stack-nix/cardano-wallet.nix @@ -115,6 +115,7 @@ "Cardano/Wallet/Shelley/Compatibility/Ledger" "Cardano/Wallet/Shelley/Network" "Cardano/Wallet/Shelley/Network/Blockfrost" + "Cardano/Wallet/Shelley/Network/Discriminant" "Cardano/Wallet/Shelley/Network/Node" "Cardano/Wallet/Shelley/Transaction" "Cardano/Wallet/Shelley/Launch"