[CAD-2178] The retryCount from the /errors endpoint is not correctly incremented.

schema/migration-2-0005-20201203.sql

@@ -0,0 +1,20 @@
+-- Persistent generated migration.
+
+CREATE FUNCTION migrate() RETURNS void AS $$
+DECLARE
+  next_version int ;
+BEGIN
+  SELECT stage_two + 1 INTO next_version FROM schema_version ;
+  IF next_version = 5 THEN
+    ALTER TABLE "pool_metadata_fetch_error" DROP CONSTRAINT "unique_pool_metadata_fetch_error";
+    ALTER TABLE "pool_metadata_fetch_error" ADD CONSTRAINT "unique_pool_metadata_fetch_error" UNIQUE("fetch_time","pool_id","pool_hash","retry_count");
+    -- Hand written SQL statements can be added here.
+    UPDATE schema_version SET stage_two = 5 ;
+    RAISE NOTICE 'DB has been migrated to stage_two version %', next_version ;
+  END IF ;
+END ;
+$$ LANGUAGE plpgsql ;
+
+SELECT migrate() ;
+
+DROP FUNCTION migrate() ;

smash-servant-types/smash-servant-types.cabal

@@ -53,6 +53,7 @@ library
     , swagger2
     , text
     , time
+    , quiet
     , wai
 
   default-language:   Haskell2010

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

smash-servant-types/src/Cardano/SMASH/Types.hs

@@ -13,6 +13,7 @@ module Cardano.SMASH.Types
     , PoolId (..)
     , PoolUrl (..)
     , PoolMetadataHash (..)
+    , bytestringToPoolMetaHash
     , PoolMetadataRaw (..)
     , TickerName (..)
     -- * Wrapper
@@ -35,6 +36,7 @@ module Cardano.SMASH.Types
     , TimeStringFormat (..)
     -- * Util
     , DBConversion (..)
+    , formatTimeToNormal
     ) where
 
 import           Cardano.Prelude

smash/smash.cabal

@@ -47,7 +47,6 @@ library
     Cardano.SMASH.DBSync.SmashDbSync
     Cardano.SMASH.DBSyncPlugin
     Cardano.SMASH.FetchQueue
-    Cardano.SMASH.FetchQueue.Retry
     Cardano.SMASH.Lib
     Cardano.SMASH.Offline
 
@@ -168,6 +167,7 @@ test-suite smash-test
   build-depends:
       base                      >=4.7 && <5
     , cardano-prelude
+    , iohk-monitoring
     , containers
     , ed25519
     , hspec
@@ -176,6 +176,7 @@ test-suite smash-test
     , smash
     , smash-servant-types
     , tree-diff
+    , transformers-except
 
   default-language:   Haskell2010
   default-extensions:
@@ -214,6 +215,8 @@ test-suite db-spec-test
     , smash-servant-types
     , iohk-monitoring
     , tree-diff
+    , time
+    , transformers-except
 
   default-language:   Haskell2010
   default-extensions:

smash/src/Cardano/SMASH/DBSync/Db/Delete.hs

@@ -11,15 +11,9 @@ import           Cardano.Prelude                hiding (Meta)
 import           Control.Monad.IO.Class         (MonadIO)
 import           Control.Monad.Trans.Reader     (ReaderT)
 
-import           Database.Persist.Class         (AtLeastOneUniqueKey, Key,
-                                                 PersistEntityBackend,
-                                                 checkUnique, getByValue,
-                                                 insert)
 import           Database.Persist.Sql           (SqlBackend, deleteCascade,
                                                  selectKeysList, (==.))
-import           Database.Persist.Types         (entityKey)
 
-import           Cardano.SMASH.DBSync.Db.Error
 import           Cardano.SMASH.DBSync.Db.Schema
 import qualified Cardano.SMASH.DBSync.Db.Types  as Types
 

smash/src/Cardano/SMASH/DBSync/Db/Insert.hs

