Refactor HealthCheck/HealthStatus types

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

@@ -21,8 +21,8 @@ module Cardano.Pool.Metadata
     , StakePoolMetadataFetchLog (..)
     , fetchDelistedPools
     , healthCheck
-    , isHealthy
-    , HealthCheck (..)
+    , isHealthyStatus
+    , HealthStatusSMASH (..)
 
     -- * Construct URLs
     , identityUrlBuilder
@@ -40,7 +40,7 @@ import Cardano.BM.Data.Severity
 import Cardano.BM.Data.Tracer
     ( HasPrivacyAnnotation (..), HasSeverityAnnotation (..) )
 import Cardano.Wallet.Api.Types
-    ( HealthCheck (..), defaultRecordTypeOptions )
+    ( HealthStatusSMASH (..), defaultRecordTypeOptions )
 import Cardano.Wallet.Primitive.AddressDerivation
     ( hex )
 import Cardano.Wallet.Primitive.Types
@@ -216,35 +216,37 @@ smashRequest mtr uri manager = getPayload
     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
     :: Maybe (Tracer IO StakePoolMetadataFetchLog)
     -> URI
     -> Manager
-    -> IO (Maybe HealthCheck)
+    -> IO (Maybe HealthStatusSMASH)
 healthCheck mtr uri manager = runExceptTLog $ do
     pl <- smashRequest mtr
         (uri { uriPath = "/" <> healthCheckEP , uriQuery = "", uriFragment = "" })
         manager
-    except . eitherDecodeStrict @HealthCheck $ pl
+    except . eitherDecodeStrict @HealthStatusSMASH $ pl
   where
     runExceptTLog
-        :: ExceptT String IO HealthCheck
-        -> IO (Maybe HealthCheck)
+        :: ExceptT String IO HealthStatusSMASH
+        -> IO (Maybe HealthStatusSMASH)
     runExceptTLog action = runExceptT action >>= \case
         Left msg ->
             Nothing <$ trMaybe mtr (MsgFetchHealthCheckFailure msg)
 
         Right health
-            | isHealthy health -> do
+            | isHealthyStatus health -> do
                 trMaybe mtr (MsgFetchHealthCheckFailure
                     ("Server reports unhealthy status: " <> T.unpack (status health)))
                 pure $ Just health
             | otherwise -> do
                 trMaybe mtr (MsgFetchHealthCheckSuccess health)
                 pure (Just health)
 
-isHealthy :: HealthCheck -> Bool
-isHealthy (HealthCheck {..})
+isHealthyStatus :: HealthStatusSMASH -> Bool
+isHealthyStatus (HealthStatusSMASH {..})
     | T.toLower status /= "ok" = True
     | otherwise = False
 
@@ -364,7 +366,7 @@ data StakePoolMetadataFetchLog
     | MsgFetchDelistedPoolsFailure String
     | MsgFetchDelistedPoolsSuccess [PoolId]
     | MsgFetchHealthCheckFailure String
-    | MsgFetchHealthCheckSuccess HealthCheck
+    | MsgFetchHealthCheckSuccess HealthStatusSMASH
     deriving (Show, Eq)
 
 instance HasPrivacyAnnotation StakePoolMetadataFetchLog

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

@@ -127,7 +127,6 @@ import Cardano.Wallet.Api.Types
     , ApiByronWallet
     , ApiCoinSelectionT
     , ApiFee
-    , ApiHealthCheck
     , ApiMaintenanceAction
     , ApiMaintenanceActionPostData
     , ApiNetworkClock
@@ -148,6 +147,7 @@ import Cardano.Wallet.Api.Types
     , ApiWalletPassphrase
     , ApiWalletSignData
     , ByronWalletPutPassphraseData
+    , HealthCheckSMASH
     , Iso8601Time
     , MinWithdrawal
     , PostExternalTransactionData
@@ -724,12 +724,12 @@ type SMASH = GetCurrentSMASHHealth
 
 type GetCurrentSMASHHealth = "smash"
     :> "health"
