Add proxy endpoints for health check

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

@@ -56,7 +56,7 @@ import Cardano.Wallet.Primitive.Types
 import Control.Exception
     ( IOException, handle )
 import Control.Monad
-    ( forM, when )
+    ( forM, forM_, when )
 import Control.Monad.IO.Class
     ( MonadIO (..) )
 import Control.Monad.Trans.Except
@@ -183,18 +183,24 @@ 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
-    :: Tracer IO StakePoolMetadataFetchLog
+    :: Maybe (Tracer IO StakePoolMetadataFetchLog)
     -> URI
     -> Manager
     -> ExceptT String IO ByteString
-smashRequest tr uri manager = getPayload
+smashRequest mtr uri manager = getPayload
   where
     getPayload :: ExceptT String IO ByteString
     getPayload = do
         req <- withExceptT show $ except $ requestFromURI uri
-        liftIO $ traceWith tr $ MsgFetchSMASH uri
+        liftIO $ trMaybe mtr $ MsgFetchSMASH uri
         ExceptT
             $ handle fromIOException
             $ handle fromHttpException
@@ -214,12 +220,12 @@ smashRequest tr uri manager = getPayload
     fromHttpException = return . Left . ("HTTP exception: " <>) . show
 
 healthCheck
-    :: Tracer IO StakePoolMetadataFetchLog
+    :: Maybe (Tracer IO StakePoolMetadataFetchLog)
     -> URI
     -> Manager
     -> IO (Maybe HealthCheck)
-healthCheck tr uri manager = runExceptTLog $ do
-    pl <- smashRequest tr
+healthCheck mtr uri manager = runExceptTLog $ do
+    pl <- smashRequest mtr
         (uri { uriPath = "/" <> healthCheckEP , uriQuery = "", uriFragment = "" })
         manager
     except . eitherDecodeStrict @HealthCheck $ pl
@@ -229,15 +235,15 @@ healthCheck tr uri manager = runExceptTLog $ do
         -> IO (Maybe HealthCheck)
     runExceptTLog action = runExceptT action >>= \case
         Left msg ->
-            Nothing <$ traceWith tr (MsgFetchHealthCheckFailure msg)
+            Nothing <$ trMaybe mtr (MsgFetchHealthCheckFailure msg)
 
         Right health
             | isHealthy health -> do
