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
@@ -53,7 +53,7 @@ import Cardano.Wallet.Primitive.Types
 import Control.Exception
     ( IOException, handle )
 import Control.Monad
-    ( forM, forM_, when )
+    ( forM, when )
 import Control.Monad.IO.Class
     ( MonadIO (..) )
 import Control.Monad.Trans.Except
@@ -180,24 +180,18 @@ registryUrlBuilder baseUrl pid _ hash =
         { uriPath = "/" <> metadaFetchEp pid hash
         }
 
-trMaybe
-    :: Maybe (Tracer IO StakePoolMetadataFetchLog)
-    -> StakePoolMetadataFetchLog
-    -> IO ()
-trMaybe mtr m = forM_ mtr $ \tr -> traceWith tr m
-
 -- | A smash GET request that reads the result at once into memory.
 smashRequest
-    :: Maybe (Tracer IO StakePoolMetadataFetchLog)
+    :: Tracer IO StakePoolMetadataFetchLog
     -> URI
     -> Manager
     -> ExceptT String IO ByteString
-smashRequest mtr uri manager = getPayload
+smashRequest tr uri manager = getPayload
   where
     getPayload :: ExceptT String IO ByteString
     getPayload = do
         req <- withExceptT show $ except $ requestFromURI uri
-        liftIO $ trMaybe mtr $ MsgFetchSMASH uri
+        liftIO $ traceWith tr $ MsgFetchSMASH uri
         ExceptT
             $ handle fromIOException
             $ handle fromHttpException
@@ -216,35 +210,31 @@ 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)
+    :: Tracer IO StakePoolMetadataFetchLog
     -> URI
     -> Manager
-    -> IO (Maybe HealthCheck)
-healthCheck mtr uri manager = runExceptTLog $ do
-    pl <- smashRequest mtr
+    -> IO (Maybe HealthStatusSMASH)
+healthCheck tr uri manager = runExceptTLog $ do
+    pl <- smashRequest tr
         (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
-                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 {..})
+            Nothing <$ traceWith tr (MsgFetchHealthCheckFailure msg)
+        Right health -> do
+            traceWith tr (MsgFetchHealthCheckSuccess health)
+            pure $ Just health
+
+isHealthyStatus :: HealthStatusSMASH -> Bool
+isHealthyStatus (HealthStatusSMASH {..})
     | T.toLower status /= "ok" = True
     | otherwise = False
 
@@ -254,7 +244,7 @@ fetchDelistedPools
     -> Manager
     -> IO (Maybe [PoolId])
 fetchDelistedPools tr uri manager = runExceptTLog $ do
-    pl <- smashRequest (Just tr) uri manager
+    pl <- smashRequest tr uri manager
     smashPids <- except $ eitherDecodeStrict @[SMASHPoolId] pl
     forM smashPids $ except . first getTextDecodingError . toPoolId
   where
@@ -364,7 +354,7 @@ data StakePoolMetadataFetchLog
     | MsgFetchDelistedPoolsFailure String
     | MsgFetchDelistedPoolsSuccess [PoolId]
     | MsgFetchHealthCheckFailure String
-    | MsgFetchHealthCheckSuccess HealthCheck
+    | MsgFetchHealthCheckSuccess HealthStatusSMASH
     deriving (Show, Eq)
 
 instance HasPrivacyAnnotation StakePoolMetadataFetchLog
@@ -377,7 +367,7 @@ instance HasSeverityAnnotation StakePoolMetadataFetchLog where
         MsgFetchSMASH{} -> Debug
         MsgFetchDelistedPoolsFailure{} -> Warning
         MsgFetchDelistedPoolsSuccess{} -> Info
-        MsgFetchHealthCheckFailure{} -> Error
+        MsgFetchHealthCheckFailure{} -> Warning
         MsgFetchHealthCheckSuccess{} -> Info
 
 instance ToText StakePoolMetadataFetchLog where

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
@@ -725,12 +725,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/data/Cardano/Wallet/Api/ApiHealthCheck.json → lib/core/test/data/Cardano/Wallet/Api/ApiTHealthCheckSMASH.json

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

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 (..)
@@ -107,6 +106,7 @@ import Cardano.Wallet.Api.Types
     , DecodeStakeAddress (..)
     , EncodeAddress (..)
     , EncodeStakeAddress (..)
+    , HealthCheckSMASH (..)
     , Iso8601Time (..)
     , NtpSyncingStatus (..)
     , PostExternalTransactionData (..)
@@ -348,7 +348,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"))
@@ -1719,7 +1719,7 @@ instance Arbitrary ApiAddressInspect where
             , "stake_reference" .= Aeson.String stake
             ]
 
-instance Arbitrary ApiHealthCheck where
+instance Arbitrary HealthCheckSMASH where
     arbitrary = genericArbitrary
     shrink = genericShrink
 
@@ -1790,7 +1790,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 (..)
@@ -439,17 +439,17 @@ server byron icarus shelley spl ntp =
       where
         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
+            health <- healthCheck mempty (unSmashServer smashServer) manager
+            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