-    :> Get '[JSON] ApiHealthCheck
+    :> Get '[JSON] (ApiT HealthCheckSMASH)
 
 type GetURISmashHealth = "smash"
     :> "health"
     :> ReqBody '[JSON] (ApiT SmashServer)
-    :> Post '[JSON] ApiHealthCheck
+    :> Post '[JSON] (ApiT HealthCheckSMASH)
 
 {-------------------------------------------------------------------------------
                                    Proxy_

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

@@ -150,8 +150,8 @@ module Cardano.Wallet.Api.Types
 
     -- * Others
     , defaultRecordTypeOptions
-    , HealthCheck (..)
-    , ApiHealthCheck (..)
+    , HealthStatusSMASH (..)
+    , HealthCheckSMASH (..)
     ) where
 
 import Prelude
@@ -2165,37 +2165,30 @@ type instance ApiWalletMigrationPostDataT (n :: NetworkDiscriminant) (s :: Symbo
 -------------------------------------------------------------------------------}
 
 -- | Parses the SMASH HealthCheck type from the SMASH API.
-data HealthCheck = HealthCheck
-    { status :: T.Text
-    , version :: T.Text
+data HealthStatusSMASH = HealthStatusSMASH
+    { status :: Text
+    , version :: Text
     } deriving (Generic, Show, Eq, Ord)
 
-instance FromJSON HealthCheck where
+instance FromJSON HealthStatusSMASH where
     parseJSON = genericParseJSON defaultRecordTypeOptions
-instance ToJSON HealthCheck where
+instance ToJSON HealthStatusSMASH where
     toJSON = genericToJSON defaultRecordTypeOptions
 
-data ApiHealthCheck =
-      Available     -- server available
-    | Unavailable   -- server reachable, but unavailable
-    | Unreachable   -- could not get a response from the SMASH server
-    | NoSMASH       -- no SMASH server has been configured
+-- | 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)
 
-instance FromJSON ApiHealthCheck where
-    parseJSON = withText "ApiHealthCheck" $ \txt -> do
-        case T.unpack txt of
-            "available" -> pure Available
-            "unavailable" -> pure Unavailable
-            "unreachable" -> pure Unreachable
-            "no_smash_configured" -> pure NoSMASH
-            e -> fail ("Unexpeced value: " <> e)
-
-instance ToJSON ApiHealthCheck where
-    toJSON Available = String "available"
-    toJSON Unavailable = String "unavailable"
-    toJSON Unreachable = String "unreachable"
-    toJSON NoSMASH = String "no_smash_configured"
+instance FromJSON (ApiT HealthCheckSMASH) where
+    parseJSON = fmap ApiT . genericParseJSON defaultSumTypeOptions
+        { sumEncoding = UntaggedValue }
+
+instance ToJSON (ApiT HealthCheckSMASH) where
+    toJSON = genericToJSON defaultSumTypeOptions . getApiT
 
 instance FromJSON (ApiT SmashServer) where
     parseJSON = parseJSON >=> either (fail . show . ShowFmt) (pure . ApiT) . fromText

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

@@ -63,7 +63,6 @@ import Cardano.Wallet.Api.Types
     , ApiEpochInfo (..)
     , ApiErrorCode (..)
     , ApiFee (..)
-    , ApiHealthCheck (..)
     , ApiMaintenanceAction (..)
     , ApiMaintenanceActionPostData (..)
     , ApiMnemonicT (..)
@@ -108,6 +107,7 @@ import Cardano.Wallet.Api.Types
     , DecodeStakeAddress (..)
     , EncodeAddress (..)
     , EncodeStakeAddress (..)
+    , HealthCheckSMASH (..)
     , Iso8601Time (..)
     , NtpSyncingStatus (..)
     , PostExternalTransactionData (..)
@@ -368,7 +368,7 @@ spec = do
             jsonRoundtripAndGolden $ Proxy @ApiNetworkParameters
             jsonRoundtripAndGolden $ Proxy @ApiNetworkClock
             jsonRoundtripAndGolden $ Proxy @ApiWalletDelegation
