Merge #3209

3209: Light Mode: currentCardanoEra r=Unisay a=Unisay - [x] I have tested Epoch/Era translation in REPL manually. - [x] wrote unit test for the Epoch/Era translation. ### Comments Blockfrost API doesn't expose current Era so its implemented as a translation from current epoch number using a hardcoded table. ``` ┌───────┬───────┬─────────┐ │ Epoch │ Major │ Era │ ├───────┼───────┼─────────┤ │ ... │ 6 │ Alonzo │ │ 298 │ 6 │ Alonzo │ ├───────┼───────┼─────────┤ │ 297 │ 5 │ Alonzo │ │ ... │ 5 │ Alonzo │ │ 290 │ 5 │ Alonzo │ ├───────┼───────┼─────────┤ │ 289 │ 4 │ Mary │ │ ... │ 4 │ Mary │ │ 251 │ 4 │ Mary │ ├───────┼───────┼─────────┤ │ 250 │ 3 │ Allegra │ │ ... │ 3 │ Allegra │ │ 236 │ 3 │ Allegra │ ├───────┼───────┼─────────┤ │ 235 │ 2 │ Shelley │ │ ... │ 2 │ Shelley │ │ 202 │ 2 │ Shelley │ ├───────┼───────┼─────────┤ │ 201 │ 1 │ Byron │ │ ... │ 1 │ Byron │ └───────┴───────┴─────────┘ ``` When new era type is added its expected that compiler emits a warning about non-exhaustive pattern match, thus forcing developer to update translation table with the corresponding epoch number; ### Issue Number ADP-1504 Co-authored-by: Yuriy Lazaryev <[email protected]> Co-authored-by: IOHK <[email protected]>
cardano-foundation · Apr 4, 2022 · d3a5ad4 · d3a5ad4
2 parents 8fa352e + e965f80
commit d3a5ad4
Show file tree

Hide file tree

Showing 5 changed files with 134 additions and 39 deletions.
diff --git a/lib/shelley/cardano-wallet.cabal b/lib/shelley/cardano-wallet.cabal
@@ -277,6 +277,7 @@ test-suite unit
       Cardano.Wallet.Shelley.LaunchSpec
       Cardano.Wallet.Shelley.Launch.BlockfrostSpec
       Cardano.Wallet.Shelley.NetworkSpec
+      Cardano.Wallet.Shelley.Network.BlockfrostSpec
       Cardano.Wallet.Shelley.TransactionSpec
       Spec
 

diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs
@@ -66,5 +66,5 @@ withNetworkLayer tr blockchainSrc net netParams tol =
             in Node.withNetworkLayer tr' net netParams nodeConn ver tol
         BlockfrostSource project ->
             let tr' = BlockfrostNetworkLog >$< tr
-            in Blockfrost.withNetworkLayer tr' project
+            in Blockfrost.withNetworkLayer tr' net project
 
diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Network/Blockfrost.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Network/Blockfrost.hs
@@ -3,6 +3,7 @@
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns #-}
@@ -27,8 +28,7 @@ module Cardano.Wallet.Shelley.Network.Blockfrost
 
     -- * Internal
     , getPoolPerformanceEstimate
-    -- * Blockfrost -> Cardano translation
-    , fromBlockfrost
+    , eraByEpoch
     ) where
 
 import Prelude
@@ -38,7 +38,7 @@ import qualified Cardano.Api.Shelley as Node
 import qualified Data.Sequence as Seq
 
 import Cardano.Api
-    ( AnyCardanoEra )
+    ( AnyCardanoEra, NetworkId (Mainnet, Testnet) )
 import Cardano.BM.Data.Severity
     ( Severity (..) )
 import Cardano.BM.Tracer