-                traceWith tr (MsgFetchHealthCheckFailure
+                trMaybe mtr (MsgFetchHealthCheckFailure
                     ("Server reports unhealthy status: " <> T.unpack (status health)))
                 pure $ Just health
             | otherwise -> do
-                traceWith tr (MsgFetchHealthCheckSuccess health)
+                trMaybe mtr (MsgFetchHealthCheckSuccess health)
                 pure (Just health)
 
 isHealthy :: HealthCheck -> Bool
@@ -251,7 +257,7 @@ fetchDelistedPools
     -> Manager
     -> IO (Maybe [PoolId])
 fetchDelistedPools tr uri manager = runExceptTLog $ do
-    pl <- smashRequest tr uri manager
+    pl <- smashRequest (Just tr) uri manager
     smashPids <- except $ eitherDecodeStrict @[SMASHPoolId] pl
     forM smashPids $ except . first getTextDecodingError . toPoolId
   where

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,9 +168,14 @@ import Cardano.Wallet.Primitive.AddressDerivation
 import Cardano.Wallet.Primitive.SyncProgress
     ( SyncTolerance )
 import Cardano.Wallet.Primitive.Types
-    ( Block, NetworkParameters, SortOrder (..), WalletId (..) )
-import Cardano.Wallet.Primitive.Types.Address
-    ( AddressState )
+    ( AddressState
+    , Block
+    , Coin (..)
+    , NetworkParameters
+    , SmashServer (..)
+    , SortOrder (..)
+    , WalletId (..)
+    )
 import Cardano.Wallet.Primitive.Types.Coin
     ( Coin (..) )
 import Cardano.Wallet.Registry
@@ -233,6 +240,7 @@ type Api n apiPool =
     :<|> Network
     :<|> Proxy_
     :<|> Settings
+    :<|> SMASH
 
 {-------------------------------------------------------------------------------
                                   Wallets
@@ -709,6 +717,23 @@ type GetNetworkClock = "network"
     :> QueryFlag "forceNtpCheck"
     :> Get '[JSON] ApiNetworkClock
 
+{-------------------------------------------------------------------------------
+                                  SMASH
+
+-------------------------------------------------------------------------------}
+
+type SMASH = GetCurrentSMASHHealth
+    :<|> GetURISmashHealth
+
+type GetCurrentSMASHHealth = "smash"
+    :> "health"
+    :> Get '[JSON] ApiHealthCheck
+
+type GetURISmashHealth = "smash"
+    :> "health"
+    :> ReqBody '[JSON] (ApiT SmashServer)
+    :> Post '[JSON] ApiHealthCheck
+
 {-------------------------------------------------------------------------------
                                    Proxy_
 

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

@@ -151,6 +151,7 @@ module Cardano.Wallet.Api.Types
     -- * Others
     , defaultRecordTypeOptions
     , HealthCheck (..)
+    , ApiHealthCheck (..)
     ) where
 
 import Prelude
@@ -205,6 +206,7 @@ import Cardano.Wallet.Primitive.Types
     , SlotLength (..)
     , SlotNo (..)
     , SlottingParameters (..)
+    , SmashServer (..)
     , StakePoolMetadata
     , StartTime (..)
     , UTxOStatistics (..)
@@ -2160,6 +2162,7 @@ type instance ApiWalletMigrationPostDataT (n :: NetworkDiscriminant) (s :: Symbo
                          SMASH interfacing types
 -------------------------------------------------------------------------------}
 
+-- | Parses the SMASH HealthCheck type from the SMASH API.
 data HealthCheck = HealthCheck
     { status :: T.Text
     , version :: T.Text
@@ -2170,3 +2173,31 @@ instance FromJSON HealthCheck where
 instance ToJSON HealthCheck 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
+    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 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,15 @@
+{
+    "seed": 5135632696367642844,
+    "samples": [
+        "available",
+        "available",
+        "unavailable",
+        "available",
+        "available",
+        "unavailable",
+        "no_smash_configured",
+        "unavailable",
+        "no_smash_configured",
+        "unreachable"
+    ]
+}

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

@@ -76,7 +76,7 @@ import Cardano.Wallet.Api.Types
 import Cardano.Wallet.Primitive.AddressDerivation
     ( AccountingStyle (..), DerivationIndex (..), NetworkDiscriminant (..) )
 import Cardano.Wallet.Primitive.Types
-    ( WalletId, walletNameMaxLength )
+    ( WalletId, SmashServer, walletNameMaxLength )
 import Cardano.Wallet.Primitive.Types.Address
     ( Address (..) )
 import Control.Arrow
@@ -1151,6 +1151,13 @@ instance Malformed (BodyParam ApiMaintenanceActionPostData) where
           )
         ]
 
+instance Malformed (BodyParam (ApiT SmashServer)) where
+    malformed = first (BodyParam . Aeson.encode) <$>
+        [ ( [aesonQQ|"smash.server.org"|]
+          , "Error in $: Not a valid absolute URI."
+          )
+        ]
+
 --
 -- Class instances (Header)
 --

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

@@ -63,6 +63,7 @@ import Cardano.Wallet.Api.Types
     , ApiEpochInfo (..)
     , ApiErrorCode (..)
     , ApiFee (..)
+    , ApiHealthCheck (..)
     , ApiMaintenanceAction (..)
     , ApiMaintenanceActionPostData (..)
     , ApiMnemonicT (..)
@@ -351,6 +352,7 @@ spec = do
             jsonRoundtripAndGolden $ Proxy @ApiNetworkParameters
             jsonRoundtripAndGolden $ Proxy @ApiNetworkClock
             jsonRoundtripAndGolden $ Proxy @ApiWalletDelegation
+            jsonRoundtripAndGolden $ Proxy @ApiHealthCheck
             jsonRoundtripAndGolden $ Proxy @ApiWalletDelegationStatus
             jsonRoundtripAndGolden $ Proxy @ApiWalletDelegationNext
             jsonRoundtripAndGolden $ Proxy @(ApiT (Hash "Genesis"))
@@ -1721,6 +1723,10 @@ instance Arbitrary ApiAddressInspect where
             , "stake_reference" .= Aeson.String stake
             ]
 