-            jsonRoundtripAndGolden $ Proxy @ApiHealthCheck
+            jsonRoundtripAndGolden $ Proxy @(ApiT HealthCheckSMASH)
             jsonRoundtripAndGolden $ Proxy @ApiWalletDelegationStatus
             jsonRoundtripAndGolden $ Proxy @ApiWalletDelegationNext
             jsonRoundtripAndGolden $ Proxy @(ApiT (Hash "Genesis"))
@@ -1735,7 +1735,7 @@ instance Arbitrary ApiAddressInspect where
             , "stake_reference" .= Aeson.String stake
             ]
 
-instance Arbitrary ApiHealthCheck where
+instance Arbitrary HealthCheckSMASH where
     arbitrary = genericArbitrary
     shrink = genericShrink
 
@@ -1815,7 +1815,7 @@ instance ToSchema (ApiSelectCoinsData n) where
 instance ToSchema (ApiT SmashServer) where
     declareNamedSchema _ = declareSchemaForDefinition "ApiSmashServer"
 
-instance ToSchema ApiHealthCheck where
+instance ToSchema (ApiT HealthCheckSMASH) where
     declareNamedSchema _ = declareSchemaForDefinition "ApiHealthCheck"
 
 instance ToSchema (ApiSelectCoinsPayments n) where

lib/shelley/src/Cardano/Wallet/Shelley.hs

@@ -443,7 +443,7 @@ instance HasSeverityAnnotation ApplicationLog where
         MsgStarting _ -> Info
         MsgNetworkName _ -> Info
         MsgServerStartupError _ -> Alert
