Merge pull request #1592 from input-output-hk/KtorZ/ntp-fix

NTP fix: block and force check only when asked

Author: KtorZ

lib/cli/src/Cardano/CLI.hs

@@ -247,6 +247,7 @@ import Options.Applicative
     , command
     , customExecParser
     , eitherReader
+    , flag
     , flag'
     , footer
     , header
@@ -1422,8 +1423,9 @@ cmdNetworkParameters mkClient =
         runClient wPort Aeson.encodePretty $ networkParameters mkClient epoch
 
 -- | Arguments for 'network clock' command
-newtype NetworkClockArgs = NetworkClockArgs
+data NetworkClockArgs = NetworkClockArgs
     { _port :: Port "Wallet"
+    , _forceNtpCheck :: Bool
     }
 
 cmdNetworkClock
@@ -1433,9 +1435,11 @@ cmdNetworkClock mkClient =
     command "clock" $ info (helper <*> cmd) $ mempty
         <> progDesc "View NTP offset."
   where
-    cmd = fmap exec $ NetworkClockArgs <$> portOption
-    exec (NetworkClockArgs wPort) = do
-        runClient wPort Aeson.encodePretty $ networkClock mkClient
+    cmd = fmap exec $ NetworkClockArgs
+        <$> portOption
+        <*> forceNtpCheckOption
+    exec (NetworkClockArgs wPort forceNtpCheck) = do
+        runClient wPort Aeson.encodePretty $ networkClock mkClient forceNtpCheck
 
 {-------------------------------------------------------------------------------
                             Commands - 'launch'
@@ -1613,6 +1617,13 @@ sortOrderOption = optionT $ mempty
     <> help "specifies a sort order, either 'ascending' or 'descending'."
     <> showDefaultWith showT
 
+-- | [--force-ntp-check]
+forceNtpCheckOption :: Parser Bool
+forceNtpCheckOption = flag False True $ mempty
+    <> long "force-ntp-check"
+    <> help "When set, will block and force an NTP check with the server. \
+            \Otherwise, uses an available cached result."
+
 loggingSeverities :: [(String, Severity)]
 loggingSeverities =
     [ ("debug", Debug)

lib/cli/test/unit/Cardano/CLISpec.hs

@@ -518,13 +518,16 @@ spec = do
             ]
 
         ["network", "clock", "--help"] `shouldShowUsage`
-            [ "Usage:  network clock [--port INT]"
+            [ "Usage:  network clock [--port INT] [--force-ntp-check]"
             , "  View NTP offset."
             , ""
             , "Available options:"
             , "  -h,--help                Show this help text"
             , "  --port INT               port used for serving the wallet"
             , "                           API. (default: 8090)"
+            , "  --force-ntp-check        When set, will block and force an NTP"
+            , "                           check with the server. Otherwise, uses"
+            , "                           an available cached result."
             ]
 
         ["key", "root", "--help"] `shouldShowUsage`

lib/core-integration/src/Test/Integration/Scenario/API/Network.hs

@@ -161,6 +161,17 @@ spec = do
             expectResponseCode @IO HTTP.status200 r
             expectField (#ntpStatus . #status)
                 (`shouldBe` NtpSyncingStatusAvailable) r
+
+    it "NETWORK_CLOCK - Can query network clock and force NTP check" $ \ctx -> do
+        sandboxed <- inNixBuild
+        when sandboxed $
+            pendingWith "Internet NTP servers unavailable in build sandbox"
+        eventually "ntp status = (un)available" $ do
+            r <- request @ApiNetworkClock ctx
+                (Link.getNetworkClock' True) Default Empty
+            expectResponseCode @IO HTTP.status200 r
+            expectField (#ntpStatus . #status)
+                (`shouldBe` NtpSyncingStatusAvailable) r
    where
        verifyEpochNumWrong
             :: Context t

lib/core/cardano-wallet-core.cabal

@@ -85,6 +85,7 @@ library
     , servant-server
     , split
     , streaming-commons
+    , stm
     , template-haskell
     , text
     , text-class

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

@@ -155,7 +155,15 @@ import Data.Generics.Product.Typed
 import GHC.Generics
     ( Generic )
 import Servant.API
-    ( (:<|>), (:>), Capture, JSON, OctetStream, QueryParam, ReqBody )
+    ( (:<|>)
+    , (:>)
+    , Capture
+    , JSON
+    , OctetStream
+    , QueryFlag
+    , QueryParam
+    , ReqBody
+    )
 import Servant.API.Verbs
     ( DeleteAccepted
     , DeleteNoContent
@@ -533,6 +541,7 @@ type GetNetworkParameters = "network"
 
 type GetNetworkClock = "network"
     :> "clock"
+    :> QueryFlag "forceNtpCheck"
     :> Get '[JSON] ApiNetworkClock
 
 {-------------------------------------------------------------------------------

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

@@ -195,7 +195,8 @@ data NetworkClient = NetworkClient
         :: ApiEpochNumber
         -> ClientM ApiNetworkParameters
     , networkClock
-        :: ClientM ApiNetworkClock
+        :: Bool -- When 'True', block and force NTP check
+        -> ClientM ApiNetworkClock
     }
 
 -- | Produces a 'WalletClient' working against the /wallets API.

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

@@ -75,6 +75,7 @@ module Cardano.Wallet.Api.Link
     , getNetworkInfo
     , getNetworkParams
     , getNetworkClock
+    , getNetworkClock'
 
       -- * Proxy
     , postExternalTransaction
@@ -119,6 +120,7 @@ import Servant.API
     , Header'
     , IsElem
     , NoContentVerb
+    , QueryFlag
     , QueryParam
     , ReflectMethod (..)
     , ReqBody
@@ -454,7 +456,14 @@ getNetworkParams e =
 getNetworkClock
     :: (Method, Text)
 getNetworkClock =
-    endpoint @Api.GetNetworkClock id
+    endpoint @Api.GetNetworkClock (False &)
+
+getNetworkClock'
+    :: Bool -- ^ When 'True', block and force NTP check
+    -> (Method, Text)
+getNetworkClock' forceNtpCheck =
+    endpoint @Api.GetNetworkClock (forceNtpCheck &)
+
 
 --
 -- Proxy
@@ -551,5 +560,8 @@ instance HasVerb sub => HasVerb (ReqBody a b :> sub) where
 instance HasVerb sub => HasVerb (QueryParam a b :> sub) where
     method _ = method (Proxy @sub)
 
+instance HasVerb sub => HasVerb (QueryFlag sym :> sub) where
+    method _ = method (Proxy @sub)
+
 instance HasVerb sub => HasVerb (Header' opts name ty :> sub) where
     method _ = method (Proxy @sub)

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

@@ -1716,8 +1716,8 @@ data ErrNoSuchEpoch = ErrNoSuchEpoch
     , errCurrentEpoch :: W.EpochNo
     } deriving (Eq, Show)
 
-getNetworkClock :: NtpClient -> Handler ApiNetworkClock
-getNetworkClock = liftIO . getNtpStatus
+getNetworkClock :: NtpClient -> Bool -> Handler ApiNetworkClock
+getNetworkClock client = liftIO . getNtpStatus client
 
 {-------------------------------------------------------------------------------
                                    Proxy

lib/core/src/Network/Ntp.hs

@@ -26,6 +26,8 @@ import Cardano.BM.Data.Tracer
     ( HasPrivacyAnnotation (..), HasSeverityAnnotation (..) )
 import Cardano.Wallet.Api.Types
     ( ApiNetworkClock (..), ApiNtpStatus (..), NtpSyncingStatus (..) )
+import Control.Concurrent.STM
+    ( atomically, check )
 import Control.Tracer
     ( Tracer )
 import Data.Quantity
@@ -61,7 +63,7 @@ ntpSettings = NtpSettings
     { ntpServers = [ "0.de.pool.ntp.org", "0.europe.pool.ntp.org"
                    , "0.pool.ntp.org", "1.pool.ntp.org"
                    , "2.pool.ntp.org", "3.pool.ntp.org" ]
-    , ntpRequiredNumberOfResults = 2
+    , ntpRequiredNumberOfResults = 3
     , ntpResponseTimeout = 1_000_000
     , ntpPollDelay = 300_000_000
     }
@@ -121,8 +123,24 @@ instance HasSeverityAnnotation NtpTrace where
         NtpTracePacketReceived _ _ -> Debug
         NtpTraceWaitingForRepliesTimeout _ -> Notice
 
-getNtpStatus :: NtpClient -> IO ApiNetworkClock
-getNtpStatus = fmap (ApiNetworkClock . toStatus) . ntpQueryBlocking
+getNtpStatus
+    :: NtpClient
+    -> Bool
+        -- ^ When 'True', will block and force a NTP check instead of using cached results
+    -> IO ApiNetworkClock
+getNtpStatus client forceCheck = (ApiNetworkClock . toStatus) <$>
+    if forceCheck
+    -- Forces an NTP check / query on the central servers, use with care
+    then do
+        ntpQueryBlocking client
+
+    else atomically $ do
+      -- Reads a cached NTP status from an STM.TVar so we don't get
+      -- blacklisted by the central NTP "authorities" for sending too many NTP
+      -- requests.
+      s <- ntpGetStatus client
+      check (s /= NtpSyncPending)
+      pure s
   where
     toStatus = \case
         NtpSyncPending ->

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

@@ -221,6 +221,7 @@ import Servant
     , Header'
     , JSON
     , PostNoContent
+    , QueryFlag
     , QueryParam
     , ReqBody
     , StdMethod (..)
@@ -1810,6 +1811,9 @@ instance HasPath sub => HasPath (ReqBody a b :> sub) where
 instance HasPath sub => HasPath (QueryParam a b :> sub) where
     getPath _ = getPath (Proxy @sub)
 
+instance HasPath sub => HasPath (QueryFlag sym :> sub) where
+    getPath _ = getPath (Proxy @sub)
+
 instance HasPath sub => HasPath (Header' opts name ty :> sub) where
     getPath _ = getPath (Proxy @sub)