From 4983433a3af5475f9f06edc0dbd09c4c4307982b Mon Sep 17 00:00:00 2001 From: ksaric Date: Tue, 1 Dec 2020 20:48:31 +0100 Subject: [PATCH] [CAD-2178] The retryCount from the /errors endpoint is not correctly incremented. --- smash-servant-types/smash-servant-types.cabal | 1 + .../src/Cardano/SMASH/DBSync/Db/Types.hs | 20 +- .../src/Cardano/SMASH/Types.hs | 1 + smash/smash.cabal | 4 + smash/src/Cardano/SMASH/DBSyncPlugin.hs | 1 + smash/src/Cardano/SMASH/FetchQueue.hs | 17 +- smash/src/Cardano/SMASH/FetchQueue/Retry.hs | 9 + smash/src/Cardano/SMASH/Offline.hs | 220 +++++++++++------- smash/test/MigrationSpec.hs | 60 ++++- smash/test/SmashSpec.hs | 10 +- 10 files changed, 244 insertions(+), 99 deletions(-) diff --git a/smash-servant-types/smash-servant-types.cabal b/smash-servant-types/smash-servant-types.cabal index 14f70e9..3e36d59 100644 --- a/smash-servant-types/smash-servant-types.cabal +++ b/smash-servant-types/smash-servant-types.cabal @@ -53,6 +53,7 @@ library , swagger2 , text , time + , quiet , wai default-language: Haskell2010 diff --git a/smash-servant-types/src/Cardano/SMASH/DBSync/Db/Types.hs b/smash-servant-types/src/Cardano/SMASH/DBSync/Db/Types.hs index 935cb08..2a580ab 100644 --- a/smash-servant-types/src/Cardano/SMASH/DBSync/Db/Types.hs +++ b/smash-servant-types/src/Cardano/SMASH/DBSync/Db/Types.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralisedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DerivingVia #-} module Cardano.SMASH.DBSync.Db.Types where @@ -17,13 +18,16 @@ import Cardano.Api.Typed hiding (PoolId) import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString.Char8 as BSC +import Quiet (Quiet (..)) + -- | The stake pool identifier. It is the hash of the stake pool operator's -- vkey. -- -- It may be rendered as hex or as bech32 using the @pool@ prefix. -- newtype PoolId = PoolId { getPoolId :: Text } - deriving stock (Eq, Show, Ord, Generic) + deriving stock (Eq, Ord, Generic) + deriving Show via (Quiet PoolId) deriving newtype PersistField instance ToJSON PoolId where @@ -71,7 +75,8 @@ parsePoolId poolId = -- It may be rendered as hex. -- newtype PoolMetadataHash = PoolMetadataHash { getPoolMetadataHash :: Text } - deriving stock (Eq, Show, Ord, Generic) + deriving stock (Eq, Ord, Generic) + deriving Show via (Quiet PoolMetadataHash) deriving newtype PersistField instance ToJSON PoolMetadataHash where @@ -87,6 +92,11 @@ instance FromJSON PoolMetadataHash where poolHash <- o .: "poolHash" return $ PoolMetadataHash poolHash +-- Converting the basic type to a strong one. +-- Presumes the user knows what he is doing, NOT TYPE SAFE! +bytestringToPoolMetaHash :: ByteString -> PoolMetadataHash +bytestringToPoolMetaHash bs = PoolMetadataHash . decodeUtf8 . B16.encode $ bs + -- | The stake pool metadata. It is JSON format. This type represents it in -- its raw original form. The hash of this content is the 'PoolMetadataHash'. newtype PoolMetadataRaw = PoolMetadataRaw { getPoolMetadata :: Text } @@ -95,12 +105,14 @@ newtype PoolMetadataRaw = PoolMetadataRaw { getPoolMetadata :: Text } -- | The pool url wrapper so we have some additional safety. newtype PoolUrl = PoolUrl { getPoolUrl :: Text } - deriving stock (Eq, Show, Ord, Generic) + deriving stock (Eq, Ord, Generic) + deriving Show via (Quiet PoolUrl) deriving newtype PersistField -- | The ticker name wrapper so we have some additional safety. newtype TickerName = TickerName { getTickerName :: Text } - deriving stock (Eq, Show, Ord, Generic) + deriving stock (Eq, Ord, Generic) + deriving Show via (Quiet TickerName) deriving newtype PersistField instance ToJSON TickerName where diff --git a/smash-servant-types/src/Cardano/SMASH/Types.hs b/smash-servant-types/src/Cardano/SMASH/Types.hs index abbb0ad..d822a5e 100644 --- a/smash-servant-types/src/Cardano/SMASH/Types.hs +++ b/smash-servant-types/src/Cardano/SMASH/Types.hs @@ -13,6 +13,7 @@ module Cardano.SMASH.Types , PoolId (..) , PoolUrl (..) , PoolMetadataHash (..) + , bytestringToPoolMetaHash , PoolMetadataRaw (..) , TickerName (..) -- * Wrapper diff --git a/smash/smash.cabal b/smash/smash.cabal index cc5f23a..c8d7d89 100644 --- a/smash/smash.cabal +++ b/smash/smash.cabal @@ -168,6 +168,7 @@ test-suite smash-test build-depends: base >=4.7 && <5 , cardano-prelude + , iohk-monitoring , containers , ed25519 , hspec @@ -176,6 +177,7 @@ test-suite smash-test , smash , smash-servant-types , tree-diff + , transformers-except default-language: Haskell2010 default-extensions: @@ -214,6 +216,8 @@ test-suite db-spec-test , smash-servant-types , iohk-monitoring , tree-diff + , time + , transformers-except default-language: Haskell2010 default-extensions: diff --git a/smash/src/Cardano/SMASH/DBSyncPlugin.hs b/smash/src/Cardano/SMASH/DBSyncPlugin.hs index d2aa560..2bfaffb 100644 --- a/smash/src/Cardano/SMASH/DBSyncPlugin.hs +++ b/smash/src/Cardano/SMASH/DBSyncPlugin.hs @@ -201,3 +201,4 @@ insertPoolRegister dataLayer tracer params = do liftIO . logInfo tracer $ "Inserted pool register." pure () + diff --git a/smash/src/Cardano/SMASH/FetchQueue.hs b/smash/src/Cardano/SMASH/FetchQueue.hs index b8e7775..abd8cdd 100644 --- a/smash/src/Cardano/SMASH/FetchQueue.hs +++ b/smash/src/Cardano/SMASH/FetchQueue.hs @@ -1,7 +1,7 @@ module Cardano.SMASH.FetchQueue ( FetchQueue -- opaque , PoolFetchRetry (..) - , Retry -- opaque + , Retry (..) , retryCount , emptyFetchQueue , lenFetchQueue @@ -10,6 +10,7 @@ module Cardano.SMASH.FetchQueue , partitionFetchQueue , newRetry , nextRetry + , countedRetry ) where @@ -20,7 +21,8 @@ import qualified Data.Map.Strict as Map import Data.Time.Clock.POSIX (POSIXTime) import Cardano.SMASH.DBSync.Db.Schema (PoolMetadataReferenceId) -import Cardano.SMASH.DBSync.Db.Types (PoolId) +import Cardano.SMASH.DBSync.Db.Types (PoolId, PoolMetadataHash, + PoolUrl) import Cardano.SMASH.FetchQueue.Retry @@ -29,15 +31,16 @@ import Cardano.SMASH.FetchQueue.Retry -- Figuring out how to use an existing priority queue for this task would be more time -- consuming that writing this from scratch. -newtype FetchQueue = FetchQueue (Map Text PoolFetchRetry) +newtype FetchQueue = FetchQueue (Map PoolUrl PoolFetchRetry) + deriving (Show) data PoolFetchRetry = PoolFetchRetry { pfrReferenceId :: !PoolMetadataReferenceId , pfrPoolIdWtf :: !PoolId - , pfrPoolUrl :: !Text - , pfrPoolMDHash :: !ByteString + , pfrPoolUrl :: !PoolUrl + , pfrPoolMDHash :: !PoolMetadataHash , pfrRetry :: !Retry - } + } deriving (Show) emptyFetchQueue :: FetchQueue emptyFetchQueue = FetchQueue mempty @@ -52,7 +55,7 @@ insertFetchQueue :: [PoolFetchRetry] -> FetchQueue -> FetchQueue insertFetchQueue xs (FetchQueue mp) = FetchQueue $ Map.union mp (Map.fromList $ map build xs) where - build :: PoolFetchRetry -> (Text, PoolFetchRetry) + build :: PoolFetchRetry -> (PoolUrl, PoolFetchRetry) build pfr = (pfrPoolUrl pfr, pfr) partitionFetchQueue :: FetchQueue -> POSIXTime -> ([PoolFetchRetry], FetchQueue) diff --git a/smash/src/Cardano/SMASH/FetchQueue/Retry.hs b/smash/src/Cardano/SMASH/FetchQueue/Retry.hs index a4d7a31..0975019 100644 --- a/smash/src/Cardano/SMASH/FetchQueue/Retry.hs +++ b/smash/src/Cardano/SMASH/FetchQueue/Retry.hs @@ -5,6 +5,7 @@ module Cardano.SMASH.FetchQueue.Retry ( Retry (..) , newRetry , nextRetry + , countedRetry ) where @@ -32,6 +33,14 @@ newRetry now = , retryCount = 0 } +countedRetry :: Retry -> Retry +countedRetry retry = + Retry + { retryWhen = retryWhen retry + , retryNext = retryNext retry + , retryCount = retryCount retry + 1 + } + -- Update a Retry with an exponential (* 3) backoff. nextRetry :: POSIXTime -> Retry -> Retry nextRetry now r = diff --git a/smash/src/Cardano/SMASH/Offline.hs b/smash/src/Cardano/SMASH/Offline.hs index 59aa80c..f37562a 100644 --- a/smash/src/Cardano/SMASH/Offline.hs +++ b/smash/src/Cardano/SMASH/Offline.hs @@ -1,20 +1,24 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} module Cardano.SMASH.Offline ( fetchInsertNewPoolMetadata + , fetchInsertNewPoolMetadataOld , runOfflineFetchThread ) where -import Cardano.Prelude hiding (from, groupBy, retry) +import Cardano.Prelude hiding (from, groupBy, retry, on) import Cardano.BM.Trace (Trace, logInfo, logWarning) import Control.Concurrent (threadDelay) +import Control.Monad.Logger (LoggingT) import Control.Monad.Trans.Except.Extra (handleExceptT, hoistEither, left) -import Cardano.SMASH.DB (DataLayer (..), +import Cardano.SMASH.DB (DataLayer (..), PoolMetadata, PoolMetadataFetchError (..), PoolMetadataReference (..), PoolMetadataReferenceId, @@ -26,6 +30,8 @@ import Cardano.SMASH.Types (FetchError (..), PoolId (..), PoolMetadataHash (..), PoolMetadataRaw (..), + PoolUrl (..), + bytestringToPoolMetaHash, getPoolMetadataHash, getPoolUrl, pomTicker) @@ -42,11 +48,12 @@ import qualified Cardano.SMASH.DBSync.Db.Schema as DB import qualified Data.ByteString.Base16 as B16 -import Database.Esqueleto (Entity (..), SqlExpr, - ValueList, entityKey, - entityVal, from, groupBy, - in_, just, max_, notExists, - select, subList_select, +import Database.Esqueleto (Entity (..), InnerJoin (..), + SqlExpr, Value, ValueList, + entityKey, entityVal, from, + groupBy, in_, just, max_, + notExists, on, select, + subList_select, unValue, where_, (==.), (^.)) import Database.Persist.Sql (SqlBackend) @@ -58,6 +65,7 @@ import qualified Network.HTTP.Types.Status as Http import qualified Shelley.Spec.Ledger.BaseTypes as Shelley import qualified Shelley.Spec.Ledger.TxData as Shelley + -- This is an incredibly rough hack that adds asynchronous fetching of offline metadata. -- This is not my best work. @@ -70,33 +78,36 @@ fetchInsertNewPoolMetadata -> IO () fetchInsertNewPoolMetadata dataLayer tracer refId poolId md = do now <- Time.getPOSIXTime - void . fetchInsertNewPoolMetadataOld dataLayer tracer $ + void . fetchInsertNewPoolMetadataOld dataLayer tracer fetchInsertDefault $ PoolFetchRetry { pfrReferenceId = refId , pfrPoolIdWtf = poolId - , pfrPoolUrl = Shelley.urlToText (Shelley._poolMDUrl md) - , pfrPoolMDHash = Shelley._poolMDHash md + , pfrPoolUrl = PoolUrl . Shelley.urlToText . Shelley._poolMDUrl $ md + , pfrPoolMDHash = bytestringToPoolMetaHash . Shelley._poolMDHash $ md , pfrRetry = newRetry now } fetchInsertNewPoolMetadataOld :: DataLayer -> Trace IO Text + -> (PoolId -> Trace IO Text -> PoolFetchRetry -> ExceptT FetchError IO ()) -> PoolFetchRetry -> IO (Maybe PoolFetchRetry) -fetchInsertNewPoolMetadataOld dataLayer tracer pfr = do +fetchInsertNewPoolMetadataOld dataLayer tracer fetchInsert pfr = do -- We extract the @PoolId@ before so we can map the error to that @PoolId@. let poolId = pfrPoolIdWtf pfr - res <- runExceptT (fetchInsert poolId) + res <- runExceptT (fetchInsert poolId tracer pfr) + -- In the case all went well, we do nothing, but if something went wrong + -- we log that and add the error to the database. case res of Right () -> pure Nothing Left err -> do - let poolHash = PoolMetadataHash . decodeUtf8 . B16.encode $ pfrPoolMDHash pfr + let poolHash = pfrPoolMDHash pfr let poolMetadataReferenceId = pfrReferenceId pfr let fetchError = renderFetchError err - let currRetryCount = retryCount $ pfrRetry pfr + let currRetryCount = 1 + (retryCount $ pfrRetry pfr) -- Update retry timeout here as a psuedo-randomisation of retry. now <- Time.getPOSIXTime @@ -116,82 +127,114 @@ fetchInsertNewPoolMetadataOld dataLayer tracer pfr = do logWarning tracer fetchError + -- Here we update the the time to update. pure . Just $ pfr { pfrRetry = nextRetry now (pfrRetry pfr) } - where - -- |We pass in the @PoolId@ so we can know from which pool the error occured. - fetchInsert :: PoolId -> ExceptT FetchError IO () - fetchInsert poolId = do - -- This is a bit bad to do each time, but good enough for now. - manager <- liftIO $ Http.newManager tlsManagerSettings - let poolMetadataURL = pfrPoolUrl pfr +-- |We pass in the @PoolId@ so we can know from which pool the error occured. +fetchInsertDefault + :: PoolId + -> Trace IO Text + -> PoolFetchRetry + -> ExceptT FetchError IO () +fetchInsertDefault poolId tracer pfr = do + -- This is a bit bad to do each time, but good enough for now. + manager <- liftIO $ Http.newManager tlsManagerSettings + + let poolMetadataURL = getPoolUrl $ pfrPoolUrl pfr - liftIO . logInfo tracer $ "Request: " <> poolMetadataURL + liftIO . logInfo tracer $ "Request URL: " <> poolMetadataURL - request <- handleExceptT (\(_ :: HttpException) -> FEUrlParseFail poolId poolMetadataURL (pfrPoolUrl pfr)) - $ Http.parseRequest (toS $ pfrPoolUrl pfr) + -- This is a weird Error. + request <- handleExceptT (\(_ :: HttpException) -> FEUrlParseFail poolId poolMetadataURL poolMetadataURL) + $ Http.parseRequest (toS poolMetadataURL) - (respBS, status) <- httpGetMax512Bytes poolId poolMetadataURL request manager + (respBS, status) <- httpGetMax512Bytes poolId poolMetadataURL request manager - when (Http.statusCode status /= 200) . - left $ FEHttpResponse poolId poolMetadataURL (Http.statusCode status) + when (Http.statusCode status /= 200) . + left $ FEHttpResponse poolId poolMetadataURL (Http.statusCode status) - liftIO . logInfo tracer $ "Response: " <> show (Http.statusCode status) + liftIO . logInfo tracer $ "Response: " <> show (Http.statusCode status) - decodedMetadata <- case eitherDecode' (LBS.fromStrict respBS) of - Left err -> left $ FEJsonDecodeFail poolId poolMetadataURL (toS err) - Right result -> pure result + decodedMetadata <- case eitherDecode' (LBS.fromStrict respBS) of + Left err -> left $ FEJsonDecodeFail poolId poolMetadataURL (toS err) + Right result -> pure result - -- Let's check the hash - let hashFromMetadata = Crypto.digest (Proxy :: Proxy Crypto.Blake2b_256) respBS - expectedHash = renderByteStringHex (pfrPoolMDHash pfr) + -- Let's check the hash + let hashFromMetadata = Crypto.digest (Proxy :: Proxy Crypto.Blake2b_256) respBS + expectedHash = getPoolMetadataHash (pfrPoolMDHash pfr) - if hashFromMetadata /= pfrPoolMDHash pfr - then left $ FEHashMismatch poolId expectedHash (renderByteStringHex hashFromMetadata) poolMetadataURL - else liftIO . logInfo tracer $ "Inserting pool data with hash: " <> expectedHash + if (bytestringToPoolMetaHash hashFromMetadata) /= pfrPoolMDHash pfr + then left $ FEHashMismatch poolId expectedHash (renderByteStringHex hashFromMetadata) poolMetadataURL + else liftIO . logInfo tracer $ "Inserting pool data with hash: " <> expectedHash - let addPoolMetadata = dlAddPoolMetadata postgresqlDataLayer + let addPoolMetadata = dlAddPoolMetadata postgresqlDataLayer - _ <- liftIO $ - addPoolMetadata + _ <- liftIO $ + addPoolMetadata (Just $ pfrReferenceId pfr) (pfrPoolIdWtf pfr) - (PoolMetadataHash . renderByteStringHex $ pfrPoolMDHash pfr) + (pfrPoolMDHash pfr) (PoolMetadataRaw $ decodeUtf8 respBS) (pomTicker decodedMetadata) - liftIO $ logInfo tracer (decodeUtf8 respBS) + liftIO $ logInfo tracer (decodeUtf8 respBS) runOfflineFetchThread :: Trace IO Text -> IO () runOfflineFetchThread trce = do liftIO $ logInfo trce "Runing Offline fetch thread" - fetchLoop postgresqlDataLayer trce emptyFetchQueue + fetchLoop postgresqlDataLayer FetchLoopForever trce queryPoolFetchRetryDefault emptyFetchQueue + +--------------------------------------------------------------------------------------------------- + +data FetchLoopType + = FetchLoopForever + | FetchLoopOnce + deriving (Eq, Show) --- ------------------------------------------------------------------------------------------------- +isFetchLoopForever :: FetchLoopType -> Bool +isFetchLoopForever FetchLoopForever = True +isFetchLoopForever FetchLoopOnce = False -fetchLoop :: DataLayer -> Trace IO Text -> FetchQueue -> IO () -fetchLoop dataLayer trce = - loop +fetchLoop + :: forall m. MonadIO m + => DataLayer + -> FetchLoopType + -> Trace IO Text + -> (Retry -> ReaderT SqlBackend (LoggingT IO) [PoolFetchRetry]) -- This should be in the @DataLayer@ + -> FetchQueue + -> m () +fetchLoop dataLayer fetchLoopType trce queryPoolFetchRetry fetchQueue = + loop fetchQueue where - loop :: FetchQueue -> IO () + loop :: FetchQueue -> m () loop fq = do - now <- Time.getPOSIXTime - pools <- runDbAction Nothing $ queryPoolFetchRetry (newRetry now) + now <- liftIO $ Time.getPOSIXTime + + -- Fetch all pools that have not been run with success. + -- This has to be stateful in order to count. + pools <- liftIO $ runDbAction (Just trce) $ queryPoolFetchRetry (newRetry now) + let newFq = insertFetchQueue pools fq (runnable, unrunnable) = partitionFetchQueue newFq now - logInfo trce $ + + liftIO $ logInfo trce $ mconcat [ "fetchLoop: ", show (length runnable), " runnable, " , show (lenFetchQueue unrunnable), " pending" ] + if null runnable then do - threadDelay (20 * 1000 * 1000) -- 20 seconds - loop unrunnable + liftIO $ threadDelay 20_000_000 -- 20 seconds + + -- If it loops forever then loop, else finish. For testing. + if isFetchLoopForever fetchLoopType + then loop unrunnable + else pure () else do liftIO $ logInfo trce $ "Pools without offline metadata: " <> show (length runnable) - rs <- catMaybes <$> mapM (fetchInsertNewPoolMetadataOld dataLayer trce) runnable - loop $ insertFetchQueue rs unrunnable + poolsMetaWithError <- liftIO $ catMaybes <$> mapM (fetchInsertNewPoolMetadataOld dataLayer trce fetchInsertDefault) runnable + loop $ insertFetchQueue poolsMetaWithError unrunnable httpGetMax512Bytes :: PoolId @@ -224,39 +267,52 @@ convertHttpException poolId poolMetadataURL he = other -> FEHttpException poolId poolMetadataURL (show other) InvalidUrlException url _ -> FEUrlParseFail poolId poolMetadataURL (Text.pack url) --- select * from pool_metadata_reference --- where id in (select max(id) from pool_metadata_reference group by pool_id) --- and not exists (select * from pool_metadata where pmr_id = pool_metadata_reference.id) ; +-- select * from pool_metadata_fetch_error pmfr +-- where pmfr.id in (select max(id) from pool_metadata_fetch_error group by pool_id, pool_hash) +-- and not exists (select * from pool_metadata where pmr_id = pmfr.pmr_id); -- Get a list of the pools for which there is a PoolMetadataReference entry but there is -- no PoolMetadata entry. -- This is a bit questionable because it assumes that the autogenerated 'id' primary key -- is a reliable proxy for time, ie higher 'id' was added later in time. -queryPoolFetchRetry :: MonadIO m => Retry -> ReaderT SqlBackend m [PoolFetchRetry] -queryPoolFetchRetry retry = do - res <- select . from $ \ pmr -> do - where_ (just (pmr ^. DB.PoolMetadataReferenceId) `in_` latestReferences) - where_ (notExists . from $ \ pod -> where_ (pod ^. DB.PoolMetadataPmrId ==. just (pmr ^. DB.PoolMetadataReferenceId))) - pure pmr - pure $ map convert res +queryPoolFetchRetryDefault :: MonadIO m => Retry -> ReaderT SqlBackend m [PoolFetchRetry] +queryPoolFetchRetryDefault retry = do + + pmfr <- select . from $ \((pmfr :: SqlExpr (Entity PoolMetadataFetchError)) `InnerJoin` (pmr :: SqlExpr (Entity PoolMetadataReference))) -> do + on (pmfr ^. DB.PoolMetadataFetchErrorPmrId ==. pmr ^. DB.PoolMetadataReferenceId) + where_ (just (pmfr ^. DB.PoolMetadataFetchErrorId) `in_` latestReferences) + where_ (notExists . from $ \pod -> where_ (pod ^. DB.PoolMetadataPmrId ==. just (pmfr ^. DB.PoolMetadataFetchErrorPmrId))) + + pure + ( pmfr ^. DB.PoolMetadataFetchErrorPmrId + , pmfr ^. DB.PoolMetadataFetchErrorPoolId + , pmr ^. DB.PoolMetadataReferenceUrl + , pmfr ^. DB.PoolMetadataFetchErrorPoolHash + , pmfr ^. DB.PoolMetadataFetchErrorRetryCount + ) + + pure $ map (convert . unValue5) pmfr where - latestReferences :: SqlExpr (ValueList (Maybe PoolMetadataReferenceId)) + latestReferences :: SqlExpr (ValueList (Maybe DB.PoolMetadataFetchErrorId)) latestReferences = - subList_select . from $ \ pfr -> do - groupBy (pfr ^. DB.PoolMetadataReferencePoolId) - pure $ max_ (pfr ^. DB.PoolMetadataReferenceId) + subList_select . from $ \(pmfr :: SqlExpr (Entity PoolMetadataFetchError)) -> do + groupBy (pmfr ^. DB.PoolMetadataFetchErrorPoolId, pmfr ^. DB.PoolMetadataFetchErrorPoolHash) + pure $ max_ (pmfr ^. DB.PoolMetadataFetchErrorId) - convert :: Entity PoolMetadataReference -> PoolFetchRetry - convert entity = - let pmr = entityVal entity in + convert :: (PoolMetadataReferenceId, PoolId, PoolUrl, PoolMetadataHash, Word) -> PoolFetchRetry + convert (poolMetadataReferenceId, poolId, poolUrl, poolMetadataHash, existingRetryCount) = PoolFetchRetry - { pfrReferenceId = entityKey entity - , pfrPoolIdWtf = DB.poolMetadataReferencePoolId pmr - , pfrPoolUrl = getPoolUrl $ poolMetadataReferenceUrl pmr - , pfrPoolMDHash = fst . B16.decode . encodeUtf8 $ getPoolMetadataHash (poolMetadataReferenceHash pmr) - , pfrRetry = retry + { pfrReferenceId = poolMetadataReferenceId + , pfrPoolIdWtf = poolId + , pfrPoolUrl = poolUrl + , pfrPoolMDHash = poolMetadataHash + , pfrRetry = retry { retryCount = existingRetryCount } } + unValue5 :: (Value a, Value b, Value c, Value d, Value e) -> (a, b, c, d, e) + unValue5 (a, b, c, d, e) = (unValue a, unValue b, unValue c, unValue d, unValue e) + + renderByteStringHex :: ByteString -> Text renderByteStringHex = Text.decodeUtf8 . B16.encode @@ -294,7 +350,7 @@ renderFetchError fe = ] FEJsonDecodeFail poolId poolMetaUrl err -> mconcat - [ "JSON decode error from poolId " + [ "JSON decode error from poolId '" , getPoolId poolId , "' when fetching metadata from '" , poolMetaUrl @@ -303,7 +359,7 @@ renderFetchError fe = ] FEHttpException poolId poolMetaUrl err -> mconcat - [ "HTTP Exception from poolId " + [ "HTTP Exception from poolId '" , getPoolId poolId , "' when fetching metadata from '" , poolMetaUrl @@ -312,7 +368,7 @@ renderFetchError fe = ] FEHttpResponse poolId poolMetaUrl sc -> mconcat - [ "HTTP Response from poolId " + [ "HTTP Response from poolId '" , getPoolId poolId , "' when fetching metadata from '" , poolMetaUrl @@ -322,7 +378,7 @@ renderFetchError fe = FETimeout poolId poolMetaUrl ctx -> mconcat [ ctx - , " timeout from poolId " + , " timeout from poolId '" , getPoolId poolId , "' when fetching metadata from '" , poolMetaUrl @@ -330,7 +386,7 @@ renderFetchError fe = ] FEConnectionFailure poolId poolMetaUrl -> mconcat - [ "Connection failure from poolId " + [ "Connection failure from poolId '" , getPoolId poolId , "' when fetching metadata from '" , poolMetaUrl diff --git a/smash/test/MigrationSpec.hs b/smash/test/MigrationSpec.hs index 4e4656b..dc36386 100644 --- a/smash/test/MigrationSpec.hs +++ b/smash/test/MigrationSpec.hs @@ -7,17 +7,28 @@ module MigrationSpec import Cardano.Prelude +import Control.Monad.Trans.Except.Extra (left) +import Data.Time.Clock.POSIX (getPOSIXTime) + import Test.Hspec (Spec, describe) import Test.Hspec.QuickCheck (modifyMaxSuccess, prop) import Test.QuickCheck.Monadic (assert, monadicIO, run) import qualified Cardano.BM.Trace as Logging + +import Cardano.SMASH.FetchQueue +import Cardano.SMASH.Offline +import Cardano.SMASH.Types + +import Cardano.SMASH.DB +import Cardano.SMASH.DBSync.Db.Insert (insertPoolMetadataReference) import Cardano.SMASH.DBSync.Db.Migration (SmashLogFileDir (..), SmashMigrationDir (..), runMigrations) import Cardano.SMASH.DBSync.Db.Query (querySchemaVersion) import Cardano.SMASH.DBSync.Db.Run (runDbNoLogging) -import Cardano.SMASH.DBSync.Db.Schema (SchemaVersion (..)) +import Cardano.SMASH.DBSync.Db.Schema (PoolMetadataReference (..), + SchemaVersion (..)) -- | Test spec for smash -- SMASHPGPASSFILE=config/pgpass-test ./scripts/postgresql-setup.sh --createdb @@ -28,6 +39,53 @@ migrationSpec = do _ <- run migrationTest assert True + describe "FetchQueueSpec" $ do + describe "Retry count" $ + prop "retrying again increases the retry count" $ \initialCount -> monadicIO $ do + + -- Probably switch to @DataLayer@ + poolMetadataRefIdE <- run $ runDbNoLogging $ insertPoolMetadataReference $ PoolMetadataReference (PoolId "1") (PoolUrl "http://test.com") (PoolMetadataHash "hash") + + poolMetadataRefId <- case poolMetadataRefIdE of + Left err -> panic $ show err + Right id -> return id + + timeNow <- run $ getPOSIXTime --secondsToNominalDiffTime timeNowInt + + let retry = + Retry + { retryWhen = timeNow + , retryNext = timeNow + , retryCount = initialCount + } + + let poolFetchRetry = + PoolFetchRetry + { pfrReferenceId = poolMetadataRefId + , pfrPoolIdWtf = PoolId "1" + , pfrPoolUrl = PoolUrl "http://test.com" + , pfrPoolMDHash = PoolMetadataHash "hash" + , pfrRetry = retry + } + + + let dataLayer = postgresqlDataLayer +-- DataLayer +-- { dlAddFetchError = \poolMetadataFetchError -> return $ Right poolMetadataRefId +-- } + + let fetchInsert = \_ _ _ -> left $ FEIOException "Dunno" + + mPool <- run $ fetchInsertNewPoolMetadataOld dataLayer Logging.nullTracer fetchInsert poolFetchRetry + + assert $ isJust mPool + + let pool = fromMaybe (panic "!") mPool + let newRetryCount = retryCount (pfrRetry pool) + + assert $ newRetryCount == initialCount + 1 + + -- Really just make sure that the migrations do actually run correctly. -- If they fail the file path of the log file (in /tmp) will be printed. migrationTest :: IO () diff --git a/smash/test/SmashSpec.hs b/smash/test/SmashSpec.hs index f34c254..c2c4c5e 100644 --- a/smash/test/SmashSpec.hs +++ b/smash/test/SmashSpec.hs @@ -8,12 +8,11 @@ module SmashSpec import Cardano.Prelude import Crypto.Sign.Ed25519 (createKeypair) -import Data.IORef (IORef, newIORef) -import Test.Hspec (Spec, describe, it, pending) -import Test.Hspec.QuickCheck (modifyMaxSuccess, prop) -import Test.QuickCheck (Arbitrary (..), Gen, Property, - elements, generate, listOf) +import Test.Hspec (Spec, describe) +import Test.Hspec.QuickCheck (prop) + +import Test.QuickCheck (Arbitrary (..), Gen, elements, listOf) import Test.QuickCheck.Monadic (assert, monadicIO, run) import Cardano.SMASH.DB @@ -22,6 +21,7 @@ import Cardano.SMASH.Types -- | Test spec for smash smashSpec :: Spec smashSpec = do + describe "DataLayer" $ do describe "Delisted pool" $ prop "adding a pool hash adds it to the data layer" $ monadicIO $ do