Convert unit to monadic property test

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

@@ -1,6 +1,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Cardano.Wallet.Api.ServerSpec (spec) where
 
@@ -9,9 +10,11 @@ import Prelude
 import Cardano.Slotting.Slot
     ( EpochNo (..) )
 import Cardano.Wallet.Api.Server
-    ( Listen (..), ListenError (..), withListeningSocket )
-import Cardano.Wallet.Api.Server
-    ( getNetworkInformation )
+    ( Listen (..)
+    , ListenError (..)
+    , getNetworkInformation
+    , withListeningSocket
+    )
 import Cardano.Wallet.Api.Types
     ( ApiNetworkInformation (..) )
 import Cardano.Wallet.Network
@@ -24,6 +27,8 @@ 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
@@ -40,6 +45,12 @@ 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 )
 
@@ -90,26 +101,49 @@ spec = describe "API Server" $ do
 
     describe "getNetworkInformation" $ do
         it "doesn't return 500 when the time interpreter horizon is ahead of\
-           \ the current time" $ do
-            st <- StartTime . ((-1000) `addUTCTime`) <$> getCurrentTime
+           \ 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 nl = dummyNetworkLayer ti
-            let tolerance = mkSyncTolerance 30
-            Right info <- runHandler $ getNetworkInformation tolerance nl
-            (networkTip info) `shouldBe` Nothing
-            nextEpoch info `shouldBe` Nothing
+            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 :: TimeInterpreter IO -> NetworkLayer IO () Block
-    dummyNetworkLayer ti = NetworkLayer
+    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
-                    (SlotNo 100)
-                    (Quantity 100)
+                    sl
+                    (Quantity $ fromIntegral $ unSlotNo sl)
                     (Hash "header hash")
                     (Hash "prevHeaderHash")
         , watchNodeTip = error "todo"
@@ -124,13 +158,12 @@ spec = describe "API Server" $ do
         let
             era1 = HF.initBound
             era2 = HF.Bound
-                    (RelativeTime 1000)
-                    (SlotNo 1000)
-                    (EpochNo 10)
+                    (RelativeTime 20)
+                    (SlotNo 20)
+                    (EpochNo 1)
 
-            era1Params = HF.defaultEraParams (SecurityParam 100) (mkSlotLength 1)
+            era1Params = HF.defaultEraParams (SecurityParam 2) (mkSlotLength 1)
             summary = HF.summaryWithExactly $ exactlyOne
                 (HF.EraSummary era1 (HF.EraEnd era2) era1Params)
             int = HF.mkInterpreter summary
         in mkTimeInterpreter startTime int
-