Merge #1977

1977: Test getNetworkInformation handling of PastHorizonException r=Anviking a=Anviking

# Issue Number

#1869 /  #1960


# Overview

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

- [x] Added a mock interpreter & network layer to produce a single unit test
- [x] I think we can make this a monadic property test easily


# 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: Johannes Lund <[email protected]>

lib/byron/src/Cardano/Wallet/Byron/Api/Server.hs

@@ -282,12 +282,12 @@ server byron icarus ntp =
 
     network :: Server Network
     network =
-        getNetworkInformation genesis nl
+        getNetworkInformation syncTolerance nl
         :<|> getNetworkParameters genesis nl
         :<|> getNetworkClock ntp
       where
         nl = icarus ^. networkLayer @t
-        genesis = icarus ^. genesisData
+        genesis@(_,_,syncTolerance) = icarus ^. genesisData
 
     proxy :: Server Proxy_
     proxy = postExternalTransaction icarus

lib/core/cardano-wallet-core.cabal

@@ -192,6 +192,7 @@ test-suite unit
     , cardano-addresses
     , cardano-crypto
     , cardano-wallet-core
+    , ouroboros-consensus
     , cardano-wallet-launcher
     , cardano-wallet-test-utils
     , cardano-slotting

lib/core/src/Cardano/Wallet/Api/Server.hs

@@ -1544,10 +1544,10 @@ getCurrentEpoch ctx = do
 
 getNetworkInformation
     :: forall t. (HasCallStack)
-    => (Block, NetworkParameters, SyncTolerance)
+    => SyncTolerance
     -> NetworkLayer IO t Block
     -> Handler ApiNetworkInformation
-getNetworkInformation (_block0, _, st) nl = do
+getNetworkInformation st nl = do
     now <- liftIO getCurrentTime
     nodeTip <-  liftHandler (NW.currentNodeTip nl)
     apiNodeTip <- liftIO $ mkApiBlockReference ti nodeTip

lib/core/test/unit/Cardano/Wallet/Api/ServerSpec.hs

@@ -1,18 +1,63 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Cardano.Wallet.Api.ServerSpec (spec) where
 
 import Prelude
 
+import Cardano.Slotting.Slot
+    ( EpochNo (..) )
 import Cardano.Wallet.Api.Server
-    ( Listen (..), ListenError (..), withListeningSocket )
+    ( Listen (..)
+    , ListenError (..)
+    , getNetworkInformation
+    , withListeningSocket
+    )
+import Cardano.Wallet.Api.Types
+    ( ApiNetworkInformation (..) )
+import Cardano.Wallet.Network
+    ( NetworkLayer (..) )
+import Cardano.Wallet.Primitive.Slotting
+    ( TimeInterpreter, mkTimeInterpreter )
+import Cardano.Wallet.Primitive.SyncProgress
+    ( mkSyncTolerance )
+import Cardano.Wallet.Primitive.Types
+    ( Block (..), BlockHeader (..), Hash (..), SlotNo (..), StartTime (..) )
+import Control.Exception
+    ( throwIO )
+import Data.Maybe
+    ( isJust, isNothing )
+import Data.Quantity
+    ( Quantity (..) )
+import Data.Time.Clock
+    ( addUTCTime, getCurrentTime )
 import Network.Socket
     ( SockAddr (..), getSocketName, tupleToHostAddress )
+import Ouroboros.Consensus.BlockchainTime.WallClock.Types
+    ( RelativeTime (..), mkSlotLength )
+import Ouroboros.Consensus.Config.SecurityParam
+    ( SecurityParam (..) )
+import Ouroboros.Consensus.Util.Counting
+    ( exactlyOne )
+import Servant.Server.Internal.Handler
+    ( runHandler )
 import Test.Hspec
     ( Spec, describe, it, shouldBe, shouldReturn )
+import Test.QuickCheck.Modifiers
+    ( NonNegative (..) )
+import Test.QuickCheck.Monadic
+    ( PropertyM, assert, monadicIO, monitor, run )
+import Test.QuickCheck.Property
+    ( counterexample, property )
 import Test.Utils.Windows
     ( skipOnWindows )
 
+import qualified Ouroboros.Consensus.HardFork.History.EraParams as HF
+import qualified Ouroboros.Consensus.HardFork.History.Qry as HF
+import qualified Ouroboros.Consensus.HardFork.History.Summary as HF
+
 spec :: Spec
 spec = describe "API Server" $ do
     it "listens on the local interface" $ do
