Implement getPoolLifeCycleStatus

cardano-foundation · Jun 13, 2022 · 645593b · 645593b
1 parent 08e411c
commit 645593b
Show file tree

Hide file tree

Showing 6 changed files with 160 additions and 71 deletions.
diff --git a/lib/shelley/cardano-wallet.cabal b/lib/shelley/cardano-wallet.cabal
@@ -120,6 +120,7 @@ library
       Cardano.Wallet.Shelley.Compatibility.Ledger
       Cardano.Wallet.Shelley.Network
       Cardano.Wallet.Shelley.Network.Blockfrost
+      Cardano.Wallet.Shelley.Network.Blockfrost.Conversion
       Cardano.Wallet.Shelley.Network.Blockfrost.Error
       Cardano.Wallet.Shelley.Network.Blockfrost.Fixture
       Cardano.Wallet.Shelley.Network.Blockfrost.Monad

diff --git a/lib/shelley/src/Cardano/Wallet/Shelley.hs b/lib/shelley/src/Cardano/Wallet/Shelley.hs
@@ -250,7 +250,7 @@ serveWallet
                 netParams
                 netLayer
         BlockfrostSource bfProject -> do
-            withBlockfrostStakePoolLayer poolsEngineTracer bfProject
+            withBlockfrostStakePoolLayer poolsEngineTracer bfProject network
     randomApi <- withRandomApi netLayer
     icarusApi  <- withIcarusApi netLayer
     shelleyApi <- withShelleyApi netLayer

diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Network/Blockfrost.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Network/Blockfrost.hs
@@ -22,13 +22,13 @@
 --
 -- Network Layer implementation that uses Blockfrost API
 module Cardano.Wallet.Shelley.Network.Blockfrost
-  ( withNetworkLayer,
-    Log,
+    ( withNetworkLayer,
+        Log,
 
-    -- * Internal
-    getPoolPerformanceEstimate,
-    eraByEpoch
-  )
+        -- * Internal
+        getPoolPerformanceEstimate,
+        eraByEpoch
+    )
 where
 
 import Prelude
@@ -58,7 +58,7 @@ import Cardano.Pool.Rank.Likelihood
 import Cardano.Slotting.Slot
     ( unEpochSize )
 import Cardano.Wallet.Api.Types
-    ( decodeAddress, decodeStakeAddress, encodeAddress, encodeStakeAddress )
+    ( decodeStakeAddress, encodeAddress, encodeStakeAddress )
 import Cardano.Wallet.Logging
     ( BracketLog, bracketTracer )
 import Cardano.Wallet.Network
@@ -132,8 +132,10 @@ import Cardano.Wallet.Primitive.Types.TokenBundle
     ( TokenBundle (..) )
 import Cardano.Wallet.Primitive.Types.Tx
     ( Tx (..), TxIn (..), TxOut (..), TxScriptValidity (..), TxSize (..) )
+import Cardano.Wallet.Shelley.Network.Blockfrost.Conversion
+    ( fromBfAddress, fromBfLovelaces )
 import Cardano.Wallet.Shelley.Network.Blockfrost.Error