@@ -16,7 +16,7 @@ module Cardano.SMASH.DBSync.Db.Insert
   , insertByReturnKey
   ) where
 
-import           Cardano.Prelude                hiding (Meta)
+import           Cardano.Prelude                hiding (Meta, replace)
 
 import           Control.Monad.IO.Class         (MonadIO)
 import           Control.Monad.Trans.Reader     (ReaderT, mapReaderT)
@@ -78,12 +78,18 @@ insertPoolMetadataFetchError
     :: (MonadIO m)
     => PoolMetadataFetchError
     -> ReaderT SqlBackend m (Either DBFail PoolMetadataFetchErrorId)
-insertPoolMetadataFetchError = insertByReturnKey
+insertPoolMetadataFetchError pmfe = do
+    isUnique <- checkUnique pmfe
+    -- If there is no unique constraint violated, insert, otherwise delete and insert.
+    case isUnique of
+        Nothing -> insertByReturnKey pmfe
+        Just _key -> return . Left . DbInsertError $ "Pool metadata fetch error already exists!"
 
 -------------------------------------------------------------------------------
 
 -- | Insert a record (with a Unique constraint), and return 'Right key' if the
 -- record is inserted and 'Left key' if the record already exists in the DB.
+-- TODO(KS): This needs to be tested, not sure if it's actually working.
 insertByReturnKey
     :: ( AtLeastOneUniqueKey record
        , MonadIO m
@@ -101,4 +107,3 @@ insertByReturnKey value = do
     exceptionHandler e =
         liftIO . pure . Left . DbInsertError . show $ e
 
-

smash/src/Cardano/SMASH/DBSync/Db/Query.hs

@@ -211,15 +211,15 @@ queryPoolMetadataFetchErrorByTime
 queryPoolMetadataFetchErrorByTime poolId Nothing = do
   res <- select . from $ \(poolMetadataFetchError :: SqlExpr (Entity PoolMetadataFetchError)) -> do
             where_ (poolMetadataFetchError ^. PoolMetadataFetchErrorPoolId ==. val poolId)
-
+            orderBy [desc (poolMetadataFetchError ^. PoolMetadataFetchErrorFetchTime)]
             pure $ poolMetadataFetchError
   pure $ fmap entityVal res
 
 queryPoolMetadataFetchErrorByTime poolId (Just fromTime) = do
   res <- select . from $ \(poolMetadataFetchError :: SqlExpr (Entity PoolMetadataFetchError)) -> do
             where_ (poolMetadataFetchError ^. PoolMetadataFetchErrorPoolId ==. val poolId
                 &&. poolMetadataFetchError ^. PoolMetadataFetchErrorFetchTime >=. val fromTime)
-
+            orderBy [desc (poolMetadataFetchError ^. PoolMetadataFetchErrorFetchTime)]
             pure $ poolMetadataFetchError
   pure $ fmap entityVal res
 

smash/src/Cardano/SMASH/DBSync/Db/Schema.hs

@@ -95,7 +95,7 @@ share
     pmrId               PoolMetadataReferenceId
     fetchError          Text
     retryCount          Word                      sqltype=uinteger
-    UniquePoolMetadataFetchError fetchTime poolId
+    UniquePoolMetadataFetchError fetchTime poolId poolHash retryCount
 
   -- We actually need the block table to be able to persist sync data
 

smash/src/Cardano/SMASH/DBSyncPlugin.hs

@@ -201,3 +201,4 @@ insertPoolRegister dataLayer tracer params = do
 
   liftIO . logInfo tracer $ "Inserted pool register."
   pure ()
+

smash/src/Cardano/SMASH/FetchQueue.hs

@@ -1,64 +1,68 @@
+{-# LANGUAGE DeriveGeneric #-}
+
 module Cardano.SMASH.FetchQueue
-  ( FetchQueue -- opaque
-  , PoolFetchRetry (..)
-  , Retry -- opaque
-  , retryCount
-  , emptyFetchQueue
-  , lenFetchQueue
-  , nullFetchQueue
-  , insertFetchQueue
-  , partitionFetchQueue
+  ( PoolFetchRetry (..)
+  , Retry (..)
   , newRetry
-  , nextRetry
+  , retryAgain
+  , showRetryTimes
   ) where
 
 
 import           Cardano.Prelude
 
-import           Data.Map.Strict                (Map)
-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.FetchQueue.Retry
-
-
--- Unfortunately I am way too pressed for time and way too tired to make this less savage.
--- 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)
+import           Cardano.SMASH.DBSync.Db.Types  (PoolId, PoolMetadataHash,
+                                                 PoolUrl)
+import           Cardano.SMASH.Types            (formatTimeToNormal)
 
 data PoolFetchRetry = PoolFetchRetry
   { pfrReferenceId :: !PoolMetadataReferenceId
   , pfrPoolIdWtf   :: !PoolId
-  , pfrPoolUrl     :: !Text
-  , pfrPoolMDHash  :: !ByteString
+  , pfrPoolUrl     :: !PoolUrl
+  , pfrPoolMDHash  :: !PoolMetadataHash
   , pfrRetry       :: !Retry
-  }
+  } deriving (Show)
 
-emptyFetchQueue :: FetchQueue
-emptyFetchQueue = FetchQueue mempty
+data Retry = Retry
+  { fetchTime  :: !POSIXTime
+  , retryTime  :: !POSIXTime
+  , retryCount :: !Word
+  } deriving (Eq, Show, Generic)
 
-lenFetchQueue :: FetchQueue -> Int
-lenFetchQueue (FetchQueue m) = Map.size m
+newRetry :: POSIXTime -> Retry
+newRetry now =
+  Retry
+    { fetchTime = now
+    , retryTime = now + 60 -- 60 seconds from now
+    , retryCount = 0
+    }
 
-nullFetchQueue :: FetchQueue -> Bool
-nullFetchQueue (FetchQueue m) = Map.null m
+retryAgain :: POSIXTime -> Word -> Retry
+retryAgain fetchTimePOSIX existingRetryCount =
+    -- When to retry. Maximum of a day for a retry.
+    -- We are basically using a series to predict the next retry time.
+    let calculateNewDiff currRetryCount = min (24 * 60 * 60) ((3 ^ currRetryCount) * 60)
+        newRetryDiff = sum $ map calculateNewDiff [0..existingRetryCount]
+    in
+        Retry
+            { fetchTime = fetchTimePOSIX
+            , retryTime = fetchTimePOSIX + newRetryDiff
+            , retryCount = existingRetryCount
+            }
 
-insertFetchQueue :: [PoolFetchRetry] -> FetchQueue -> FetchQueue
-insertFetchQueue xs (FetchQueue mp) =
-    FetchQueue $ Map.union mp (Map.fromList $ map build xs)
-  where
-    build :: PoolFetchRetry -> (Text, PoolFetchRetry)
-    build pfr = (pfrPoolUrl pfr, pfr)
+-- A nice pretty printer for the retry.
+showRetryTimes :: Retry -> Text
+showRetryTimes retry' =
+    mconcat
+        [ "Fetch time: '"
+        , formatTimeToNormal $ fetchTime retry'
+        , "', retry time: '"
+        , formatTimeToNormal $ retryTime retry'
+        , "', retry count: '"
+        , show $ retryCount retry'
+        , "'."
+        ]
 
-partitionFetchQueue :: FetchQueue -> POSIXTime -> ([PoolFetchRetry], FetchQueue)
-partitionFetchQueue (FetchQueue mp) now =
-    case Map.partition isRunnable mp of
-      (runnable, unrunnable) -> (Map.elems runnable, FetchQueue unrunnable)
-  where
-    isRunnable :: PoolFetchRetry -> Bool
-    isRunnable pfr = retryWhen (pfrRetry pfr) <= now