+instance Arbitrary ApiHealthCheck where
+    arbitrary = genericArbitrary
+    shrink = genericShrink
+
 {-------------------------------------------------------------------------------
                    Specification / Servant-Swagger Machinery
 
@@ -1785,6 +1791,12 @@ instance ToSchema (ApiPutAddressesData t) where
 instance ToSchema (ApiSelectCoinsData n) where
     declareNamedSchema _ = declareSchemaForDefinition "ApiSelectCoinsData"
 
+instance ToSchema (ApiT SmashServer) where
+    declareNamedSchema _ = declareSchemaForDefinition "ApiSmashServer"
+
+instance ToSchema ApiHealthCheck where
+    declareNamedSchema _ = declareSchemaForDefinition "ApiHealthCheck"
+
 instance ToSchema (ApiSelectCoinsPayments n) where
     declareNamedSchema _ = declareSchemaForDefinition "ApiSelectCoinsPayments"
 

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

@@ -23,6 +23,8 @@ import Prelude
 
 import Cardano.Address
     ( unAddress )
+import Cardano.Pool.Metadata
+    ( defaultManagerSettings, healthCheck, isHealthy, newManager )
 import Cardano.Wallet
     ( ErrCreateRandomAddress (..)
     , ErrNotASequentialWallet (..)
@@ -43,6 +45,7 @@ import Cardano.Wallet.Api
     , CoinSelections
     , Network
     , Proxy_
+    , SMASH
     , Settings
     , ShelleyMigrations
     , StakePools
@@ -106,6 +109,7 @@ import Cardano.Wallet.Api.Types
     , ApiAddressInspectData (..)
     , ApiCredential (..)
     , ApiErrorCode (..)
+    , ApiHealthCheck (..)
     , ApiMaintenanceAction (..)
     , ApiMaintenanceActionPostData (..)
     , ApiSelectCoinsAction (..)
@@ -128,6 +132,8 @@ import Cardano.Wallet.Primitive.AddressDiscovery.Random
     ( RndState )
 import Cardano.Wallet.Primitive.AddressDiscovery.Sequential
     ( SeqState )
+import Cardano.Wallet.Primitive.Types
+    ( PoolMetadataSource (..), SmashServer (..), poolMetadataSource )
 import Cardano.Wallet.Shelley.Compatibility
     ( HasNetworkId (..), NetworkId, inspectAddress )
 import Cardano.Wallet.Shelley.Pools
@@ -203,6 +209,7 @@ server byron icarus shelley spl ntp =
     :<|> network'
     :<|> proxy
     :<|> settingS
+    :<|> smash
   where
     wallets :: Server Wallets
     wallets = deleteWallet shelley
@@ -427,6 +434,23 @@ server byron icarus shelley spl ntp =
         getSettings'
             = Handler $ fmap ApiT $ liftIO $ getSettings spl
 
+    smash :: Server SMASH
+    smash = getCurrentSmashHealth :<|> getUriSmashHealth
+      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
+
+        getUriSmashHealth (ApiT smashServer) = Handler $ getHealth smashServer
+
+        getCurrentSmashHealth = Handler $ do
+            settings' <- liftIO $ getSettings spl
+            case poolMetadataSource settings' of
+                FetchSMASH smashServer -> getHealth smashServer
+                _ -> pure NoSMASH
+
 postAnyAddress
     :: NetworkId
     -> ApiAddressData

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

@@ -744,7 +744,7 @@ monitorMetadata gcStatus tr sp db@(DBLayer{..}) = do
     case poolMetadataSource settings of
         FetchSMASH uri -> do
             let loop = do
-                    r <- healthCheck trFetch (unSmashServer uri) manager
+                    r <- healthCheck (Just trFetch) (unSmashServer uri) manager
                     case r of
                         (Just health)
                             | isHealthy health -> pure ()