Merge #1623

1623: Mock metadata aggregation server r=KtorZ a=KtorZ

# Issue Number

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

#1597

# Overview

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

-  64052c5
  📍 **Basic skeleton for refreshing metadata.**
  Still requires proper log messages and error handling. But this already allows some level of testing.

- 7be9a83
  📍 **log events while refreshing metadata**
  
- 566d95d
  📍 **handle 404 in the metadata client directly**
  So that the calling code needs not to worry about the 'ClientError'. Any error becomes unexpected and all errors can be treated consistently.

- 398bb78
  📍 **merge 'refresh' and 'Client' so that the client is already caching results by itself.**
  This makes it slightly easier to use from a consumer perspective. Once one has a handle on a 'Client IO Api' it can makes requests without having to
worry about whether they get cached or not. Doing so, I also removed the 'ClientError' from the response. The client does handle error by itself and
log messages accordingly. A caller would likely not do anything more than relogging the error.
Plus, from the caller perspective, a metadata not being there and the request failing has pretty much the same end: no metadata.

- 98a499d
  📍 **write small unit / property tests to exercise the client.**
    Written as property so we get some fuzzy testing and test cases with and without metadata
  Fails nicely with each log messages obtained in the run:
  ```
  Assertion failed (after 1 test):
    PoolId {getPoolId = "\SOH\NUL\SOH\NUL\NUL\NUL\NUL\NUL\NUL\SOH\SOH\NUL\SOH\SOH\SOH\SOH\NUL\SOH\NUL\SOH\SOH\SOH\NUL\SOH\NUL\SOH\NUL\NUL\NUL\SOH\SOH\NUL"}
    MsgRefreshingMetadata (PoolId {getPoolId = "\SOH\NUL\SOH\NUL\NUL\NUL\NUL\NUL\NUL\SOH\SOH\NUL\SOH\SOH\SOH\SOH\NUL\SOH\NUL\SOH\SOH\SOH\NUL\SOH\NUL\SOH\NUL\NUL\NUL\SOH\SOH\NUL"}) (Just (StakePoolOffChainMetadata {ticker = StakePoolTicker {unStakePoolTicker = "VUHQ"}, name = "_-NfdG\21785\&0?-wjm'\\.G{0MtJ4E", description = "_-NfdG\21785\&0?-wjm'\\.G{0MtJ4E", homepage = "https://\tXuP9h>v\ETXXM\FSUHd\ACKp\SOH\FS\SOHg\DEL$.io"}),2020-05-04 23:31:26.917183969 UTC)
    MsgUsingCached (PoolId {getPoolId = "\SOH\NUL\SOH\NUL\NUL\NUL\NUL\NUL\NUL\SOH\SOH\NUL\SOH\SOH\SOH\SOH\NUL\SOH\NUL\SOH\SOH\SOH\NUL\SOH\NUL\SOH\NUL\NUL\NUL\SOH\SOH\NUL"}) 2020-05-04 23:31:26.917183969 UTC
  ```

- 51cf00a
  📍 **add an extra scenario illustrating a unhappy path**
    ```
  Cardano.Pool.Metadata
    Metadata - MockServer
      Mock Server works as intended
        +++ OK, passed 100 tests:
        51% Got Valid Metadata
        49% No Corresponding Metadata
      Cache metadata when called twice within the TTL
        +++ OK, passed 10 tests.
      Fetch them again when fetching outside of the TTL
        +++ OK, passed 10 tests.
      Returns 'Nothing' and a warning log message on failure
        +++ OK, passed 1 test.
  ```

- c76f29d
  📍 **move 'count' to 'Test.Util.Trace' with extra comments'**

<!-- 
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: KtorZ <matthias.benkort@gmail.com>
Co-authored-by: IOHK <devops+stack-project@iohk.io>

Author: 3 people

lib/core/cardano-wallet-core.cabal

@@ -216,7 +216,6 @@ test-suite unit
     , safe
     , scrypt
     , servant
-    , servant-client
     , servant-server
     , servant-swagger
     , stm

lib/core/src/Cardano/Pool/Metadata.hs

@@ -1,4 +1,8 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeOperators #-}
 
@@ -12,10 +16,17 @@
 --
 -- - https://github.com/input-output-hk/smash
 --
+-- This module is expected to be mostly used qualified as 'Metadata' to give
+-- context to the exposed functions and data-types.
 module Cardano.Pool.Metadata
     ( Api
+
+    -- * Client
     , Client(..)
-    , mkClient
+    , ClientConfig (..)
+    , ClientCallbacks (..)
+    , newClient
+    , MetadataRegistryLog (..)
 
     -- * Re-export
     , BaseUrl (..)
@@ -27,14 +38,30 @@ module Cardano.Pool.Metadata
 
 import Prelude
 
+import Cardano.BM.Data.Severity
+    ( Severity (..) )
+import Cardano.BM.Data.Tracer
+    ( HasPrivacyAnnotation (..), HasSeverityAnnotation (..) )
 import Cardano.Wallet.Api.Types
     ( ApiT (..) )
 import Cardano.Wallet.Primitive.Types
     ( PoolId, StakePoolOffChainMetadata (..) )
+import Control.Tracer
+    ( Tracer, traceWith )
 import Data.Proxy
     ( Proxy (..) )
+import Data.Text.Class
+    ( ToText (..) )
+import Data.Time.Clock
+    ( NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime )
+import Fmt
+    ( pretty )
+import GHC.Generics
+    ( Generic )
 import Network.HTTP.Client
     ( Manager, defaultManagerSettings, newManager )
+import Network.HTTP.Types
+    ( status404 )
 import Servant
     ( (:>), Capture, Get, JSON )
 import Servant.Client
@@ -44,9 +71,12 @@ import Servant.Client
     , Scheme (..)
     , client
     , mkClientEnv
+    , responseStatusCode
     , runClientM
     )
 
