[CAD-2724] CLI option to switch to existing SMASH server filtering.

smash-servant-types/smash-servant-types.cabal

@@ -46,6 +46,7 @@ library
     , cardano-api
     , base16-bytestring
     , persistent
+    , network-uri
     , servant
     , servant-server
     , servant-swagger

smash-servant-types/src/Cardano/SMASH/API.hs

@@ -10,6 +10,7 @@
 
 module Cardano.SMASH.API
     ( API
+    , DelistedPoolsAPI
     , fullAPI
     , smashApi
     ) where
@@ -23,11 +24,11 @@ import           Data.Aeson                    (FromJSON, ToJSON (..),
 import           Data.Swagger                  (Swagger (..))
 
 import           Network.Wai                   (Request, lazyRequestBody)
-import           Servant                       ((:<|>) (..), (:>), BasicAuth,
-                                                Capture, Get, HasServer (..),
-                                                Header, Headers, JSON,
-                                                OctetStream, Patch, Post,
-                                                QueryParam, ReqBody)
+import           Servant                       (BasicAuth, Capture, Get,
+                                                HasServer (..), Header, Headers,
+                                                JSON, OctetStream, Patch, Post,
+                                                QueryParam, ReqBody,
+                                                (:<|>) (..), (:>))
 import           Servant.Server                (err400)
 import           Servant.Server.Internal       (DelayedIO, addBodyCheck,
                                                 delayedFailFatal, errBody,
@@ -37,11 +38,13 @@ import           Servant.Swagger               (HasSwagger (..))
 
 import           Cardano.SMASH.DBSync.Db.Error (DBFail (..))
 import           Cardano.SMASH.Types           (ApiResult, HealthStatus,
-                                                PoolFetchError, PoolId (..),
-                                                PoolId, PoolIdBlockNumber (..),
+                                                PolicyResult, PoolFetchError,
+                                                PoolId (..),
+                                                PoolIdBlockNumber (..),
                                                 PoolMetadataHash,
-                                                PoolMetadataRaw, TickerName,
-                                                TimeStringFormat, User)
+                                                PoolMetadataRaw, SmashURL,
+                                                TickerName, TimeStringFormat,
+                                                UniqueTicker, User)
 
 
 -- Showing errors as JSON. To be reused when we need more general error handling.
@@ -80,11 +83,14 @@ type ApiRes verb a = verb '[JSON] (ApiResult DBFail a)
 -- The basic auth.
 type BasicAuthURL = BasicAuth "smash" User
 
+-- GET api/v1/metadata/{hash}
+type OfflineMetadataAPI = "api" :> APIVersion :> "metadata" :> Capture "id" PoolId :> Capture "hash" PoolMetadataHash :> Get '[JSON] (Headers '[Header "Cache-Control" Text] (ApiResult DBFail PoolMetadataRaw))
+
 -- GET api/v1/status
 type HealthStatusAPI = "api" :> APIVersion :> "status" :> ApiRes Get HealthStatus
 
--- GET api/v1/metadata/{hash}
-type OfflineMetadataAPI = "api" :> APIVersion :> "metadata" :> Capture "id" PoolId :> Capture "hash" PoolMetadataHash :> Get '[JSON] (Headers '[Header "Cache-Control" Text] (ApiResult DBFail PoolMetadataRaw))
+-- GET api/v1/tickers
+type ReservedTickersAPI = "api" :> APIVersion :> "tickers" :> ApiRes Get [UniqueTicker]
 
 -- GET api/v1/delisted
 type DelistedPoolsAPI = "api" :> APIVersion :> "delisted" :> ApiRes Get [PoolId]
@@ -97,10 +103,20 @@ type FetchPoolErrorAPI = "api" :> APIVersion :> "errors" :> Capture "poolId" Poo
 type DelistPoolAPI = "api" :> APIVersion :> "delist" :> ReqBody '[JSON] PoolId :> ApiRes Patch PoolId
 
 type EnlistPoolAPI = "api" :> APIVersion :> "enlist" :> ReqBody '[JSON] PoolId :> ApiRes Patch PoolId
