merrying feePolicy and slotLength getters in jormungandr network

cardano-foundation · Jul 12, 2019 · cea809c · cea809c
1 parent a53f988
commit cea809c
Show file tree

Hide file tree

Showing 3 changed files with 26 additions and 75 deletions.
diff --git a/exe/wallet/jormungandr/Main.hs b/exe/wallet/jormungandr/Main.hs
@@ -74,11 +74,7 @@ import Cardano.Wallet.Jormungandr.Compatibility
 import Cardano.Wallet.Jormungandr.Environment
     ( KnownNetwork (..), Network (..) )
 import Cardano.Wallet.Jormungandr.Network
-    ( ErrGetInitialFeePolicy (..)
-    , ErrGetInitialSlotDuration (..)
-    , getBlock
-    , getInitialFeePolicy
-    )
+    ( ErrGetInitialConfigParams (..), getBlock, getInitialConfigParams )
 import Cardano.Wallet.Jormungandr.Primitive.Types
     ( Tx (..) )
 import Cardano.Wallet.Network
@@ -95,7 +91,7 @@ import Cardano.Wallet.Primitive.AddressDiscovery
 import Cardano.Wallet.Primitive.Fee
     ( FeePolicy )
 import Cardano.Wallet.Primitive.Types
-    ( Block (..), Hash (..) )
+    ( Block (..), Hash (..), SlotLength )
 import Cardano.Wallet.Version
     ( showVersion, version )
 import Control.Applicative
@@ -344,26 +340,14 @@ cmdServe = command "serve" $ info (helper <*> cmd) $ mempty
             -> DBLayer IO s t
             -> IO (WalletLayer s t)
         newWalletLayer (sb, tracer) db = do
-            (nl, block0, theFeePolicy) <- newNetworkLayer (sb, tracer)
+            (nl, block0, theFeePolicy, theSlotLength) <- newNetworkLayer (sb, tracer)
             let tl = Jormungandr.newTransactionLayer @n block0H
-            let url = BaseUrl Http "localhost" (getPort nodePort) "/api"
-            mgr <- newManager defaultManagerSettings
-            let jor = Jormungandr.mkJormungandrLayer mgr url
-            theSlotLength <-
-                runExceptT (Jormungandr.getInitialSlotDuration jor (coerce block0H)) >>= \case
-                Right a -> return a
-                Left (ErrGetInitialSlotDurationNetworkUnreachable _) ->
-                    handleNetworkUnreachable tracer
-                Left (ErrGetInitialSlotDurationGenesisNotFound _) ->
-                    handleGenesisNotFound (sb, tracer)
-                Left (ErrGetInitialSlotDurationNoInitialPolicy _) ->
-                    handleNoInitialPolicy tracer
             Wallet.newWalletLayer
                 tracer (BlockchainParameters block0 theFeePolicy theSlotLength) db nl tl
 
         newNetworkLayer
             :: (Switchboard Text, Trace IO Text)
-            -> IO (NetworkLayer t IO, Block Tx, FeePolicy)
+            -> IO (NetworkLayer t IO, Block Tx, FeePolicy, SlotLength)
         newNetworkLayer (sb, tracer) = do
             let url = BaseUrl Http "localhost" (getPort nodePort) "/api"
             mgr <- newManager defaultManagerSettings
@@ -377,15 +361,16 @@ cmdServe = command "serve" $ info (helper <*> cmd) $ mempty
                     handleNetworkUnreachable tracer
                 Left (ErrGetBlockNotFound _) ->
                     handleGenesisNotFound (sb, tracer)
-            theFeePolicy <- runExceptT (getInitialFeePolicy jor (coerce block0H)) >>= \case
+            (theFeePolicy, theSlotLength) <-
+                runExceptT (getInitialConfigParams jor (coerce block0H)) >>= \case
                 Right a -> return a
-                Left (ErrGetInitialFeePolicyNetworkUnreachable _) ->
+                Left (ErrGetInitialConfigParamsNetworkUnreachable _) ->
                     handleNetworkUnreachable tracer
-                Left (ErrGetInitialFeePolicyGenesisNotFound _) ->
+                Left (ErrGetInitialConfigParamsGenesisNotFound _) ->
                     handleGenesisNotFound (sb, tracer)
-                Left (ErrGetInitialFeePolicyNoInitialPolicy _) ->
+                Left (ErrGetInitialConfigParamsNoInitialPolicy _) ->
                     handleNoInitialPolicy tracer
-            return (nl, block0, theFeePolicy)
+            return (nl, block0, theFeePolicy, theSlotLength)
 
         withDBLayer
             :: CM.Configuration

diff --git a/lib/jormungandr/src/Cardano/Wallet/Jormungandr/Network.hs b/lib/jormungandr/src/Cardano/Wallet/Jormungandr/Network.hs
@@ -25,9 +25,8 @@ module Cardano.Wallet.Jormungandr.Network
     , ErrUnexpectedNetworkFailure (..)
 
     -- * Errors
-    , ErrGetInitialFeePolicy (..)
     , ErrGetDescendants (..)
-    , ErrGetInitialSlotDuration (..)
+    , ErrGetInitialConfigParams (..)
 
     -- * Re-export
     , BaseUrl (..)
@@ -174,12 +173,9 @@ data JormungandrLayer m = JormungandrLayer
     , postMessage
         :: (Tx, [TxWitness])
         -> ExceptT ErrPostTx m ()
