Add health check

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

@@ -3,6 +3,7 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TypeApplications #-}
 
 -- |
@@ -19,6 +20,10 @@ module Cardano.Pool.Metadata
       fetchFromRemote
     , StakePoolMetadataFetchLog (..)
     , fetchDelistedPools
+    , healthCheck
+    , isHealthyStatus
+    , toHealthCheckSMASH
+    , HealthStatusSMASH (..)
 
     -- * Construct URLs
     , identityUrlBuilder
@@ -39,11 +44,11 @@ import Cardano.BM.Data.Severity
 import Cardano.BM.Data.Tracer
     ( HasPrivacyAnnotation (..), HasSeverityAnnotation (..) )
 import Cardano.Wallet.Api.Types
-    ( defaultRecordTypeOptions )
+    ( HealthCheckSMASH (..), HealthStatusSMASH (..), defaultRecordTypeOptions )
 import Cardano.Wallet.Primitive.AddressDerivation
     ( hex )
 import Cardano.Wallet.Primitive.Types
-    ( PoolId
+    ( PoolId (..)
     , StakePoolMetadata (..)
     , StakePoolMetadataHash (..)
     , StakePoolMetadataUrl (..)
@@ -62,12 +67,14 @@ import Control.Tracer
 import Crypto.Hash.Utils
     ( blake2b256 )
 import Data.Aeson
-    ( FromJSON (..)
-    , ToJSON (..)
+    ( FromJSON
+    , ToJSON
     , eitherDecodeStrict
     , fieldLabelModifier
     , genericParseJSON
     , genericToJSON
+    , parseJSON
+    , toJSON
     )
 import Data.Bifunctor
     ( first )
@@ -119,6 +126,13 @@ metadaFetchEp pid (StakePoolMetadataHash bytes)
     hashStr = T.unpack $ T.decodeUtf8 $ convertToBase Base16 bytes
     pidStr  = T.unpack $ toText pid
 
+-- TODO: use SMASH servant types
+healthCheckEP :: String
+healthCheckEP = T.unpack $ T.intercalate "/" ["api", "v1", "status"]
+
+delistedEP :: String
+delistedEP = T.unpack $ T.intercalate "/" ["api", "v1", "delisted"]
+
 -- | TODO: import SMASH types
 newtype SMASHPoolId = SMASHPoolId
     { poolId :: T.Text
@@ -173,20 +187,18 @@ registryUrlBuilder baseUrl pid _ hash =
         { uriPath = "/" <> metadaFetchEp pid hash
         }
 
-fetchDelistedPools
+-- | A smash GET request that reads the result at once into memory.
+smashRequest
     :: Tracer IO StakePoolMetadataFetchLog
     -> URI
     -> Manager
-    -> IO (Maybe [PoolId])
-fetchDelistedPools tr uri manager = runExceptTLog $ do
-    pl <- getPoolsPayload
-    smashPids <- except $ eitherDecodeStrict @[SMASHPoolId] pl
-    forM smashPids $ except . first getTextDecodingError . toPoolId
+    -> ExceptT String IO ByteString
+smashRequest tr uri manager = getPayload
   where
-    getPoolsPayload :: ExceptT String IO ByteString
-    getPoolsPayload = do
+    getPayload :: ExceptT String IO ByteString
+    getPayload = do
         req <- withExceptT show $ except $ requestFromURI uri
-        liftIO $ traceWith tr $ MsgFetchDelistedPools uri
+        liftIO $ traceWith tr $ MsgFetchSMASH uri
         ExceptT
             $ handle fromIOException
             $ handle fromHttpException
@@ -202,6 +214,57 @@ fetchDelistedPools tr uri manager = runExceptTLog $ do
                 , show s
                 ]
 
+    fromHttpException :: Monad m => HttpException -> m (Either String a)
+    fromHttpException = return . Left . ("HTTP exception: " <>) . show
+
+-- | Gets the health status from the SMASH server. Returns
+-- @Nothing@ if the server is unreachable.
+healthCheck
+    :: Tracer IO StakePoolMetadataFetchLog
+    -> URI
+    -> Manager
+    -> IO (Maybe HealthStatusSMASH)
+healthCheck tr uri manager = runExceptTLog $ do
+    pl <- smashRequest tr
+        (uri { uriPath = "/" <> healthCheckEP , uriQuery = "", uriFragment = "" })
+        manager
+    except . eitherDecodeStrict @HealthStatusSMASH $ pl
+  where
+    runExceptTLog
+        :: ExceptT String IO HealthStatusSMASH
+        -> IO (Maybe HealthStatusSMASH)
+    runExceptTLog action = runExceptT action >>= \case
+        Left msg ->
+            Nothing <$ traceWith tr (MsgFetchHealthCheckFailure msg)
+        Right health -> do
+            traceWith tr (MsgFetchHealthCheckSuccess health)
+            pure $ Just health
+
+-- | Convert the result of @healthCheck@, which represents the
+-- server response to our own @HealthCheckSMASH@ type, which is a
+-- superset of it.
+toHealthCheckSMASH :: Maybe HealthStatusSMASH -> HealthCheckSMASH
+toHealthCheckSMASH = \case
+    (Just health)
+        | isHealthyStatus health -> Available
+        | otherwise -> Unavailable
+    _ -> Unreachable
+
+isHealthyStatus :: HealthStatusSMASH -> Bool
+isHealthyStatus (HealthStatusSMASH {..}) = T.toLower status == "ok"
+
+fetchDelistedPools
+    :: Tracer IO StakePoolMetadataFetchLog
+    -> URI
+    -> Manager
+    -> IO (Maybe [PoolId])
+fetchDelistedPools tr uri manager = runExceptTLog $ do
+    pl <- smashRequest tr
+        (uri { uriPath = "/" <> delistedEP , uriQuery = "", uriFragment = "" })
+        manager
+    smashPids <- except $ eitherDecodeStrict @[SMASHPoolId] pl
+    forM smashPids $ except . first getTextDecodingError . toPoolId
+  where
     runExceptTLog
         :: ExceptT String IO [PoolId]
         -> IO (Maybe [PoolId])
@@ -212,9 +275,6 @@ fetchDelistedPools tr uri manager = runExceptTLog $ do
         Right meta ->
             Just meta <$ traceWith tr (MsgFetchDelistedPoolsSuccess meta)
 
-    fromHttpException :: Monad m => HttpException -> m (Either String a)
-    fromHttpException = return . Left . ("HTTP exception: " <>) . show
-
 -- TODO: refactor/simplify this
 fetchFromRemote
     :: Tracer IO StakePoolMetadataFetchLog
@@ -301,14 +361,17 @@ fetchFromRemote tr builders manager pid url hash = runExceptTLog $ do
 
 fromIOException :: Monad m => IOException -> m (Either String a)
 fromIOException = return . Left . ("IO exception: " <>) . show
+
 data StakePoolMetadataFetchLog
     = MsgFetchPoolMetadata StakePoolMetadataHash URI
     | MsgFetchPoolMetadataSuccess StakePoolMetadataHash StakePoolMetadata
     | MsgFetchPoolMetadataFailure StakePoolMetadataHash String
     | MsgFetchPoolMetadataFallback URI Bool
-    | MsgFetchDelistedPools URI
+    | MsgFetchSMASH URI
     | MsgFetchDelistedPoolsFailure String
     | MsgFetchDelistedPoolsSuccess [PoolId]
+    | MsgFetchHealthCheckFailure String
+    | MsgFetchHealthCheckSuccess HealthStatusSMASH
     deriving (Show, Eq)
 
 instance HasPrivacyAnnotation StakePoolMetadataFetchLog
@@ -318,9 +381,11 @@ instance HasSeverityAnnotation StakePoolMetadataFetchLog where
         MsgFetchPoolMetadataSuccess{} -> Info
         MsgFetchPoolMetadataFailure{} -> Warning
         MsgFetchPoolMetadataFallback{} -> Warning
-        MsgFetchDelistedPools{} -> Info
+        MsgFetchSMASH{} -> Debug
         MsgFetchDelistedPoolsFailure{} -> Warning
         MsgFetchDelistedPoolsSuccess{} -> Info
+        MsgFetchHealthCheckFailure{} -> Warning
+        MsgFetchHealthCheckSuccess{} -> Info
 
 instance ToText StakePoolMetadataFetchLog where
     toText = \case
@@ -341,8 +406,8 @@ instance ToText StakePoolMetadataFetchLog where
                 then ""
                 else " Falling back using a different strategy."
             ]
-        MsgFetchDelistedPools uri -> mconcat
-            [ "Fetching delisted pools from ", T.pack (show uri)
+        MsgFetchSMASH uri -> mconcat
+            [ "Making a SMASH request to ", T.pack (show uri)
             ]
         MsgFetchDelistedPoolsSuccess poolIds -> mconcat
             [ "Successfully fetched delisted "
@@ -352,3 +417,11 @@ instance ToText StakePoolMetadataFetchLog where
         MsgFetchDelistedPoolsFailure err -> mconcat
             [ "Failed to fetch delisted pools: ", T.pack err
             ]
+        MsgFetchHealthCheckSuccess health -> mconcat
+            [ "Successfully checked health "
+            , T.pack (show health)
+            ]
+        MsgFetchHealthCheckFailure err -> mconcat
+            [ "Failed to check health: ", T.pack err
+            ]
+

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

@@ -100,6 +100,7 @@ module Cardano.Wallet.Api
         , GetNetworkInformation
         , GetNetworkParameters
         , GetNetworkClock
+    , SMASH
 
     , Proxy_
         , PostExternalTransaction
@@ -126,6 +127,7 @@ import Cardano.Wallet.Api.Types
     , ApiByronWallet
     , ApiCoinSelectionT
     , ApiFee
+    , ApiHealthCheck
     , ApiMaintenanceAction
     , ApiMaintenanceActionPostData
     , ApiNetworkClock
@@ -166,7 +168,12 @@ import Cardano.Wallet.Primitive.AddressDerivation
 import Cardano.Wallet.Primitive.SyncProgress
     ( SyncTolerance )
 import Cardano.Wallet.Primitive.Types
-    ( Block, NetworkParameters, SortOrder (..), WalletId (..) )
+    ( Block
+    , NetworkParameters
+    , SmashServer (..)
+    , SortOrder (..)
+    , WalletId (..)
+    )
 import Cardano.Wallet.Primitive.Types.Address
     ( AddressState )
 import Cardano.Wallet.Primitive.Types.Coin
@@ -233,6 +240,7 @@ type Api n apiPool =
     :<|> Network
     :<|> Proxy_
     :<|> Settings
+    :<|> SMASH
 
 {-------------------------------------------------------------------------------
                                   Wallets
@@ -709,6 +717,18 @@ type GetNetworkClock = "network"
     :> QueryFlag "forceNtpCheck"
     :> Get '[JSON] ApiNetworkClock
 
+{-------------------------------------------------------------------------------
+                                  SMASH
+
+-------------------------------------------------------------------------------}
+
+type SMASH = GetCurrentSMASHHealth
+
+type GetCurrentSMASHHealth = "smash"
+    :> "health"
+    :> QueryParam "url" (ApiT SmashServer)
+    :> Get '[JSON] ApiHealthCheck
+
 {-------------------------------------------------------------------------------
                                    Proxy_
 

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

@@ -150,8 +150,11 @@ module Cardano.Wallet.Api.Types
     , PostTransactionFeeDataT
     , ApiWalletMigrationPostDataT
 
-    -- * other
+    -- * Others
     , defaultRecordTypeOptions
+    , HealthStatusSMASH (..)
+    , HealthCheckSMASH (..)
+    , ApiHealthCheck (..)
     ) where
 
 import Prelude
@@ -205,6 +208,7 @@ import Cardano.Wallet.Primitive.Types
     , SlotLength (..)
     , SlotNo (..)
     , SlottingParameters (..)
+    , SmashServer (..)
     , StakePoolMetadata
     , StartTime (..)
     , WalletBalance (..)
@@ -2161,3 +2165,49 @@ type instance PostTransactionFeeDataT (n :: NetworkDiscriminant) =
 
 type instance ApiWalletMigrationPostDataT (n :: NetworkDiscriminant) (s :: Symbol) =
     ApiWalletMigrationPostData n s
+
+
+{-------------------------------------------------------------------------------
+                         SMASH interfacing types
+-------------------------------------------------------------------------------}
+
+-- | Parses the SMASH HealthCheck type from the SMASH API.
+data HealthStatusSMASH = HealthStatusSMASH
+    { status :: Text
+    , version :: Text
+    } deriving (Generic, Show, Eq, Ord)
+
+instance FromJSON HealthStatusSMASH where
+    parseJSON = genericParseJSON defaultRecordTypeOptions
+instance ToJSON HealthStatusSMASH where
+    toJSON = genericToJSON defaultRecordTypeOptions
+
+-- | Dscribes the health status of the SMASH server.
+data HealthCheckSMASH =
+      Available          -- server available
+    | Unavailable        -- server reachable, but unavailable
+    | Unreachable        -- could not get a response from the SMASH server
+    | NoSmashConfigured  -- no SMASH server has been configured
+    deriving (Generic, Show, Eq, Ord)
+
+newtype ApiHealthCheck = ApiHealthCheck
+    { health :: HealthCheckSMASH }
+    deriving (Generic, Show, Eq, Ord)
+
+instance FromJSON HealthCheckSMASH where
+    parseJSON = genericParseJSON defaultSumTypeOptions
+        { sumEncoding = UntaggedValue }
+instance ToJSON HealthCheckSMASH where
+    toJSON = genericToJSON defaultSumTypeOptions
+
+instance FromJSON ApiHealthCheck where
+    parseJSON = genericParseJSON defaultRecordTypeOptions
+instance ToJSON ApiHealthCheck where
+    toJSON = genericToJSON defaultRecordTypeOptions
+
+instance FromJSON (ApiT SmashServer) where
+    parseJSON = parseJSON >=> either (fail . show . ShowFmt) (pure . ApiT) . fromText
+
+instance ToJSON (ApiT SmashServer) where
+    toJSON = toJSON . toText . getApiT
+

lib/core/test/data/Cardano/Wallet/Api/ApiHealthCheck.json

@@ -0,0 +1,35 @@
+{
+    "seed": 7366747724838226215,
+    "samples": [
+        {
+            "health": "no_smash_configured"
+        },
+        {
+            "health": "unreachable"
+        },
+        {
+            "health": "available"
+        },
+        {
+            "health": "unreachable"
+        },
+        {
+            "health": "available"
+        },
+        {
+            "health": "available"
+        },
+        {
+            "health": "unreachable"
+        },
+        {
+            "health": "available"
+        },
+        {
+            "health": "unavailable"
+        },
+        {
+            "health": "unavailable"
+        }
+    ]
+}

lib/core/test/data/Cardano/Wallet/Api/ApiTHealthCheckSMASH.json

@@ -0,0 +1,15 @@
+{
+    "seed": -5187213199879941418,
+    "samples": [
+        "no_smash_configured",
+        "unreachable",
+        "no_smash_configured",
+        "available",
+        "unavailable",
+        "unavailable",
+        "no_smash_configured",
+        "no_smash_configured",
+        "unavailable",
+        "unavailable"
+    ]
+}