@@ -56,6 +56,7 @@ import Cardano.Wallet.Network
 import Cardano.Wallet.Primitive.Types
     ( BlockHeader (..)
     , DecentralizationLevel (..)
+    , EpochNo (EpochNo)
     , ExecutionUnitPrices (..)
     , ExecutionUnits (..)
     , FeePolicy (LinearFee)
@@ -76,22 +77,18 @@ import Cardano.Wallet.Primitive.Types.Hash
     ( Hash )
 import Cardano.Wallet.Primitive.Types.Tx
     ( TxSize (..) )
-import Control.Arrow
-    ( (<<<) )
 import Control.Concurrent
     ( threadDelay )
 import Control.Monad
     ( forever, (<=<) )
 import Control.Monad.Error.Class
     ( MonadError, liftEither, throwError )
 import Control.Monad.Trans.Except
-    ( ExceptT (..), runExceptT )
-import Data.Bifunctor
-    ( first )
+    ( ExceptT (..), runExceptT, withExceptT )
 import Data.Bits
     ( Bits )
-import Data.Function
-    ( (&) )
+import Data.Functor
+    ( (<&>) )
 import Data.Functor.Contravariant
     ( (>$<) )
 import Data.IntCast
@@ -127,7 +124,8 @@ data BlockfrostError
     | NoBlockHeight BF.Block
     | InvalidBlockHash BF.BlockHash TextDecodingError
     | InvalidDecentralizationLevelPercentage Double
-    deriving (Show)
+    | UnknownEraForEpoch EpochNo
+    deriving (Show, Eq)
 
 newtype BlockfrostException = BlockfrostException BlockfrostError
     deriving stock (Show)
@@ -147,10 +145,11 @@ instance HasSeverityAnnotation Log where
 
 withNetworkLayer
     :: Tracer IO Log
+    -> NetworkId
     -> BF.Project
     -> (NetworkLayer IO (CardanoBlock StandardCrypto) -> IO a)
     -> IO a
-withNetworkLayer tr project k = k NetworkLayer
+withNetworkLayer tr net project k = k NetworkLayer
     { chainSync = \_tr _chainFollower -> pure ()
     , lightSync = Nothing
     , currentNodeTip
@@ -167,42 +166,39 @@ withNetworkLayer tr project k = k NetworkLayer
     }
   where
     currentNodeTip :: IO BlockHeader
-    currentNodeTip = runBlockfrost BF.getLatestBlock & runExceptT >>= \case
-        -- TODO: use cached value while retrying
-        Left err -> throwIO (BlockfrostException err)
-        Right header -> pure header
+    currentNodeTip = runBlockfrost BF.getLatestBlock
+    -- ^ TODO: use cached value while retrying
 
     watchNodeTip :: (BlockHeader -> IO ()) -> IO ()
     watchNodeTip callback = link =<< async (pollNodeTip callback)
       where
         pollNodeTip :: (BlockHeader -> IO ()) -> IO ()
         pollNodeTip cb = forever $ do
-            runBlockfrost BF.getLatestBlock & runExceptT >>= \case
-                Left err -> throwIO (BlockfrostException err)
-                Right header ->
-                    bracketTracer (MsgWatcherUpdate header >$< tr) $ cb header
+            header <- runBlockfrost BF.getLatestBlock
+            bracketTracer (MsgWatcherUpdate header >$< tr) $ cb header
             threadDelay 2_000_000
 
     currentProtocolParameters :: IO ProtocolParameters
-    currentProtocolParameters =
-        runBlockfrost BF.getLatestEpochProtocolParams & runExceptT >>= \case
-            -- TODO: use cached value while retrying
-            Left err -> throwIO (BlockfrostException err)
-            Right params -> pure params
+    currentProtocolParameters = runBlockfrost BF.getLatestEpochProtocolParams
 
     currentNodeEra :: IO AnyCardanoEra
-    currentNodeEra = undefined
+    currentNodeEra = handleBlockfrostError $ do
+        BF.EpochInfo {_epochInfoEpoch} <- liftBlockfrost BF.getLatestEpoch
+        epoch <- fromBlockfrostM _epochInfoEpoch
+        liftEither $ eraByEpoch net epoch
+
+    handleBlockfrostError :: ExceptT BlockfrostError IO a -> IO a
+    handleBlockfrostError =
+        either (throwIO . BlockfrostException) pure <=< runExceptT
 
     runBlockfrost ::
-        FromBlockfrost b w =>
-        BF.BlockfrostClientT IO b ->
-        ExceptT BlockfrostError IO w
+        forall b w. FromBlockfrost b w => BF.BlockfrostClientT IO b -> IO w
     runBlockfrost =
-        fromBlockfrostM
-            <=< ExceptT
-            <<< (first ClientError <$>)
-            <<< BF.runBlockfrostClientT project
+        handleBlockfrostError . (fromBlockfrostM @b @w <=< liftBlockfrost)
 
+    liftBlockfrost :: BF.BlockfrostClientT IO a -> ExceptT BlockfrostError IO a
+    liftBlockfrost =
+        withExceptT ClientError . ExceptT . BF.runBlockfrostClientT project
 
 blockToBlockHeader ::
     forall m. MonadError BlockfrostError m => BF.Block -> m BlockHeader
@@ -227,10 +223,7 @@ class FromBlockfrost b w where
     fromBlockfrost :: b -> Either BlockfrostError w
 
 fromBlockfrostM
-    :: FromBlockfrost b w
-    => MonadError BlockfrostError m
-    => b
-    -> m w
+    :: FromBlockfrost b w => MonadError BlockfrostError m => b -> m w
 fromBlockfrostM = liftEither . fromBlockfrost
 
 instance FromBlockfrost BF.Block BlockHeader where
@@ -388,8 +381,67 @@ instance FromBlockfrost BF.ProtocolParams ProtocolParameters where
 instance FromBlockfrost BF.Slot SlotNo where
     fromBlockfrost = fmap SlotNo . (<?#> "SlotNo") . BF.unSlot
 
+instance FromBlockfrost BF.Epoch EpochNo where
+    fromBlockfrost = pure . fromIntegral
+
+
+{- Epoch-to-Era translation is not available in the Blockfrost API.
+
+For the Mainnet we're hardcoding the following history
+in order to work around this limiation:
+
+┌───────┬───────┬─────────┐
+│ Epoch │ Major │   Era   │
+├───────┼───────┼─────────┤
+│  ...  │   6   │ Alonzo  │
+│  298  │   6   │ Alonzo  │
+├───────┼───────┼─────────┤
+│  297  │   5   │ Alonzo  │
+│  ...  │   5   │ Alonzo  │
+│  290  │   5   │ Alonzo  │
+├───────┼───────┼─────────┤
+│  289  │   4   │  Mary   │
+│  ...  │   4   │  Mary   │
+│  251  │   4   │  Mary   │
+├───────┼───────┼─────────┤
+│  250  │   3   │ Allegra │
+│  ...  │   3   │ Allegra │
+│  236  │   3   │ Allegra │
+├───────┼───────┼─────────┤
+│  235  │   2   │ Shelley │
+│  ...  │   2   │ Shelley │
+│  202  │   2   │ Shelley │
+├───────┼───────┼─────────┤
+│  201  │   1   │  Byron  │
+│  ...  │   1   │  Byron  │
+└───────┴───────┴─────────┘
+-}
+eraByEpoch :: NetworkId -> EpochNo -> Either BlockfrostError AnyCardanoEra
+eraByEpoch = \case
+    Mainnet -> \epoch ->
+        case dropWhile ((> epoch) . snd) (reverse eraBoundaries) of
+            (era, _) : _ -> Right era
+            _ -> Left $ UnknownEraForEpoch epoch
+    Testnet _ -> \_ -> error
+        "In light-mode era to epoch conversions are only available for the \
+        \mainnet (translation uses a hard-coded history of hard forks). \
+        \It doesn't seem viable to hardcode eras for other networks yet."
+
+eraBoundaries :: [(Node.AnyCardanoEra, EpochNo)]
+eraBoundaries = [minBound .. maxBound] <&> \era -> (era, epochEraStartsAt era)
+  where
+    -- When new era is added this function reminds to update itself:
+    -- "Pattern match(es) are non-exhaustive"
+    epochEraStartsAt :: Node.AnyCardanoEra -> EpochNo
+    epochEraStartsAt = EpochNo . \case
+        Node.AnyCardanoEra Node.AlonzoEra  -> 290
+        Node.AnyCardanoEra Node.MaryEra    -> 251
+        Node.AnyCardanoEra Node.AllegraEra -> 236
+        Node.AnyCardanoEra Node.ShelleyEra -> 202
+        Node.AnyCardanoEra Node.ByronEra   -> 0
+
 -- | Raises an error in case of an absent value
-(<?>) :: MonadError e' m => Maybe a -> e' -> m a
+(<?>) :: MonadError e m => Maybe a -> e -> m a
 (<?>) Nothing e = throwError e
 (<?>) (Just a) _ = pure a
 

diff --git a/lib/shelley/test/unit/Cardano/Wallet/Shelley/Network/BlockfrostSpec.hs b/lib/shelley/test/unit/Cardano/Wallet/Shelley/Network/BlockfrostSpec.hs
@@ -0,0 +1,41 @@
+module Cardano.Wallet.Shelley.Network.BlockfrostSpec (spec) where
+
+import Prelude
+
+import Cardano.Api
+    ( AnyCardanoEra (..), CardanoEra (..), NetworkId (Mainnet) )
+import Cardano.Wallet.Primitive.Types
+    ( EpochNo )
+import Cardano.Wallet.Shelley.Network.Blockfrost
+    ( eraByEpoch )
+import Data.Foldable
+    ( for_ )
+import Test.Hspec
+    ( Spec, describe, it, shouldBe )
+
+spec :: Spec
+spec = describe "Blockfrost Network" $ do
+    it "determines era by epoch" $ do
+        for_ epochEras $ \(epoch, era) ->
+            eraByEpoch Mainnet epoch `shouldBe` Right era
+  where
+    epochEras :: [(EpochNo, AnyCardanoEra)]
+    epochEras =
+        [ (329, AnyCardanoEra AlonzoEra)
+        , (298, AnyCardanoEra AlonzoEra)
+        , (297, AnyCardanoEra AlonzoEra)
+        , (295, AnyCardanoEra AlonzoEra)
+        , (290, AnyCardanoEra AlonzoEra)
+        , (289, AnyCardanoEra MaryEra)
+        , (260, AnyCardanoEra MaryEra)
+        , (251, AnyCardanoEra MaryEra)
+        , (250, AnyCardanoEra AllegraEra)
+        , (240, AnyCardanoEra AllegraEra)
+        , (236, AnyCardanoEra AllegraEra)
+        , (235, AnyCardanoEra ShelleyEra)
+        , (220, AnyCardanoEra ShelleyEra)
+        , (202, AnyCardanoEra ShelleyEra)
+        , (201, AnyCardanoEra ByronEra)
+        , (001, AnyCardanoEra ByronEra)
+        , (000, AnyCardanoEra ByronEra)
+        ]
diff --git a/nix/materialized/stack-nix/cardano-wallet.nix b/nix/materialized/stack-nix/cardano-wallet.nix