-    , getInitialFeePolicy
+    , getInitialConfigParams
         :: Hash "Genesis"
-        -> ExceptT ErrGetInitialFeePolicy m FeePolicy
-    , getInitialSlotDuration
-        :: Hash "Genesis"
-        -> ExceptT ErrGetInitialSlotDuration m SlotLength
+        -> ExceptT ErrGetInitialConfigParams m (FeePolicy, SlotLength)
     }
 
 -- | Construct a 'JormungandrLayer'-client
@@ -241,14 +237,13 @@ mkJormungandrLayer mgr baseUrl = JormungandrLayer
             x -> do
                 let ctx = safeLink api (Proxy @PostMessage)
                 left ErrPostTxNetworkUnreachable <$> defaultHandler ctx x
-
-    , getInitialFeePolicy = \block0 -> do
+    , getInitialConfigParams = \block0 -> do
         J.Block _ msgs <- ExceptT $ run (cGetBlock (BlockId $ coerce block0)) >>= \case
             Left (FailureResponse e) | responseStatusCode e == status400 ->
-                return . Left . ErrGetInitialFeePolicyGenesisNotFound $ block0
+                return . Left . ErrGetInitialConfigParamsGenesisNotFound $ block0
             x -> do
                 let ctx = safeLink api (Proxy @GetBlock) (BlockId $ coerce block0)
-                let networkUnreachable = ErrGetInitialFeePolicyNetworkUnreachable
+                let networkUnreachable = ErrGetInitialConfigParamsNetworkUnreachable
                 left networkUnreachable <$> defaultHandler ctx x
 
         let params = mconcat $ mapMaybe getConfigParameters msgs
@@ -263,38 +258,17 @@ mkJormungandrLayer mgr baseUrl = JormungandrLayer
                     ConfigLinearFee x -> Just x
                     _ -> Nothing
 
-        case mpolicy of
-            [policy] ->
-                return policy
-            _ ->
-                throwE $ ErrGetInitialFeePolicyNoInitialPolicy params
-
-    , getInitialSlotDuration = \block0 -> do
-        J.Block _ msgs <- ExceptT $ run (cGetBlock (BlockId $ coerce block0)) >>= \case
-            Left (FailureResponse e) | responseStatusCode e == status400 ->
-                return . Left . ErrGetInitialSlotDurationGenesisNotFound $ block0
-            x -> do
-                let ctx = safeLink api (Proxy @GetBlock) (BlockId $ coerce block0)
-                let networkUnreachable = ErrGetInitialSlotDurationNetworkUnreachable
-                left networkUnreachable <$> defaultHandler ctx x
-
-        let params = mconcat $ mapMaybe getConfigParameters msgs
-              where
-                getConfigParameters = \case
-                    Initial xs -> Just xs
-                    _ -> Nothing
-
         let mduration = mapMaybe getSlotDuration params
               where
                 getSlotDuration = \case
                     SlotDuration x -> Just x
                     _ -> Nothing
 
-        case mduration of
-            [duration] ->
-                return $ SlotLength duration
+        case (mpolicy,mduration) of
+            ([policy],[duration]) ->
+                return (policy, SlotLength duration)
             _ ->
-                throwE $ ErrGetInitialSlotDurationNoInitialPolicy params
+                throwE $ ErrGetInitialConfigParamsNoInitialPolicy params
     }
   where
     run :: ClientM a -> IO (Either ServantError a)
@@ -335,14 +309,8 @@ data ErrGetDescendants
     | ErrGetDescendantsParentNotFound (Hash "BlockHeader")
     deriving (Show, Eq)
 
-data ErrGetInitialFeePolicy
-    = ErrGetInitialFeePolicyNetworkUnreachable ErrNetworkUnreachable
-    | ErrGetInitialFeePolicyGenesisNotFound (Hash "Genesis")
-    | ErrGetInitialFeePolicyNoInitialPolicy [ConfigParam]
-    deriving (Show, Eq)
-
-data ErrGetInitialSlotDuration
-    = ErrGetInitialSlotDurationNetworkUnreachable ErrNetworkUnreachable
-    | ErrGetInitialSlotDurationGenesisNotFound (Hash "Genesis")
-    | ErrGetInitialSlotDurationNoInitialPolicy [ConfigParam]
+data ErrGetInitialConfigParams
+    = ErrGetInitialConfigParamsNetworkUnreachable ErrNetworkUnreachable
+    | ErrGetInitialConfigParamsGenesisNotFound (Hash "Genesis")
+    | ErrGetInitialConfigParamsNoInitialPolicy [ConfigParam]
     deriving (Show, Eq)
diff --git a/lib/jormungandr/test/integration/Main.hs b/lib/jormungandr/test/integration/Main.hs
@@ -214,10 +214,8 @@ newNetworkLayer url block0H = do
     waitForConnection nl defaultRetryPolicy
     block0 <- unsafeRunExceptT $
         getBlock jormungandr (coerce block0H)
-    feePolicy <- unsafeRunExceptT $
-        getInitialFeePolicy jormungandr (coerce block0H)
-    slotLength <- unsafeRunExceptT $
-        getInitialSlotDuration jormungandr (coerce block0H)
+    (feePolicy, slotLength) <- unsafeRunExceptT $
+        getInitialConfigParams jormungandr (coerce block0H)
     return (nl, block0, feePolicy, slotLength)
 
 mkFeeEstimator :: FeePolicy -> TxDescription -> (Natural, Natural)