-    ( BlockfrostError (..) )
+    ( BlockfrostError (..), (<?#>), (<?>) )
 import Cardano.Wallet.Shelley.Network.Blockfrost.Monad
     ( BFM )
 import Cardano.Wallet.Shelley.Network.Discriminant
@@ -158,16 +160,14 @@ import Data.Bifunctor
     ( first )
 import Data.Bitraversable
     ( bitraverse )
-import Data.Bits
-    ( Bits )
 import Data.Function
     ( (&) )
 import Data.Functor
     ( void, (<&>) )
 import Data.Functor.Contravariant
     ( (>$<) )
 import Data.IntCast
-    ( intCast, intCastMaybe )
+    ( intCast )
 import Data.List
     ( partition )
 import Data.List.NonEmpty
@@ -203,8 +203,6 @@ import Fmt
     ( pretty )
 import GHC.OldList
     ( sortOn )
-import Money
-    ( Discrete' )
 import Ouroboros.Consensus.Cardano.Block
     ( CardanoBlock, StandardCrypto )
 import Ouroboros.Consensus.HardFork.History.EraParams
@@ -649,7 +647,7 @@ withNetworkLayer tr network np project k = do
         BFM.run bfConfig do
             BF.Network{_networkStake = BF.NetworkStake{_stakeLive}} <-
                 BF.getNetworkInfo
-            totalLiveStake <- fromBlockfrostM _stakeLive
+            totalLiveStake <- fromBfLovelaces _stakeLive
             pools <- mapConcurrently BF.getPool =<< BF.listPools
             stake <- poolsStake totalLiveStake pools
             pure StakePoolsSummary
@@ -667,12 +665,12 @@ withNetworkLayer tr network np project k = do
                 -> m (Map PoolId Percentage)
             poolsStake total = fmap Map.fromList . traverse \BF.PoolInfo{..} ->
                 (,) <$> fromBlockfrostM _poolInfoPoolId <*> do
-                    live <- fromBlockfrostM @_ @Coin _poolInfoLiveStake
+                    live <- fromBfLovelaces _poolInfoLiveStake
                     let ratio = Coin.toInteger live % Coin.toInteger total
                     case mkPercentage ratio of
-                       Right percentage -> pure percentage
-                       Left PercentageOutOfBoundsError ->
-                           throwError $ PoolStakePercentageError total live
+                        Right percentage -> pure percentage
+                        Left PercentageOutOfBoundsError ->
+                            throwError $ PoolStakePercentageError total live
 
 fetchNextBlocks
     :: forall m
@@ -781,7 +779,7 @@ assembleTransaction
     -> [BF.TransactionMetaJSON]
     -> m Tx
 assembleTransaction
-    (SomeNetworkDiscriminant (Proxy :: Proxy nd))
+    network@(SomeNetworkDiscriminant (Proxy :: Proxy nd))
     BF.Transaction{..}
     BF.TransactionUtxos{..}
     txWithdrawals
@@ -791,15 +789,12 @@ assembleTransaction
         (resolvedInputs, resolvedCollateralInputs) <-
             fromInputs _transactionUtxosInputs
         outputs <- for _transactionUtxosOutputs \out@BF.UtxoOutput{..} -> do
-            let outAddr = BF.unAddress _utxoOutputAddress
-            address <-
-                either (throwError . InvalidAddress outAddr) pure $
-                    decodeAddress @nd outAddr
+            address <- fromBfAddress network _utxoOutputAddress
             tokens <- do
                 coin <- case [ lovelaces
                              | BF.AdaAmount lovelaces <- _utxoOutputAmount
                              ] of
-                    [l] -> fromBlockfrost l
+                    [l] -> fromBfLovelaces l
                     _ -> throwError $ InvalidUtxoOutputAmount out
                 pure $ TokenBundle coin mempty -- TODO: Handle native assets
             pure TxOut{..}
@@ -809,7 +804,7 @@ assembleTransaction
                     let addr = BF.unAddress _transactionWithdrawalAddress
                     rewardAccount <-
                         first (InvalidAddress addr) $ decodeStakeAddress @nd addr
-                    coin <- fromBlockfrost _transactionWithdrawalAmount
+                    coin <- fromBfLovelaces _transactionWithdrawalAmount
                     pure (rewardAccount, coin)
         metadata <-
             if null metadataJSON
@@ -851,7 +846,7 @@ assembleTransaction
                 txIndex <- _utxoInputOutputIndex <?#> "_utxoInputOutputIndex"
                 coin <-
                     case [lovelaces | BF.AdaAmount lovelaces <- _utxoInputAmount] of
-                        [l] -> fromBlockfrost l
+                        [l] -> fromBfLovelaces l
                         _ -> throwError $ InvalidUtxoInputAmount input
                 pure (TxIn txHash txIndex, coin)
 
@@ -905,8 +900,7 @@ fromBlockfrostPP
 fromBlockfrostPP network BF.ProtocolParams{..} = do
     decentralizationLevel <-
         let percentage =
-                mkPercentage $
-                    toRational _protocolParamsDecentralisationParam
+                mkPercentage $ toRational _protocolParamsDecentralisationParam
             in case percentage of
                 Left PercentageOutOfBoundsError ->
                     throwError $
@@ -1064,11 +1058,6 @@ instance FromBlockfrost BF.PoolId PoolId where
 instance FromBlockfrost BF.Epoch EpochNo where
     fromBlockfrost = pure . fromIntegral
 
--- type Lovelaces = Discrete' "ADA" '(1000000, 1)
-instance FromBlockfrost (Discrete' "ADA" '(1000000, 1)) Coin where
-    fromBlockfrost lovelaces =
-        Coin <$> (intCast @_ @Integer lovelaces <?#> "Lovelaces")
-
 eraByEpoch :: NetworkId -> EpochNo -> Either BlockfrostError AnyCardanoEra
 eraByEpoch networkId epoch =
     dropWhile ((> epoch) . snd) (reverse (Fixture.eraBoundaries networkId)) &
@@ -1087,27 +1076,6 @@ epochEraSummary networkId (EpochNo epoch) =
         UC.NonEmptyCons era@EraSummary{eraEnd=EraEnd Bound{boundEpoch}} eras ->
             if boundEpoch > fromIntegral epoch then era else go eras
 
--- | Raises an error in case of an absent value
-(<?>) :: MonadError e m => Maybe a -> e -> m a
-(<?>) Nothing e = throwError e
-(<?>) (Just a) _ = pure a
-
-infixl 8 <?>
-
-{-# INLINE (<?>) #-}
-
--- | Casts integral values safely or raises an `IntegralCastError`
-(<?#>)
-    :: (MonadError BlockfrostError m, Integral a, Integral b, Bits a, Bits b)
-    => a
-    -> String
-    -> m b
-(<?#>) a e = intCastMaybe a <?> IntegralCastError e
-
-infixl 8 <?#>
-
-{-# INLINE (<?#>) #-}
-
 {-------------------------------------------------------------------------------
     Stake Pools
 -------------------------------------------------------------------------------}

diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Network/Blockfrost/Error.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Network/Blockfrost/Error.hs
@@ -1,22 +1,31 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleContexts #-}
 
 module Cardano.Wallet.Shelley.Network.Blockfrost.Error where
 
 import Prelude
 
 import Cardano.Wallet.Primitive.Types
-    ( EpochNo )
+    ( EpochNo, PoolId )
 import Cardano.Wallet.Primitive.Types.Coin
     ( Coin )
 import Control.Exception
     ( Exception )
+import Data.Bits
+    ( Bits )
 import Data.Text
     ( Text )
 import Data.Text.Class
     ( TextDecodingError )
 
 import qualified Blockfrost.Client as BF
+import Control.Monad.Error.Class
+    ( MonadError (throwError) )
+import Data.IntCast
+    ( intCastMaybe )
+import Data.Quantity
+    ( MkPercentageError )
 import qualified Servant.Client as Servant
 
 data BlockfrostError
@@ -26,12 +35,17 @@ data BlockfrostError
     | InvalidBlockHash BF.BlockHash TextDecodingError
     | InvalidTxMetadataLabel String
     | InvalidTxMetadataValue String
+    | InvalidStakePoolMetadataHash Text TextDecodingError
+    | PoolRegistrationIsMissing PoolId
+    | PoolRetirementCertificateNotFound PoolId BF.PoolUpdate
+    | PoolUpdateCertificateNotFound PoolId BF.PoolUpdate
     | InvalidTxHash Text TextDecodingError
     | InvalidAddress Text TextDecodingError
     | InvalidStakeAddress Text TextDecodingError
     | InvalidPoolId Text TextDecodingError
     | PoolStakePercentageError Coin Coin
     | InvalidDecentralizationLevelPercentage Double
+    | InvalidPercentage Double MkPercentageError
     | InvalidUtxoInputAmount BF.UtxoInput
     | InvalidUtxoOutputAmount BF.UtxoOutput
     | UnknownEraForEpoch EpochNo
@@ -40,3 +54,24 @@ data BlockfrostError
 newtype BlockfrostException = BlockfrostException BlockfrostError
     deriving stock (Show)
     deriving anyclass (Exception)
+
+-- | Raises an error in case of an absent value
+(<?>) :: MonadError e m => Maybe a -> e -> m a
+(<?>) Nothing e = throwError e
+(<?>) (Just a) _ = pure a
+
+infixl 8 <?>
+
+{-# INLINE (<?>) #-}
+
+-- | Casts integral values safely or raises an `IntegralCastError`
+(<?#>)
+    :: (MonadError BlockfrostError m, Integral a, Integral b, Bits a, Bits b)
+    => a
+    -> String
+    -> m b
+(<?#>) a e = intCastMaybe a <?> IntegralCastError e
+
+infixl 8 <?#>
+
+{-# INLINE (<?#>) #-}
diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Network/Blockfrost/Monad.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Network/Blockfrost/Monad.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE UndecidableInstances #-}
 
@@ -54,7 +55,7 @@ instance BF.MonadBlockfrost BFM where
 newClientConfig :: BF.Project -> IO BF.ClientConfig
 newClientConfig prj = (,prj) <$> BF.newEnvByProject prj
 
-run :: BF.ClientConfig -> BFM a -> IO a
+run :: BF.ClientConfig -> (forall a. BFM a -> IO a)
 run cfg (BFM c) = handleBlockfrostError (runReaderT c cfg)
 
 handleBlockfrostError :: ExceptT BlockfrostError IO a -> IO a