@@ -53,3 +98,72 @@ spec = describe "API Server" $ do
                 withListeningSocket "127.0.0.1" (ListenOnPort port) $ \res ->
                     res `shouldBe` Left (ListenErrorAddressAlreadyInUse (Just port))
             Left e -> fail (show e)
+
+    describe "getNetworkInformation" $ do
+        it "doesn't return 500 when the time interpreter horizon is behind\
+           \ the current time" $ property $ \(gap' ::(NonNegative Int)) ->
+            monadicIO $ do
+            let gap = fromRational $ toRational $ getNonNegative gap'
+            st <- run $ StartTime . ((negate gap) `addUTCTime`)
+                    <$> getCurrentTime
+            let ti = either throwIO pure . forkInterpreter st
+            let nodeTip' = SlotNo 0
+            let nl = dummyNetworkLayer nodeTip' ti
+            let tolerance = mkSyncTolerance 5
+            Right info <- run $ runHandler $ getNetworkInformation tolerance nl
+
+            -- 0              20
+            -- *               |        *
+            -- Node tip     Horizon   Network Tip
+            -- <------------------------>
+            --           gap
+            --
+            -- 20 = epoch length = 10*k
+            if gap >= 20
+            then do
+                assertWith "networkTip is Nothing" $ isNothing $ networkTip info
+                assertWith "nextEpoch is Nothing" $ isNothing $ nextEpoch info
+            else do
+                assertWith "networkTip is Just " $ isJust $ networkTip info
+                assertWith "nextEpoch is Just" $ isJust $ nextEpoch info
+
+  where
+    assertWith :: String -> Bool -> PropertyM IO ()
+    assertWith lbl condition = do
+        let flag = if condition then "✓" else "✗"
+        monitor (counterexample $ lbl <> " " <> flag)
+        assert condition
+
+    dummyNetworkLayer :: SlotNo -> TimeInterpreter IO -> NetworkLayer IO () Block
+    dummyNetworkLayer sl ti = NetworkLayer
+        { nextBlocks = error "nextBlocks: not implemented"
+        , initCursor = error "initCursor: not implemented"
+        , destroyCursor = error "destroyCursor: not implemented"
+        , cursorSlotNo = error "cursorSlotNo: not implemented"
+        , currentNodeTip = return $
+                BlockHeader
+                    sl
+                    (Quantity $ fromIntegral $ unSlotNo sl)
+                    (Hash "header hash")
+                    (Hash "prevHeaderHash")
+        , watchNodeTip = error "todo"
+        , getProtocolParameters = error "getProtocolParameters: not implemented"
+        , postTx = error "postTx: not implemented"
+        , stakeDistribution = error "stakeDistribution: not implemented"
+        , getAccountBalance = error "getAccountBalance: not implemented"
+        , timeInterpreter = ti
+        }
+
+    forkInterpreter startTime =
+        let
+            start = HF.initBound
+            end = HF.Bound
+                    (RelativeTime 20)
+                    (SlotNo 20)
+                    (EpochNo 1)
+
+            era1Params = HF.defaultEraParams (SecurityParam 2) (mkSlotLength 1)
+            summary = HF.summaryWithExactly $ exactlyOne $
+                HF.EraSummary start (HF.EraEnd end) era1Params
+            int = HF.mkInterpreter summary
+        in mkTimeInterpreter startTime int

lib/jormungandr/src/Cardano/Wallet/Jormungandr/Api/Server.hs

@@ -272,12 +272,12 @@ server byron icarus jormungandr spl ntp =
 
     network :: Server Network
     network =
-        getNetworkInformation genesis nl
+        getNetworkInformation syncTolerance nl
         :<|> getNetworkParameters genesis nl
         :<|> getNetworkClock ntp
       where
         nl = jormungandr ^. networkLayer @t
-        genesis = jormungandr ^. genesisData
+        genesis@(_,_,syncTolerance) = jormungandr ^. genesisData
 
     proxy :: Server Proxy_
     proxy = postExternalTransaction jormungandr

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

@@ -310,12 +310,12 @@ server byron icarus shelley spl ntp =
 
     network :: Server Network
     network =
-        getNetworkInformation genesis nl
+        getNetworkInformation syncTolerance nl
         :<|> getNetworkParameters genesis nl
         :<|> getNetworkClock ntp
       where
         nl = icarus ^. networkLayer @t
-        genesis = icarus ^. genesisData
+        genesis@(_,_,syncTolerance) = icarus ^. genesisData
 
     proxy :: Server Proxy_
     proxy = postExternalTransaction icarus