+
+type AddTickerAPI = "api" :> APIVersion :> "tickers" :> Capture "name" TickerName :> ReqBody '[JSON] PoolMetadataHash :> ApiRes Post TickerName
+
+-- Enabling the SMASH server to fetch the policies from remote SMASH server. Policies like delisting or unique ticker names.
+type FetchPoliciesAPI = "api" :> APIVersion :> "policies" :> ReqBody '[JSON] SmashURL :> ApiRes Post PolicyResult
 #else
 type DelistPoolAPI = BasicAuthURL :> "api" :> APIVersion :> "delist" :> ReqBody '[JSON] PoolId :> ApiRes Patch PoolId
 
 type EnlistPoolAPI = BasicAuthURL :> "api" :> APIVersion :> "enlist" :> ReqBody '[JSON] PoolId :> ApiRes Patch PoolId
+
+type AddTickerAPI = "api" :> APIVersion :> "tickers" :> Capture "name" TickerName :> ReqBody '[JSON] PoolMetadataHash :> ApiRes Post TickerName
+
+-- Enabling the SMASH server to fetch the policies from remote SMASH server. Policies like delisting or unique ticker names.
+type FetchPoliciesAPI = BasicAuthURL :> "api" :> APIVersion :> "policies" :> ReqBody '[JSON] SmashURL :> ApiRes Post PolicyResult
 #endif
 
 type RetiredPoolsAPI = "api" :> APIVersion :> "retired" :> ApiRes Get [PoolId]
@@ -110,20 +126,21 @@ type CheckPoolAPI = "api" :> APIVersion :> "exists" :> Capture "poolId" PoolId :
 -- The full API.
 type SmashAPI =  OfflineMetadataAPI
             :<|> HealthStatusAPI
+            :<|> ReservedTickersAPI
             :<|> DelistedPoolsAPI
             :<|> DelistPoolAPI
             :<|> EnlistPoolAPI
             :<|> FetchPoolErrorAPI
             :<|> RetiredPoolsAPI
             :<|> CheckPoolAPI
+            :<|> AddTickerAPI
+            :<|> FetchPoliciesAPI
 #ifdef TESTING_MODE
             :<|> RetirePoolAPI
             :<|> AddPoolAPI
-            :<|> AddTickerAPI
 
 type RetirePoolAPI = "api" :> APIVersion :> "retired" :> ReqBody '[JSON] PoolIdBlockNumber :> ApiRes Patch PoolId
 type AddPoolAPI = "api" :> APIVersion :> "metadata" :> Capture "id" PoolId :> Capture "hash" PoolMetadataHash :> ReqBody '[OctetStream] PoolMetadataRaw :> ApiRes Post PoolId
-type AddTickerAPI = "api" :> APIVersion :> "tickers" :> Capture "name" TickerName :> ReqBody '[JSON] PoolMetadataHash :> ApiRes Post TickerName
 
 #endif
 

smash-servant-types/src/Cardano/SMASH/Types.hs

@@ -18,6 +18,8 @@ module Cardano.SMASH.Types
     , bytestringToPoolMetaHash
     , PoolMetadataRaw (..)
     , TickerName (..)
+    , UniqueTicker (..)
+    , PolicyResult (..)
     -- * Wrapper
     , PoolName (..)
     , PoolDescription (..)
@@ -33,6 +35,7 @@ module Cardano.SMASH.Types
     -- * API
     , ApiResult (..)
     -- * HTTP
+    , SmashURL (..)
     , FetchError (..)
     , PoolFetchError (..)
     , TimeStringFormat (..)
@@ -60,6 +63,7 @@ import           Data.Swagger                  (NamedSchema (..),
                                                 ToSchema (..))
 import           Data.Text.Encoding            (encodeUtf8Builder)
 
+import           Network.URI                   (URI, parseURI)
 import           Servant                       (FromHttpApiData (..),
                                                 MimeUnrender (..), OctetStream)
 
@@ -69,6 +73,30 @@ import           Cardano.SMASH.DBSync.Db.Types
 import qualified Data.ByteString.Lazy          as BL
 import qualified Data.Text.Encoding            as E
 
