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

…incremented.

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

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:

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,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)

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 =