+import qualified Data.Text as T
+
 --
 -- Api
 --
@@ -65,23 +95,123 @@ type Api
 -- | A client for fetching metadata from an Aggregation server.
 --
 -- See also 'newClient' to construct a client.
-newtype Client api = Client
+newtype Client api m = Client
     { getStakePoolMetadata
         :: PoolId
-        -> IO (Either ClientError StakePoolOffChainMetadata)
+        -> m (Maybe StakePoolOffChainMetadata)
+    }
+
+-- | A configuration for managing metadata with the aggregation server.
+-- Callbacks and parameterized effects allows for easier testing while a real
+-- specialization would wire a database connector in here.
+data ClientConfig = ClientConfig
+    { manager
+        :: Manager
+        -- ^ An HTTP connection manager.
+
+    , baseUrl
+        :: BaseUrl
+        -- ^ Url for reaching out to the metadata aggregation server.
+
+    , cacheTTL
+        :: NominalDiffTime
+        -- ^ A constant for the maximum age of cached registry metadatabefore
+        -- it's considered to be stale.
     }
 
-mkClient
-    :: Manager
-    -> BaseUrl
-    -> Client Api
-mkClient mgr baseUrl = Client
-    { getStakePoolMetadata = \pid ->
-        fmap getApiT <$> run (getMetadata (ApiT pid))
+-- | Callbacks interfaces allowing the client to cache and manage cached
+-- entities. These would typically be hooked up with a database.
+data ClientCallbacks (m :: * -> *) = ClientCallbacks
+    { saveMetadata
+        :: PoolId -> (Maybe StakePoolOffChainMetadata, UTCTime) -> m ()
+        -- ^ A callback action for storing an off-chain metadata. The callback
+        -- may be called with 'Nothing' to store that no metadata were found for
+        -- a particular 'PoolId; this allows for not constantly re-fetching data
+        -- for pools that are known to have no metadata.
+
+    , getCachedMetadata
+        :: PoolId -> m (Maybe (Maybe StakePoolOffChainMetadata, UTCTime))
+        -- ^ Action for fetching the last modification time of a cached result.
+        -- 'Nothing' is expected when there's no cached result.
     }
+
+-- | Create a new HTTP 'Client' in IO with caching support.
+newClient
+    :: Tracer IO MetadataRegistryLog
+    -> ClientConfig
+    -> ClientCallbacks IO
+    -> Client Api IO
+newClient tr ClientConfig{manager,baseUrl,cacheTTL} callbacks =
+    Client { getStakePoolMetadata }
   where
     run :: ClientM a -> IO (Either ClientError a)
-    run query = runClientM query (mkClientEnv mgr baseUrl)
+    run query = runClientM query (mkClientEnv manager baseUrl)
 
-    getMetadata =
+    getFromServer =
         client (Proxy @Api)
+
+    ClientCallbacks{getCachedMetadata,saveMetadata} =
+        callbacks
+
+    getStakePoolMetadata
+        :: PoolId
+        -> IO (Maybe StakePoolOffChainMetadata)
+    getStakePoolMetadata pid = do
+        now <- getCurrentTime
+        getCachedMetadata pid >>= \case
+            Just (meta, time) | diffUTCTime now time < cacheTTL -> do
+                traceWith tr $ MsgUsingCached pid time
+                pure meta
+
+            _expiredOrNotCached ->
+                (handleRequest <$> run (getFromServer (ApiT pid))) >>= \case
+                    Right meta -> do
+                        traceWith tr $ MsgRefreshingMetadata pid (meta, now)
+                        saveMetadata pid (meta, now)
+                        pure meta
+                    Left e -> do
+                        traceWith tr $ MsgUnexpectedError e
+                        pure Nothing
+      where
+        handleRequest = \case
+            Right (ApiT meta) ->
+                Right (Just meta)
+            Left (FailureResponse _ res) | responseStatusCode res == status404 ->
+                Right Nothing
+            Left e ->
+                Left e
+
+-- | Capture log events for the Client.
+data MetadataRegistryLog
+    = MsgUsingCached PoolId UTCTime
+    | MsgRefreshingMetadata PoolId (Maybe StakePoolOffChainMetadata, UTCTime)
+    | MsgUnexpectedError ClientError
+    deriving (Generic, Show, Eq)
+
+instance HasPrivacyAnnotation MetadataRegistryLog
+instance HasSeverityAnnotation MetadataRegistryLog where
+    getSeverityAnnotation = \case
+        MsgUsingCached{} -> Debug
+        MsgRefreshingMetadata{} -> Debug
+        MsgUnexpectedError{} -> Warning
+
+instance ToText MetadataRegistryLog where
+    toText = \case
+        MsgUsingCached pid time -> T.unwords
+            [ "Using cached result for"
+            , pretty pid
+            , "last modified at"
+            , T.pack (show time)
+            ]
+        MsgRefreshingMetadata pid (meta, time) -> T.unwords
+            [ "Setting metadata for "
+            , pretty pid
+            , "="
+            , maybe "ø" (T.pack . show) meta
+            , ", last modified at"
+            , T.pack (show time)
+            ]
+        MsgUnexpectedError e -> T.unwords
+            [ "Unexpected error from the aggregation server:"
+            , T.pack (show e)
+            ]