-        MsgFailedConnectSMASH _ -> Error
+        MsgFailedConnectSMASH _ -> Warning
 
 {-------------------------------------------------------------------------------
                                     Tracers

lib/shelley/src/Cardano/Wallet/Shelley/Api/Server.hs

@@ -24,7 +24,7 @@ import Prelude
 import Cardano.Address
     ( unAddress )
 import Cardano.Pool.Metadata
-    ( defaultManagerSettings, healthCheck, isHealthy, newManager )
+    ( defaultManagerSettings, healthCheck, isHealthyStatus, newManager )
 import Cardano.Wallet
     ( ErrCreateRandomAddress (..)
     , ErrNotASequentialWallet (..)
@@ -109,13 +109,13 @@ import Cardano.Wallet.Api.Types
     , ApiAddressInspectData (..)
     , ApiCredential (..)
     , ApiErrorCode (..)
-    , ApiHealthCheck (..)
     , ApiMaintenanceAction (..)
     , ApiMaintenanceActionPostData (..)
     , ApiSelectCoinsAction (..)
     , ApiSelectCoinsData (..)
     , ApiStakePool
     , ApiT (..)
+    , HealthCheckSMASH (..)
     , MaintenanceAction (..)
     , SettingsPutData (..)
     , SomeByronWalletPostData (..)
@@ -440,16 +440,16 @@ server byron icarus shelley spl ntp =
         getHealth smashServer = liftIO $ do
             manager <- newManager defaultManagerSettings
             health <- healthCheck Nothing (unSmashServer smashServer) manager
-            pure $ maybe Unreachable
-                (\h -> if isHealthy h then Available else Unavailable) health
+            pure $ ApiT $ maybe Unreachable
+                (\h -> if isHealthyStatus h then Available else Unavailable) health
 
         getUriSmashHealth (ApiT smashServer) = Handler $ getHealth smashServer
 
         getCurrentSmashHealth = Handler $ do
             settings' <- liftIO $ getSettings spl
             case poolMetadataSource settings' of
                 FetchSMASH smashServer -> getHealth smashServer
-                _ -> pure NoSMASH
+                _ -> pure (ApiT NoSmashConfigured)
 
 postAnyAddress
     :: NetworkId

lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedLabels #-}
@@ -47,14 +48,14 @@ import Cardano.Pool.Metadata
     , fetchFromRemote
     , healthCheck
     , identityUrlBuilder
-    , isHealthy
+    , isHealthyStatus
     , newManager
     , registryUrlBuilder
     )
 import Cardano.Wallet
     ( ErrListPools (..) )
 import Cardano.Wallet.Api.Types
-    ( ApiT (..) )
+    ( ApiT (..), HealthCheckSMASH (..) )
 import Cardano.Wallet.Byron.Compatibility
     ( toByronBlockHeader )
 import Cardano.Wallet.Network
@@ -742,53 +743,54 @@ monitorMetadata gcStatus tr sp db@(DBLayer{..}) = do
     settings <- atomically readSettings
     manager <- newManager defaultManagerSettings
 
-    healthy <- case poolMetadataSource settings of
+    health <- case poolMetadataSource settings of
         FetchSMASH uri -> do
             let checkHealth _ = do
                     r <- healthCheck (Just trFetch) (unSmashServer uri) manager
                     case r of
-                        (Just health) -> pure $ isHealthy health
-                        _ -> pure False
+                        (Just health)
+                            | isHealthyStatus health -> pure Available
+                            | otherwise -> pure Unavailable
+                        _ -> pure Unreachable
 
                 maxRetries = 8
                 retryCheck RetryStatus{rsIterNumber} b
-                    | rsIterNumber < maxRetries = pure (not b)
+                    | rsIterNumber < maxRetries = pure
+                        (b == Unavailable || b == Unreachable)
                     | otherwise = pure False
 
                 ms = (* 1_000_000)
                 baseSleepTime = ms 15
 
             retrying (constantDelay baseSleepTime) retryCheck checkHealth
 
-        -- no smash configured, equivalent to healthy
-        _ -> pure True
-
-    if healthy
-    then do
-        let fetcher fetchStrategies = fetchFromRemote trFetch fetchStrategies manager
-            loop getPoolMetadata = forever $ do
-                (refs, successes) <- getPoolMetadata
-                when (null refs || null successes) $ do
-                    traceWith tr $ MsgFetchTakeBreak blockFrequency
-                    threadDelay blockFrequency
-
-        case poolMetadataSource settings of
-            FetchNone -> do
-                STM.atomically $ writeTVar gcStatus NotApplicable
-                loop (pure ([], [])) -- TODO: exit loop?
-            FetchDirect -> do
-                STM.atomically $ writeTVar gcStatus NotApplicable
-                loop (fetchThem $ fetcher [identityUrlBuilder])
-            FetchSMASH (unSmashServer -> uri) -> do
-                STM.atomically $ writeTVar gcStatus NotStarted
-                let getDelistedPools =
-                        fetchDelistedPools trFetch uri manager
-                tid <- forkFinally
-                    (gcDelistedPools gcStatus tr db getDelistedPools)
-                    onExit
-                flip finally (killThread tid) $
-                    loop (fetchThem $ fetcher [registryUrlBuilder uri])
-    else traceWith tr MsgSMASHUnreachable
+        _ -> pure NoSmashConfigured
+
+    if  | health == Available || health == NoSmashConfigured -> do
+            let fetcher fetchStrategies = fetchFromRemote trFetch fetchStrategies manager
+                loop getPoolMetadata = forever $ do
+                    (refs, successes) <- getPoolMetadata
+                    when (null refs || null successes) $ do
+                        traceWith tr $ MsgFetchTakeBreak blockFrequency
+                        threadDelay blockFrequency
+
+            case poolMetadataSource settings of
+                FetchNone -> do
+                    STM.atomically $ writeTVar gcStatus NotApplicable
+                    loop (pure ([], [])) -- TODO: exit loop?
+                FetchDirect -> do
+                    STM.atomically $ writeTVar gcStatus NotApplicable
+                    loop (fetchThem $ fetcher [identityUrlBuilder])
+                FetchSMASH (unSmashServer -> uri) -> do
+                    STM.atomically $ writeTVar gcStatus NotStarted
+                    let getDelistedPools =
+                            fetchDelistedPools trFetch uri manager
+                    tid <- forkFinally
+                        (gcDelistedPools gcStatus tr db getDelistedPools)
+                        onExit
+                    flip finally (killThread tid) $
+                        loop (fetchThem $ fetcher [registryUrlBuilder uri])
+        | otherwise -> traceWith tr MsgSMASHUnreachable
 
   where
     trFetch = contramap MsgFetchPoolMetadata tr