+-- | The Smash @URI@ containing remote filtering data.
+newtype SmashURL = SmashURL { getSmashURL :: URI }
+    deriving (Eq, Show, Generic)
+
+instance ToJSON SmashURL where
+    toJSON (SmashURL uri) =
+        object
+            [ "smashURL" .= (show uri :: Text)
+            ]
+
+instance FromJSON SmashURL where
+    parseJSON = withObject "SmashURL" $ \o -> do
+        uri <- o .: "smashURL"
+
+        let parsedURI = parseURI uri
+
+        case parsedURI of
+            Nothing -> fail "Not a valid URI for SMASH server."
+            Just uri' -> return $ SmashURL uri'
+
+instance ToSchema SmashURL where
+  declareNamedSchema _ =
+    return $ NamedSchema (Just "SmashURL") $ mempty
+
 -- | The basic @Configuration@.
 data Configuration = Configuration
     { cPortNumber :: !Int
@@ -89,6 +117,43 @@ examplePoolOfflineMetadata =
         (PoolTicker "testp")
         (PoolHomepage "https://iohk.io")
 
+data PolicyResult = PolicyResult
+    { prSmashURL :: !SmashURL
+    , prHealthStatus :: !HealthStatus
+    , prDelistedPools :: ![PoolId]
+    , prUniqueTickers :: ![UniqueTicker]
+    } deriving (Eq, Show, Generic)
+
+instance ToJSON PolicyResult where
+    toJSON (PolicyResult smashURL healthStatus delistedPools uniqueTickers) =
+        object
+            [ "smashURL" .= toJSON smashURL
+            , "healthStatus" .= toJSON healthStatus
+            , "delistedPools" .= toJSON delistedPools
+            , "uniqueTickers" .= toJSON uniqueTickers
+            ]
+
+instance ToSchema PolicyResult
+
+newtype UniqueTicker = UniqueTicker { getUniqueTicker :: (TickerName, PoolMetadataHash) }
+    deriving (Eq, Show, Generic)
+
+instance ToJSON UniqueTicker where
+    toJSON (UniqueTicker (tickerName, poolMetadataHash)) =
+        object
+            [ "tickerName" .= getTickerName tickerName
+            , "poolMetadataHash" .= getPoolMetadataHash poolMetadataHash
+            ]
+
+instance FromJSON UniqueTicker where
+    parseJSON = withObject "UniqueTicker" $ \o -> do
+        tickerName <- o .: "tickerName"
+        poolMetadataHash <- o .: "poolMetadataHash"
+
+        return . UniqueTicker $ (tickerName, poolMetadataHash)
+
+instance ToSchema UniqueTicker
+
 instance ToParamSchema TickerName
 
 instance ToSchema TickerName

smash/smash.cabal

@@ -49,6 +49,7 @@ library
     Cardano.SMASH.FetchQueue
     Cardano.SMASH.Lib
     Cardano.SMASH.Offline
+    Cardano.SMASH.HttpClient
 
   other-modules:      Paths_smash
   hs-source-dirs:     src
@@ -75,6 +76,7 @@ library
     , http-client
     , http-client-tls
     , http-types
+    , http-conduit
     , io-sim-classes
     , iohk-monitoring
     , monad-logger
@@ -94,6 +96,7 @@ library
     , smash-servant-types
     , swagger2
     , template-haskell
+    , safe-exceptions
     , text
     , time
     , transformers

smash/src/Cardano/SMASH/DB.hs

@@ -198,7 +198,9 @@ cachedDataLayer dbDataLayer (InMemoryCacheIORef inMemoryCacheIORef) =
         , dlAddMetaDataReference = dlAddMetaDataReference dbDataLayer
 
         -- TODO(KS): Cache hit?
-        , dlGetReservedTickers = dlGetReservedTickers dbDataLayer
+        , dlGetReservedTickers = do
+            inMemoryCache <- readIORef inMemoryCacheIORef
+            return $ imcReservedTickers inMemoryCache
         , dlAddReservedTicker = \tickerName poolMetadataHash' -> runExceptT $ do
             -- Modify database
             let addReservedTicker = dlAddReservedTicker dbDataLayer

smash/src/Cardano/SMASH/HttpClient.hs

@@ -0,0 +1,113 @@
+{-# LANGUAGE LambdaCase          #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Cardano.SMASH.HttpClient
+  ( httpClientFetchPolicies
+  , httpApiCall
+  , renderHttpClientError
+  ) where
+
+import           Cardano.Prelude
+
+import           Control.Monad.Trans.Except.Extra
+
+import           Cardano.SMASH.DBSync.Db.Types    (PoolId)
+
+import           Cardano.SMASH.Types              (HealthStatus,
+                                                   PolicyResult (..),
+                                                   SmashURL (..))
+import           Data.Aeson                       (FromJSON, parseJSON)
+import           Data.Aeson.Types                 (parseEither)
+
+import           Network.HTTP.Simple              (Request, getResponseBody,
+                                                   getResponseStatusCode,
+                                                   httpJSONEither,
+                                                   parseRequestThrow)
+
+-- |The possible errors for the http client.
+data HttpClientError
+    = HttpClientCannotParseEndpoint !Text
+    | HttpClientInvalidClientBody
+    | HttpClientCannotParseJSON !Text
+    | HttpClientStatusNotOk
+
+-- |Render the http client error.
+renderHttpClientError :: HttpClientError -> Text
+renderHttpClientError = \case
+    HttpClientCannotParseEndpoint endpoint ->
+        mconcat
+            [ "Http client cannot parse the '"
+            , endpoint
+            , "' endpoint"
+            ]
+    HttpClientInvalidClientBody ->
+        "Http client invalid response body."
+    HttpClientCannotParseJSON reason ->
+        mconcat
+            [ "Http client cannot parse the response JSON - '"
+            , reason
+            , "'."
+            ]
+    HttpClientStatusNotOk ->
+        "Http client returned status not ok. Status should be 200."
+
+-- |Fetch the remote SMASH server policies.
+httpClientFetchPolicies :: SmashURL -> IO (Either HttpClientError PolicyResult)
+httpClientFetchPolicies smashURL = runExceptT $ do
+
+    -- https://smash.cardano-mainnet.iohk.io
+    let baseSmashURL = show $ getSmashURL smashURL
+
+    -- TODO(KS): This would be nice.
+    --let delistedEndpoint = symbolVal (Proxy :: Proxy DelistedPoolsAPI)
+    --let smashDelistedEndpoint = baseSmashURL <> delistedEndpoint
+
+    let statusEndpoint = baseSmashURL <> "/api/v1/status"
+    let delistedEndpoint = baseSmashURL <> "/api/v1/delisted"
+    let reservedTickersEndpoint = baseSmashURL <> "/api/v1/tickers"
+
+    statusRequest <- parseRequestEither statusEndpoint
+    delistedRequest <- parseRequestEither delistedEndpoint
+    _reservedTickersRequest <- parseRequestEither reservedTickersEndpoint
+
+    healthStatus :: HealthStatus <- httpApiCall statusRequest
+    delistedPools :: [PoolId] <- httpApiCall delistedRequest
+
+    -- TODO(KS): Current version doesn't have exposed the tickers endpoint and would fail!
+    -- uniqueTickers :: [UniqueTicker] <- httpApiCall reservedTickersRequest
+    uniqueTickers <- pure []
+
+    let policyResult =
+            PolicyResult
+                { prSmashURL = smashURL
+                , prHealthStatus = healthStatus
+                , prDelistedPools = delistedPools
+                , prUniqueTickers = uniqueTickers
+                }
+
+    return policyResult
+
+-- |A simple HTTP call for remote server.
+httpApiCall :: forall a. (FromJSON a) => Request -> ExceptT HttpClientError IO a
+httpApiCall request = do
+
+    httpResult <- httpJSONEither request
+    let httpResponseBody = getResponseBody httpResult
+
+    httpResponse <- firstExceptT (\_ -> HttpClientInvalidClientBody) $ hoistEither httpResponseBody
+
+    let httpStatusCode  = getResponseStatusCode httpResult
+
+    when (httpStatusCode /= 200) $
+        left HttpClientStatusNotOk
+
+    case parseEither parseJSON httpResponse of
+        Left reason -> left $ HttpClientCannotParseJSON (toS reason)
+        Right value -> right value
+
+-- |When any exception occurs, we simply map it to an http client error.
+parseRequestEither :: Text -> ExceptT HttpClientError IO Request
+parseRequestEither requestEndpoint = do
+    let parsedRequest = newExceptT (try $ parseRequestThrow (toS requestEndpoint) :: IO (Either SomeException Request))
+    firstExceptT (\_ -> HttpClientCannotParseEndpoint requestEndpoint) parsedRequest
+