Merge #2031

2031: Time LSQ requests (and trace the times) r=Anviking a=Anviking

# Issue Number

<!-- Put here a reference to the issue this PR relates to and which requirements it tackles -->


# Overview

- [x] Measure and trace LSQ queries such that we can correlate the slowness with that of #2005 and #2006

# Comments

E.g.
```bash
[cardano-wallet.network:Info:130] [2020-08-12 11:03:17.03 UTC] Query getAccountBalance took 51.175731s
[cardano-wallet.network:Info:145] [2020-08-12 11:03:22.08 UTC] Query getAccountBalance took 51.244343s
```

<!-- 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/shelley/src/Cardano/Wallet/Shelley/Network.hs

@@ -109,7 +109,7 @@ import Control.Monad.Class.MonadThrow
 import Control.Monad.Class.MonadTimer
     ( MonadTimer, threadDelay )
 import Control.Monad.IO.Class
-    ( liftIO )
+    ( MonadIO, liftIO )
 import Control.Monad.Trans.Except
     ( ExceptT (..), throwE, withExceptT )
 import Control.Retry
@@ -138,6 +138,8 @@ import Data.Text
     ( Text )
 import Data.Text.Class
     ( ToText (..) )
+import Data.Time.Clock
+    ( NominalDiffTime, diffUTCTime, getCurrentTime )
 import Data.Void
     ( Void )
 import Data.Word
@@ -401,7 +403,9 @@ withNetworkLayer tr np addrInfo versionData action = do
         let cred = toStakeCredential acct
         let q = QueryIfCurrentShelley (Shelley.GetFilteredDelegationsAndRewardAccounts (Set.singleton cred))
         let cmd = CmdQueryLocalState (getTipPoint tip) q
-        liftIO (queryRewardQ `send` cmd) >>= \case
+        res <- liftIO . timeQryAndLog "getAccountBalance" tr $
+            queryRewardQ `send` cmd
+        case res of
             Right (Right (deleg, rewardAccounts)) -> do
                 liftIO $ traceWith tr $
                     MsgAccountDelegationAndRewards acct deleg rewardAccounts
@@ -641,7 +645,7 @@ type CardanoInterpreter sc = Interpreter (CardanoEras sc)
 --  * Tracking the latest protocol parameters state.
 --  * Querying the history interpreter as necessary.
 mkTipSyncClient
-    :: forall sc m. (HasCallStack, MonadThrow m, MonadST m, MonadTimer m, TPraosCrypto sc)
+    :: forall sc m. (HasCallStack, MonadIO m, MonadThrow m, MonadST m, MonadTimer m, TPraosCrypto sc)
     => Tracer m (NetworkLayerLog sc)
         -- ^ Base trace for underlying protocols
     -> W.NetworkParameters
@@ -672,16 +676,16 @@ mkTipSyncClient tr np localTxSubmissionQ onTipUpdate onPParamsUpdate onInterpret
             :: Point (CardanoBlock sc)
             -> m ()
         queryLocalState pt = do
-            mb <- localStateQueryQ `send`
+            mb <- timeQryAndLog "GetEraStart" tr $ localStateQueryQ `send`
                 CmdQueryLocalState pt (QueryAnytimeShelley GetEraStart)
 
-            pp <- localStateQueryQ `send`
+            pp <- timeQryAndLog "GetCurrentPParams" tr $ localStateQueryQ `send`
                 CmdQueryLocalState pt (QueryIfCurrentShelley Shelley.GetCurrentPParams)
 
             sequence (handleParamsUpdate fromShelleyPParams <$> mb <*> pp)
                 >>= handleAcquireFailure
 
-            st <- localStateQueryQ `send`
+            st <- timeQryAndLog "GetUpdateInterfaceState" tr $ localStateQueryQ `send`
                 CmdQueryLocalState pt (QueryIfCurrentByron Byron.GetUpdateInterfaceState)
 
             sequence (handleParamsUpdate protocolParametersFromUpdateState <$> mb <*> st)
@@ -777,6 +781,31 @@ debounce action = do
         unless (Just cur == prev) $ action cur
         atomically $ putTMVar mvar (Just cur)
 
+-- | Convenience function to measure the time of a LSQ query,
+-- and trace the result.
+--
+-- Such that we can get logs like:
+-- >>> Query getAccountBalance took 51.664463s
+--
+-- Failures that stop the >>= continuation will cause the corresponding
+-- measuremens /not/ to be logged.
+timeQryAndLog
+    :: MonadIO m
+    => String
+    -- ^ Label to identify the query
+    -> Tracer m (NetworkLayerLog sc)
+    -- ^ Tracer to which the measurement will be logged
+    -> m a
+    -- ^ The action that submits the query.
+    -> m a
+timeQryAndLog label tr act = do
+    t0 <- liftIO getCurrentTime
+    a <- act
+    t1 <- liftIO getCurrentTime
+    let diff = t1 `diffUTCTime` t0
+    traceWith tr $ MsgQueryTime label diff
+    return a
+
 -- | A protocol client that will never leave the initial state.
 doNothingProtocol
     :: MonadTimer m => RunMiniProtocol 'InitiatorMode ByteString m a Void
@@ -925,6 +954,7 @@ data NetworkLayerLog sc where
     MsgChainSyncCmd :: (ChainSyncLog Text Text) -> NetworkLayerLog sc
     MsgInterpreter :: CardanoInterpreter sc -> NetworkLayerLog sc
     MsgInterpreterPastHorizon :: Text -> PastHorizonException -> NetworkLayerLog sc
+    MsgQueryTime :: String -> NominalDiffTime -> NetworkLayerLog sc
 
 data QueryClientName
     = TipSyncClient
@@ -1013,6 +1043,8 @@ instance TPraosCrypto sc => ToText (NetworkLayerLog sc) where
         MsgWatcherUpdate tip b ->
             "Update watcher with tip: " <> pretty tip <>
             ". Callback " <> toText b <> "."
+        MsgQueryTime qry diffTime ->
+            "Query " <> T.pack qry <> " took " <> T.pack (show diffTime)
         MsgChainSyncCmd a -> toText a
         MsgInterpreter interpreter ->
             "Updated the history interpreter: " <> T.pack (show interpreter)
@@ -1051,4 +1083,5 @@ instance HasSeverityAnnotation (NetworkLayerLog b) where
         MsgWatcherUpdate{}                 -> Debug
         MsgChainSyncCmd cmd                -> getSeverityAnnotation cmd
         MsgInterpreter{}                   -> Debug
+        MsgQueryTime{}                     -> Info
         MsgInterpreterPastHorizon{}        -> Error