diff --git a/lib/core/src/Cardano/Pool/Metadata.hs b/lib/core/src/Cardano/Pool/Metadata.hs index 9153e842b33..310a83850ae 100644 --- a/lib/core/src/Cardano/Pool/Metadata.hs +++ b/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 + ] + diff --git a/lib/core/src/Cardano/Wallet/Api.hs b/lib/core/src/Cardano/Wallet/Api.hs index 0e2043cc9b0..b1bf6ad2beb 100644 --- a/lib/core/src/Cardano/Wallet/Api.hs +++ b/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_ diff --git a/lib/core/src/Cardano/Wallet/Api/Types.hs b/lib/core/src/Cardano/Wallet/Api/Types.hs index 04984d51c35..c909b8937ca 100644 --- a/lib/core/src/Cardano/Wallet/Api/Types.hs +++ b/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 + diff --git a/lib/core/test/data/Cardano/Wallet/Api/ApiHealthCheck.json b/lib/core/test/data/Cardano/Wallet/Api/ApiHealthCheck.json new file mode 100644 index 00000000000..d3cf38bf24d --- /dev/null +++ b/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" + } + ] +} \ No newline at end of file diff --git a/lib/core/test/data/Cardano/Wallet/Api/ApiTHealthCheckSMASH.json b/lib/core/test/data/Cardano/Wallet/Api/ApiTHealthCheckSMASH.json new file mode 100644 index 00000000000..930cc9e0d3a --- /dev/null +++ b/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" + ] +} \ No newline at end of file diff --git a/lib/core/test/unit/Cardano/Wallet/Api/TypesSpec.hs b/lib/core/test/unit/Cardano/Wallet/Api/TypesSpec.hs index f3d41099cf1..e449070c35b 100644 --- a/lib/core/test/unit/Cardano/Wallet/Api/TypesSpec.hs +++ b/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 (..) @@ -106,6 +107,7 @@ import Cardano.Wallet.Api.Types , DecodeStakeAddress (..) , EncodeAddress (..) , EncodeStakeAddress (..) + , HealthCheckSMASH (..) , Iso8601Time (..) , NtpSyncingStatus (..) , PostExternalTransactionData (..) @@ -352,6 +354,7 @@ spec = parallel $ do jsonRoundtripAndGolden $ Proxy @ApiNetworkParameters jsonRoundtripAndGolden $ Proxy @ApiNetworkClock jsonRoundtripAndGolden $ Proxy @ApiWalletDelegation + jsonRoundtripAndGolden $ Proxy @ApiHealthCheck jsonRoundtripAndGolden $ Proxy @ApiWalletDelegationStatus jsonRoundtripAndGolden $ Proxy @ApiWalletDelegationNext jsonRoundtripAndGolden $ Proxy @(ApiT (Hash "Genesis")) @@ -1722,6 +1725,14 @@ instance Arbitrary ApiAddressInspect where , "stake_reference" .= Aeson.String stake ] +instance Arbitrary HealthCheckSMASH where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary ApiHealthCheck where + arbitrary = genericArbitrary + shrink = genericShrink + {------------------------------------------------------------------------------- Specification / Servant-Swagger Machinery @@ -1786,6 +1797,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" diff --git a/lib/shelley/exe/cardano-wallet.hs b/lib/shelley/exe/cardano-wallet.hs index 85de90718b9..f52e3653407 100644 --- a/lib/shelley/exe/cardano-wallet.hs +++ b/lib/shelley/exe/cardano-wallet.hs @@ -98,7 +98,7 @@ import Cardano.Wallet.Shelley.Launch , parseGenesisData ) import Cardano.Wallet.Version - ( GitRevision, Version, gitRevision, showFullVersion, version ) + ( GitRevision, Version, gitRevision, showFullVersion ) import Control.Applicative ( Const (..), optional ) import Control.Monad @@ -134,6 +134,7 @@ import System.Environment import System.Exit ( ExitCode (..), exitWith ) +import qualified Cardano.Wallet.Version as V import qualified Data.Text as T {------------------------------------------------------------------------------- @@ -296,7 +297,7 @@ withTracers logOpt action = withLogging [LogToStdout (loggingMinSeverity logOpt)] $ \(_, tr) -> do let trMain = appendName "main" (transformTextTrace tr) let tracers = setupTracers (loggingTracers logOpt) tr - logInfo trMain $ MsgVersion version gitRevision + logInfo trMain $ MsgVersion V.version gitRevision logInfo trMain =<< MsgCmdLine <$> getExecutablePath <*> getArgs action trMain tracers diff --git a/lib/shelley/src/Cardano/Wallet/Shelley.hs b/lib/shelley/src/Cardano/Wallet/Shelley.hs index a4b2e88d10a..cd913f14e36 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley.hs @@ -127,7 +127,7 @@ import Cardano.Wallet.Shelley.Network ( NetworkLayerLog, withNetworkLayer ) import Cardano.Wallet.Shelley.Pools ( StakePoolLayer (..) - , StakePoolLog + , StakePoolLog (..) , monitorMetadata , monitorStakePools , newStakePoolLayer @@ -162,6 +162,8 @@ import Network.Ntp ( NtpClient (..), NtpTrace, withWalletNtpClient ) import Network.Socket ( SockAddr, Socket, getSocketName ) +import Network.URI + ( URI (..), uriToString ) import Network.Wai.Handler.Warp ( setBeforeMainLoop ) import Network.Wai.Middleware.Logging @@ -338,6 +340,7 @@ serveWallet gcStatus <- newTVarIO NotStarted forM_ settings $ atomically . putSettings + void $ forkFinally (monitorStakePools tr gp nl db) onExit spl <- newStakePoolLayer gcStatus nl db $ forkFinally (monitorMetadata gcStatus tr sp db) onExit @@ -402,6 +405,7 @@ data ApplicationLog = MsgStarting FilePath | MsgNetworkName Text | MsgServerStartupError ListenError + | MsgFailedConnectSMASH URI deriving (Generic, Show, Eq) instance ToText ApplicationLog where @@ -427,6 +431,11 @@ instance ToText ApplicationLog where ListenErrorOperationNotPermitted -> mempty <> "Cannot listen on the given port. " <> "The operation is not permitted." + MsgFailedConnectSMASH uri -> T.unwords + [ "Failed connect to the given smash server or validate a healthy status." + , "SMASH uri was: " + , T.pack $ uriToString id uri "" + ] instance HasPrivacyAnnotation ApplicationLog instance HasSeverityAnnotation ApplicationLog where @@ -434,6 +443,7 @@ instance HasSeverityAnnotation ApplicationLog where MsgStarting _ -> Info MsgNetworkName _ -> Info MsgServerStartupError _ -> Alert + MsgFailedConnectSMASH _ -> Warning {------------------------------------------------------------------------------- Tracers diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Api/Server.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Api/Server.hs index c8f192cc91c..cd323273e4b 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Api/Server.hs +++ b/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, newManager, toHealthCheckSMASH ) import Cardano.Wallet ( ErrCreateRandomAddress (..) , ErrNotASequentialWallet (..) @@ -43,6 +45,7 @@ import Cardano.Wallet.Api , CoinSelections , Network , Proxy_ + , SMASH , Settings , ShelleyMigrations , StakePools @@ -106,12 +109,14 @@ import Cardano.Wallet.Api.Types , ApiAddressInspectData (..) , ApiCredential (..) , ApiErrorCode (..) + , ApiHealthCheck (..) , ApiMaintenanceAction (..) , ApiMaintenanceActionPostData (..) , ApiSelectCoinsAction (..) , ApiSelectCoinsData (..) , ApiStakePool , ApiT (..) + , HealthCheckSMASH (..) , MaintenanceAction (..) , SettingsPutData (..) , SomeByronWalletPostData (..) @@ -128,6 +133,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 +210,7 @@ server byron icarus shelley spl ntp = :<|> network' :<|> proxy :<|> settingS + :<|> smash where wallets :: Server Wallets wallets = deleteWallet shelley @@ -427,6 +435,21 @@ server byron icarus shelley spl ntp = getSettings' = Handler $ fmap ApiT $ liftIO $ getSettings spl + smash :: Server SMASH + smash = getCurrentSmashHealth + where + getHealth smashServer = liftIO $ do + manager <- newManager defaultManagerSettings + health' <- healthCheck mempty (unSmashServer smashServer) manager + pure $ ApiHealthCheck $ toHealthCheckSMASH health' + + getCurrentSmashHealth (Just (ApiT smashServer)) = Handler $ getHealth smashServer + getCurrentSmashHealth Nothing = Handler $ do + settings' <- liftIO $ getSettings spl + case poolMetadataSource settings' of + FetchSMASH smashServer -> getHealth smashServer + _ -> pure (ApiHealthCheck NoSmashConfigured) + postAnyAddress :: NetworkId -> ApiAddressData diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs index 09ca9f3de5b..462014c2503 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs +++ b/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 #-} @@ -45,14 +46,16 @@ import Cardano.Pool.Metadata , defaultManagerSettings , fetchDelistedPools , fetchFromRemote + , healthCheck , identityUrlBuilder , newManager , registryUrlBuilder + , toHealthCheckSMASH ) import Cardano.Wallet ( ErrListPools (..) ) import Cardano.Wallet.Api.Types - ( ApiT (..), toApiEpochInfo ) + ( ApiT (..), HealthCheckSMASH (..), toApiEpochInfo ) import Cardano.Wallet.Byron.Compatibility ( toByronBlockHeader ) import Cardano.Wallet.Network @@ -123,6 +126,8 @@ import Control.Monad.Trans.Except ( ExceptT (..), mapExceptT, runExceptT, throwE, withExceptT ) import Control.Monad.Trans.State ( State, evalState, state ) +import Control.Retry + ( RetryStatus (..), constantDelay, retrying ) import Control.Tracer ( Tracer, contramap, traceWith ) import Data.Bifunctor @@ -163,8 +168,6 @@ import GHC.Conc ( TVar, ThreadId, killThread, newTVarIO, readTVarIO, writeTVar ) import GHC.Generics ( Generic ) -import Network.URI - ( URI (..) ) import Ouroboros.Consensus.Cardano.Block ( CardanoBlock, HardForkBlock (..) ) import System.Random @@ -732,40 +735,51 @@ monitorMetadata gcStatus tr sp db@(DBLayer{..}) = do settings <- atomically readSettings manager <- newManager defaultManagerSettings - 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 (toDelistedPoolsURI uri) manager - tid <- forkFinally - (gcDelistedPools gcStatus tr db getDelistedPools) - onExit - flip finally (killThread tid) $ - loop (fetchThem $ fetcher [registryUrlBuilder uri]) + health <- case poolMetadataSource settings of + FetchSMASH uri -> do + let checkHealth _ = toHealthCheckSMASH + <$> healthCheck trFetch (unSmashServer uri) manager + + maxRetries = 8 + retryCheck RetryStatus{rsIterNumber} b + | rsIterNumber < maxRetries = pure + (b == Unavailable || b == Unreachable) + | otherwise = pure False + + ms = (* 1_000_000) + baseSleepTime = ms 15 + + retrying (constantDelay baseSleepTime) retryCheck checkHealth + + _ -> 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 - -- Currently the SMASH url points to the full API path, e.g. - -- https://smash.cardano-testnet.iohkdev.io/api/v1/monitorMetadata - -- so we need to recover/infer the delisted pools url. - -- TODO: - -- - require the smash URL to only specify scheme and host - -- - use smash servant types to call the endpoints - toDelistedPoolsURI uri = - uri { uriPath = "/api/v1/delisted" , uriQuery = "", uriFragment = "" } - trFetch = contramap MsgFetchPoolMetadata tr -- We mask this entire section just in case, although the database -- operations runs masked anyway. Unfortunately we cannot run @@ -849,6 +863,7 @@ data StakePoolLog | MsgGCThreadKilled | MsgGCUserInterrupt | MsgGCUnhandledException Text + | MsgSMASHUnreachable deriving (Show, Eq) data PoolGarbageCollectionInfo = PoolGarbageCollectionInfo @@ -881,6 +896,7 @@ instance HasSeverityAnnotation StakePoolLog where MsgGCThreadKilled{} -> Debug MsgGCUserInterrupt{} -> Debug MsgGCUnhandledException{} -> Debug + MsgSMASHUnreachable{} -> Warning instance ToText StakePoolLog where toText = \case @@ -933,3 +949,7 @@ instance ToText StakePoolLog where MsgGCUserInterrupt -> "GC thread has exited: killed by user." MsgGCUnhandledException err -> "GC thread has exited unexpectedly: " <> err + MsgSMASHUnreachable -> mconcat + ["The SMASH server is unreachable or unhealthy." + , "Metadata monitoring thread aborting." + ] diff --git a/specifications/api/swagger.yaml b/specifications/api/swagger.yaml index 75b141332e4..5702575ed96 100644 --- a/specifications/api/swagger.yaml +++ b/specifications/api/swagger.yaml @@ -1700,6 +1700,30 @@ components: properties: settings: *settings + ApiSmashServer: &ApiSmashServer + type: string + pattern: '^https?:\/\/[a-zA-Z0-9-_~.]+(:[0-9]+)?/?$' + example: https://smash.cardano-mainnet.iohk.io/ + description: A base SMASH uri without endpoint path. + + ApiHealthCheck: &ApiHealthCheck + type: object + required: + - health + properties: + health: + type: string + enum: ["available", "unavailable", "unreachable", "no_smash_configured"] + description: | + The status of the SMASH server. Possible values are: + + health | description + --- | --- + `"available"` | server is awaiting your requests + `"unavailable"` | server is running, but currently unavailable, try again in a short time + `"unreachable"` | server could not be reached or didn't return a health status + `"no_smash_configured"` | SMASH is currently not configured, adjust the Settings first + ApiWalletPutPassphraseData: &ApiWalletPutPassphraseData type: object required: @@ -3127,6 +3151,14 @@ x-responsesPostSignatures: &responsesPostSignatures type: string format: binary +x-responsesGetSmashHealth: &responsesGetSmashHealth + 200: + description: Ok + content: + application/json: + schema: *ApiHealthCheck + + ############################################################################# # # # PATHS # @@ -3154,6 +3186,7 @@ x-tagGroups: - name: Miscellaneous tags: + - Utils - Network - Proxy - Settings @@ -4068,3 +4101,18 @@ paths: Return the current settings. responses: *responsesGetSettings + + /smash/health: + get: + operationId: getCurrentSmashHealth + tags: ["Utils"] + summary: Current SMASH health + description: | + Get health status of the currently active SMASH server. + parameters: + - in: query + name: url + schema: *ApiSmashServer + required: false + description: check this url for health instead of the currently configured one + responses: *responsesGetSmashHealth