diff --git a/doc/getting-started/how-to-install-smash.md b/doc/getting-started/how-to-install-smash.md index d425b6a..a9d8952 100644 --- a/doc/getting-started/how-to-install-smash.md +++ b/doc/getting-started/how-to-install-smash.md @@ -284,4 +284,29 @@ curl -X GET -v http://localhost:3100/api/v1/metadata/062693863e0bcf9f619238f0207 curl -X GET -v http://localhost:3100/api/v1/metadata/062693863e0bcf9f619238f020741381d4d3748aae6faf1c012e80e7/3b842358a698119a4b0c0f4934d26cff69190552bf47a85f40f5d1d646c82699 | jq . ``` -This assumes that you have a file called "test_pool.json" in your current directory that contains the JSON metadata for the stake pool. +This assumes that you have a file called "test_pool.json" in your current directory that contains the JSON +metadata for the stake pool. + +## Checking the pool rejection errors + +Currently there is a way to check if there are any errors while trying to download the pool metadata. It could be that the hash is wrong, that the server URL return 404, or something else. +This is a nice way to check what went wrong. + +So if you want to see all the errors that were recorded, you can simply query: +``` +http://localhost:3100/api/v1/errors +``` + +If you have a specific pool id you want to check, you can add that pool id (`c0b0e43213a8c898e373928fbfc3df81ee77c0df7dadc3ad6e5bae17`) in there: +``` +http://localhost:3100/api/v1/errors?poolId=c0b0e43213a8c898e373928fbfc3df81ee77c0df7dadc3ad6e5bae17 +``` + +The returned list consists of objects that contain: +- time - the time formatted in `DD.MM.YYYY. HH:MM:SS` which I claim, is the only sane choice +- utcTime - the time formatted in the standard UTCTime format for any clients +- poolId - the pool id of the owner of the pool +- poolHash - the hash of the pool metadata +- cause - what is the cause of the error and why is it failing +- retryCount - the number of times we retried to fetch the offline metadata + diff --git a/schema/migration-2-0002-20200904.sql b/schema/migration-2-0002-20200904.sql new file mode 100644 index 0000000..27cb04d --- /dev/null +++ b/schema/migration-2-0002-20200904.sql @@ -0,0 +1,31 @@ +-- 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 = 2 THEN + ALTER TABLE "pool_metadata_reference" ALTER COLUMN "pool_id" TYPE text; + ALTER TABLE "pool_metadata_reference" ALTER COLUMN "url" TYPE text; + ALTER TABLE "pool_metadata_reference" ALTER COLUMN "hash" TYPE text; + ALTER TABLE "pool_metadata" ALTER COLUMN "pool_id" TYPE text; + ALTER TABLE "pool_metadata" ALTER COLUMN "ticker_name" TYPE text; + ALTER TABLE "pool_metadata" ALTER COLUMN "hash" TYPE text; + ALTER TABLE "pool_metadata" ALTER COLUMN "metadata" TYPE text; + CREATe TABLE "pool_metadata_fetch_error"("id" SERIAL8 PRIMARY KEY UNIQUE,"fetch_time" timestamp NOT NULL,"pool_id" text NOT NULL,"pool_hash" text NOT NULL,"pmr_id" INT8 NOT NULL,"fetch_error" VARCHAR NOT NULL,"retry_count" uinteger NOT NULL); + ALTER TABLE "pool_metadata_fetch_error" ADD CONSTRAINT "unique_pool_metadata_fetch_error" UNIQUE("fetch_time","pool_id"); + ALTER TABLE "pool_metadata_fetch_error" ADD CONSTRAINT "pool_metadata_fetch_error_pmr_id_fkey" FOREIGN KEY("pmr_id") REFERENCES "pool_metadata_reference"("id"); + ALTER TABLE "delisted_pool" ALTER COLUMN "pool_id" TYPE text; + ALTER TABLE "reserved_ticker" ALTER COLUMN "name" TYPE text; + ALTER TABLE "reserved_ticker" ALTER COLUMN "pool_hash" TYPE text; + -- Hand written SQL statements can be added here. + UPDATE schema_version SET stage_two = 2 ; + RAISE NOTICE 'DB has been migrated to stage_two version %', next_version ; + END IF ; +END ; +$$ LANGUAGE plpgsql ; + +SELECT migrate() ; + +DROP FUNCTION migrate() ; diff --git a/smash.cabal b/smash.cabal index b839a32..b6801cf 100644 --- a/smash.cabal +++ b/smash.cabal @@ -20,7 +20,7 @@ source-repository head Flag disable-basic-auth description: Disable basic authentication scheme for other authentication mechanisms. - default: True + default: False library diff --git a/src/Cardano/Db/Insert.hs b/src/Cardano/Db/Insert.hs index 98bac6c..3af7a74 100644 --- a/src/Cardano/Db/Insert.hs +++ b/src/Cardano/Db/Insert.hs @@ -9,6 +9,7 @@ module Cardano.Db.Insert , insertReservedTicker , insertDelistedPool , insertAdminUser + , insertPoolMetadataFetchError -- Export mainly for testing. , insertByReturnKey @@ -56,6 +57,12 @@ insertDelistedPool = insertByReturnKey insertAdminUser :: (MonadIO m) => AdminUser -> ReaderT SqlBackend m AdminUserId insertAdminUser = insertByReturnKey +insertPoolMetadataFetchError + :: (MonadIO m) + => PoolMetadataFetchError + -> ReaderT SqlBackend m PoolMetadataFetchErrorId +insertPoolMetadataFetchError = insertByReturnKey + ------------------------------------------------------------------------------- -- | Insert a record (with a Unique constraint), and return 'Right key' if the diff --git a/src/Cardano/Db/Query.hs b/src/Cardano/Db/Query.hs index 6074640..7319c44 100644 --- a/src/Cardano/Db/Query.hs +++ b/src/Cardano/Db/Query.hs @@ -16,6 +16,7 @@ module Cardano.Db.Query , queryDelistedPool , queryReservedTicker , queryAdminUsers + , queryPoolMetadataFetchError ) where import Cardano.Prelude hiding (Meta, from, isJust, @@ -154,6 +155,18 @@ queryAdminUsers = do res <- selectList [] [] pure $ entityVal <$> res +-- | Query all the errors we have. +queryPoolMetadataFetchError :: MonadIO m => Maybe Types.PoolId -> ReaderT SqlBackend m [PoolMetadataFetchError] +queryPoolMetadataFetchError Nothing = do + res <- selectList [] [] + pure $ entityVal <$> res + +queryPoolMetadataFetchError (Just poolId) = do + res <- select . from $ \(poolMetadataFetchError :: SqlExpr (Entity PoolMetadataFetchError)) -> do + where_ (poolMetadataFetchError ^. PoolMetadataFetchErrorPoolId ==. val poolId) + pure $ poolMetadataFetchError + pure $ fmap entityVal res + ------------------------------------------------------------------------------------ maybeToEither :: e -> (a -> b) -> Maybe a -> Either e b diff --git a/src/Cardano/Db/Schema.hs b/src/Cardano/Db/Schema.hs index 8a16387..1960dec 100644 --- a/src/Cardano/Db/Schema.hs +++ b/src/Cardano/Db/Schema.hs @@ -60,7 +60,7 @@ share PoolMetadataReference poolId Types.PoolId sqltype=text url Types.PoolUrl sqltype=text - hash Types.PoolMetadataHash sqltype=base16type + hash Types.PoolMetadataHash sqltype=text UniquePoolMetadataReference poolId hash -- The table containing the metadata. @@ -68,7 +68,7 @@ share PoolMetadata poolId Types.PoolId sqltype=text tickerName Types.TickerName sqltype=text - hash Types.PoolMetadataHash sqltype=base16type + hash Types.PoolMetadataHash sqltype=text metadata Types.PoolMetadataRaw sqltype=text pmrId PoolMetadataReferenceId Maybe UniquePoolMetadata poolId hash @@ -79,6 +79,17 @@ share poolId PoolId sqltype=text UniquePoolId poolId + -- The pool metadata fetch error. We duplicate the poolId for easy access. + + PoolMetadataFetchError + fetchTime UTCTime sqltype=timestamp + poolId Types.PoolId sqltype=text + poolHash Types.PoolMetadataHash sqltype=text + pmrId PoolMetadataReferenceId + fetchError Text + retryCount Word sqltype=uinteger + UniquePoolMetadataFetchError fetchTime poolId + -- We actually need the block table to be able to persist sync data Block @@ -88,7 +99,6 @@ share blockNo Word64 Maybe sqltype=uinteger UniqueBlock hash - -- A table containing metadata about the chain. There will probably only ever be one -- row in this table. Meta @@ -110,7 +120,7 @@ share -- For now they are grouped under the specific hash of the pool. ReservedTicker name Text sqltype=text - poolHash Types.PoolMetadataHash sqltype=base16type + poolHash Types.PoolMetadataHash sqltype=text UniqueReservedTicker name -- A table containin a list of administrator users that can be used to access the secure API endpoints. diff --git a/src/Cardano/Db/Types.hs b/src/Cardano/Db/Types.hs index be041ff..fd83ebf 100644 --- a/src/Cardano/Db/Types.hs +++ b/src/Cardano/Db/Types.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralisedNewtypeDeriving #-} @@ -14,26 +15,26 @@ import Database.Persist.Class -- -- It may be rendered as hex or as bech32 using the @pool@ prefix. -- -newtype PoolId = PoolId { getPoolId :: ByteString } +newtype PoolId = PoolId { getPoolId :: Text } deriving stock (Eq, Show, Ord, Generic) deriving newtype PersistField instance ToJSON PoolId where toJSON (PoolId poolId) = object - [ "poolId" .= decodeUtf8 poolId + [ "poolId" .= poolId ] instance FromJSON PoolId where parseJSON = withObject "PoolId" $ \o -> do poolId <- o .: "poolId" - return $ PoolId $ encodeUtf8 poolId + return $ PoolId poolId -- | The hash of a stake pool's metadata. -- -- It may be rendered as hex. -- -newtype PoolMetadataHash = PoolMetadataHash { getPoolMetadataHash :: ByteString } +newtype PoolMetadataHash = PoolMetadataHash { getPoolMetadataHash :: Text } deriving stock (Eq, Show, Ord, Generic) deriving newtype PersistField diff --git a/src/Cardano/SmashDbSync.hs b/src/Cardano/SmashDbSync.hs index a1757f6..45eaa7a 100644 --- a/src/Cardano/SmashDbSync.hs +++ b/src/Cardano/SmashDbSync.hs @@ -407,6 +407,7 @@ dbSyncProtocols trce env plugin _version codecs _connectionId = (metrics, server) <- registerMetricsServer 8080 race_ (race_ + -- TODO(KS): Watch out! We pass the data layer here directly! (runDbThread trce env plugin metrics actionQueue) (runOfflineFetchThread $ modifyName (const "fetch") trce) ) diff --git a/src/DB.hs b/src/DB.hs index f3960eb..2a4e9b4 100644 --- a/src/DB.hs +++ b/src/DB.hs @@ -19,11 +19,13 @@ import Cardano.Prelude import Data.IORef (IORef, modifyIORef, readIORef) import qualified Data.Map as Map +import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) import Types import Cardano.Db.Insert (insertDelistedPool, insertPoolMetadata, + insertPoolMetadataFetchError, insertPoolMetadataReference, insertReservedTicker) import Cardano.Db.Query (DBFail (..), queryPoolMetadata) @@ -38,6 +40,8 @@ import Cardano.Db.Schema as X (AdminUser (..), Block (..), DelistedPool (..), Meta (..), PoolMetadata (..), + PoolMetadataFetchError (..), + PoolMetadataFetchErrorId, PoolMetadataReference (..), PoolMetadataReferenceId, ReservedTicker (..), @@ -52,12 +56,20 @@ import qualified Cardano.Db.Types as Types data DataLayer = DataLayer { dlGetPoolMetadata :: PoolId -> PoolMetadataHash -> IO (Either DBFail (Text, Text)) , dlAddPoolMetadata :: Maybe PoolMetadataReferenceId -> PoolId -> PoolMetadataHash -> Text -> PoolTicker -> IO (Either DBFail Text) + , dlAddMetaDataReference :: PoolId -> PoolUrl -> PoolMetadataHash -> IO PoolMetadataReferenceId + , dlAddReservedTicker :: Text -> PoolMetadataHash -> IO (Either DBFail ReservedTickerId) , dlCheckReservedTicker :: Text -> IO (Maybe ReservedTicker) + , dlCheckDelistedPool :: PoolId -> IO Bool , dlAddDelistedPool :: PoolId -> IO (Either DBFail PoolId) + , dlGetAdminUsers :: IO (Either DBFail [AdminUser]) + + -- TODO(KS): Switch to PoolFetchError! + , dlAddFetchError :: PoolMetadataFetchError -> IO (Either DBFail PoolMetadataFetchErrorId) + , dlGetFetchErrors :: Maybe PoolId -> IO (Either DBFail [PoolFetchError]) } deriving (Generic) -- | Simple stubbed @DataLayer@ for an example. @@ -96,6 +108,9 @@ stubbedDataLayer ioDataMap ioDelistedPool = DataLayer return $ Right poolId , dlGetAdminUsers = return $ Right [] + + , dlAddFetchError = \_ -> panic "!" + , dlGetFetchErrors = \_ -> panic "!" } -- The approximation for the table. @@ -148,5 +163,17 @@ postgresqlDataLayer = DataLayer adminUsers <- runDbAction Nothing $ queryAdminUsers return $ Right adminUsers + , dlAddFetchError = \poolMetadataFetchError -> do + poolMetadataFetchErrorId <- runDbAction Nothing $ insertPoolMetadataFetchError poolMetadataFetchError + return $ Right poolMetadataFetchErrorId + + , dlGetFetchErrors = \mPoolId -> do + poolMetadataFetchErrors <- runDbAction Nothing (queryPoolMetadataFetchError mPoolId) + pure $ sequence $ Right <$> map convertPoolMetadataFetchError poolMetadataFetchErrors + } +convertPoolMetadataFetchError :: PoolMetadataFetchError -> PoolFetchError +convertPoolMetadataFetchError (PoolMetadataFetchError timeUTC poolId poolHash _pMRId fetchError retryCount) = + PoolFetchError (utcTimeToPOSIXSeconds timeUTC) poolId poolHash fetchError retryCount + diff --git a/src/DbSyncPlugin.hs b/src/DbSyncPlugin.hs index f72fd4b..a4e49ca 100644 --- a/src/DbSyncPlugin.hs +++ b/src/DbSyncPlugin.hs @@ -127,7 +127,7 @@ insertPoolRegister -> ExceptT DbSyncNodeError (ReaderT SqlBackend m) () insertPoolRegister tracer params = do let poolIdHash = B16.encode . Shelley.unKeyHashBS $ Shelley._poolPubKey params - let poolId = PoolId poolIdHash + let poolId = PoolId . decodeUtf8 $ poolIdHash liftIO . logInfo tracer $ "Inserting pool register with pool id: " <> decodeUtf8 poolIdHash case strictMaybeToMaybe $ Shelley._poolMD params of @@ -135,12 +135,12 @@ insertPoolRegister tracer params = do liftIO . logInfo tracer $ "Inserting metadata." let metadataUrl = PoolUrl . Shelley.urlToText $ Shelley._poolMDUrl md - let metadataHash = PoolMetadataHash . B16.encode $ Shelley._poolMDHash md + let metadataHash = PoolMetadataHash . decodeUtf8 . B16.encode $ Shelley._poolMDHash md -- Ah. We can see there is garbage all over the code. Needs refactoring. refId <- lift . liftIO $ (dlAddMetaDataReference postgresqlDataLayer) poolId metadataUrl metadataHash - liftIO $ fetchInsertNewPoolMetadata tracer refId poolId md + liftIO $ fetchInsertNewPoolMetadata postgresqlDataLayer tracer refId poolId md liftIO . logInfo tracer $ "Metadata inserted." diff --git a/src/FetchQueue.hs b/src/FetchQueue.hs index 9ada9ec..cb3499d 100644 --- a/src/FetchQueue.hs +++ b/src/FetchQueue.hs @@ -2,6 +2,7 @@ module FetchQueue ( FetchQueue -- opaque , PoolFetchRetry (..) , Retry -- opaque + , retryCount , emptyFetchQueue , lenFetchQueue , nullFetchQueue diff --git a/src/Lib.hs b/src/Lib.hs index 81ee9dd..489e08b 100644 --- a/src/Lib.hs +++ b/src/Lib.hs @@ -32,8 +32,9 @@ import Servant (Application, BasicAuth, BasicAuthData (..), BasicAuthResult (..), Capture, Context (..), Get, Handler (..), - JSON, Patch, ReqBody, Server, err403, - err404, serveWithContext) + JSON, Patch, QueryParam, ReqBody, + Server, err403, err404, + serveWithContext) import Servant.Swagger import DB @@ -48,13 +49,18 @@ type OfflineMetadataAPI = "api" :> "v1" :> "metadata" :> Capture "id" PoolId :> -- POST api/v1/delist #ifdef DISABLE_BASIC_AUTH type DelistPoolAPI = "api" :> "v1" :> "delist" :> ReqBody '[JSON] PoolId :> ApiRes Patch PoolId + +type FetchPoolErrorAPI = "api" :> "v1" :> "errors" :> QueryParam "poolId" PoolId :> ApiRes Get [PoolFetchError] #else -- The basic auth. type BasicAuthURL = BasicAuth "smash" User + type DelistPoolAPI = BasicAuthURL :> "api" :> "v1" :> "delist" :> ReqBody '[JSON] PoolId :> ApiRes Patch PoolId + +type FetchPoolErrorAPI = BasicAuthURL :> "api" :> "v1" :> "errors" :> QueryParam "poolId" PoolId :> ApiRes Get [PoolFetchError] #endif -type SmashAPI = OfflineMetadataAPI :<|> DelistPoolAPI +type SmashAPI = OfflineMetadataAPI :<|> DelistPoolAPI :<|> FetchPoolErrorAPI -- | Swagger spec for Todo API. todoSwagger :: Swagger @@ -112,7 +118,7 @@ runAppStubbed configuration = do mkAppStubbed :: Configuration -> IO Application mkAppStubbed configuration = do - ioDataMap <- newIORef stubbedInitialDataMap + ioDataMap <- newIORef stubbedInitialDataMap ioDelistedPools <- newIORef stubbedDelistedPools let dataLayer :: DataLayer @@ -212,6 +218,25 @@ server configuration dataLayer = return todoSwagger :<|> getPoolOfflineMetadata dataLayer :<|> postDelistPool dataLayer + :<|> fetchPoolErrorAPI dataLayer + +#ifdef DISABLE_BASIC_AUTH +fetchPoolErrorAPI :: DataLayer -> Maybe PoolId -> Handler (ApiResult DBFail [PoolFetchError]) +fetchPoolErrorAPI dataLayer mPoolId = convertIOToHandler $ do + + let getFetchErrors = dlGetFetchErrors dataLayer + fetchErrors <- getFetchErrors mPoolId + + return . ApiResult $ fetchErrors +#else +fetchPoolErrorAPI :: DataLayer -> User -> Maybe PoolId -> Handler (ApiResult DBFail [PoolFetchError]) +fetchPoolErrorAPI dataLayer _user mPoolId = convertIOToHandler $ do + + let getFetchErrors = dlGetFetchErrors dataLayer + fetchErrors <- getFetchErrors mPoolId + + return . ApiResult $ fetchErrors +#endif #ifdef DISABLE_BASIC_AUTH postDelistPool :: DataLayer -> PoolId -> Handler (ApiResult DBFail PoolId) @@ -231,6 +256,7 @@ postDelistPool dataLayer user poolId = convertIOToHandler $ do return . ApiResult $ delistedPool' #endif + -- throwError err404 getPoolOfflineMetadata :: DataLayer -> PoolId -> PoolMetadataHash -> Handler (ApiResult DBFail PoolMetadataWrapped) getPoolOfflineMetadata dataLayer poolId poolHash = convertIOToHandler $ do diff --git a/src/Offline.hs b/src/Offline.hs index 881d7fa..2e14f77 100644 --- a/src/Offline.hs +++ b/src/Offline.hs @@ -13,16 +13,16 @@ import Cardano.BM.Trace (Trace, logWarning, logInfo) import Control.Concurrent (threadDelay) import Control.Monad.Trans.Except.Extra (handleExceptT, hoistEither, left) -import DB (DataLayer (..), PoolMetadataReference (..), PoolMetadataReferenceId, - postgresqlDataLayer, runDbAction) +import DB (DataLayer (..), PoolMetadataReference (..), PoolMetadataReferenceId, PoolMetadataFetchError (..), postgresqlDataLayer, runDbAction) import FetchQueue -import Types (PoolId, PoolMetadataHash (..), getPoolMetadataHash, getPoolUrl, pomTicker) +import Types (PoolId, PoolMetadataHash (..), PoolFetchError (..), FetchError (..), getPoolMetadataHash, getPoolUrl, pomTicker) import Data.Aeson (eitherDecode') import qualified Data.ByteString.Lazy as LBS import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import qualified Data.Time.Clock.POSIX as Time +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import qualified Cardano.Crypto.Hash.Class as Crypto import qualified Cardano.Crypto.Hash.Blake2b as Crypto @@ -46,27 +46,16 @@ 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. - -data FetchError - = FEHashMismatch !Text !Text - | FEDataTooLong - | FEUrlParseFail !Text - | FEJsonDecodeFail !Text - | FEHttpException !Text - | FEHttpResponse !Int - | FEIOException !Text - | FETimeout !Text - | FEConnectionFailure - fetchInsertNewPoolMetadata - :: Trace IO Text + :: DataLayer + -> Trace IO Text -> DB.PoolMetadataReferenceId -> PoolId -> Shelley.PoolMetaData -> IO () -fetchInsertNewPoolMetadata tracer refId poolId md = do +fetchInsertNewPoolMetadata dataLayer tracer refId poolId md = do now <- Time.getPOSIXTime - void . fetchInsertNewPoolMetadataOld tracer $ + void . fetchInsertNewPoolMetadataOld dataLayer tracer $ PoolFetchRetry { pfrReferenceId = refId , pfrPoolIdWtf = poolId @@ -76,17 +65,39 @@ fetchInsertNewPoolMetadata tracer refId poolId md = do } fetchInsertNewPoolMetadataOld - :: Trace IO Text + :: DataLayer + -> Trace IO Text -> PoolFetchRetry -> IO (Maybe PoolFetchRetry) -fetchInsertNewPoolMetadataOld tracer pfr = do +fetchInsertNewPoolMetadataOld dataLayer tracer pfr = do res <- runExceptT fetchInsert case res of Right () -> pure Nothing Left err -> do - logWarning tracer $ renderFetchError err + let poolId = pfrPoolIdWtf pfr + let poolHash = PoolMetadataHash . decodeUtf8 . B16.encode $ pfrPoolMDHash pfr + let poolMetadataReferenceId = pfrReferenceId pfr + let fetchError = renderFetchError err + let currRetryCount = retryCount $ pfrRetry pfr + -- Update retry timeout here as a psuedo-randomisation of retry. now <- Time.getPOSIXTime + + -- The generated fetch error + let _poolFetchError = PoolFetchError now poolId poolHash fetchError + + let addFetchError = dlAddFetchError dataLayer + + _ <- addFetchError $ PoolMetadataFetchError + (posixSecondsToUTCTime now) + poolId + poolHash + poolMetadataReferenceId + fetchError + currRetryCount + + logWarning tracer fetchError + pure . Just $ pfr { pfrRetry = nextRetry now (pfrRetry pfr) } where fetchInsert :: ExceptT FetchError IO () @@ -122,7 +133,7 @@ fetchInsertNewPoolMetadataOld tracer pfr = do (dlAddPoolMetadata postgresqlDataLayer) (Just $ pfrReferenceId pfr) (pfrPoolIdWtf pfr) - (PoolMetadataHash . B16.encode $ pfrPoolMDHash pfr) + (PoolMetadataHash . renderByteStringHex $ pfrPoolMDHash pfr) (decodeUtf8 respBS) (pomTicker decodedMetadata) @@ -131,12 +142,12 @@ fetchInsertNewPoolMetadataOld tracer pfr = do runOfflineFetchThread :: Trace IO Text -> IO () runOfflineFetchThread trce = do liftIO $ logInfo trce "Runing Offline fetch thread" - fetchLoop trce emptyFetchQueue + fetchLoop DB.postgresqlDataLayer trce emptyFetchQueue -- ------------------------------------------------------------------------------------------------- -fetchLoop :: Trace IO Text -> FetchQueue -> IO () -fetchLoop trce = +fetchLoop :: DataLayer -> Trace IO Text -> FetchQueue -> IO () +fetchLoop dataLayer trce = loop where loop :: FetchQueue -> IO () @@ -156,7 +167,7 @@ fetchLoop trce = loop unrunnable else do liftIO $ logInfo trce $ "Pools without offline metadata: " <> show (length runnable) - rs <- catMaybes <$> mapM (fetchInsertNewPoolMetadataOld trce) runnable + rs <- catMaybes <$> mapM (fetchInsertNewPoolMetadataOld dataLayer trce) runnable loop $ insertFetchQueue rs unrunnable httpGetMax512Bytes :: Http.Request -> Http.Manager -> ExceptT FetchError IO (ByteString, Http.Status) @@ -214,7 +225,7 @@ queryPoolFetchRetry retry = do { pfrReferenceId = entityKey entity , pfrPoolIdWtf = DB.poolMetadataReferencePoolId pmr , pfrPoolUrl = getPoolUrl $ poolMetadataReferenceUrl pmr - , pfrPoolMDHash = fst . B16.decode $ getPoolMetadataHash (poolMetadataReferenceHash pmr) + , pfrPoolMDHash = fst . B16.decode . encodeUtf8 $ getPoolMetadataHash (poolMetadataReferenceHash pmr) , pfrRetry = retry } diff --git a/src/Types.hs b/src/Types.hs index b9e0632..97bdbb8 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} module Types ( ApplicationUser (..) @@ -27,6 +28,9 @@ module Types , defaultConfiguration -- * API , ApiResult (..) + -- * HTTP + , FetchError (..) + , PoolFetchError (..) ) where import Cardano.Prelude @@ -38,6 +42,9 @@ import Data.Aeson (FromJSON (..), ToJSON (..), object, import qualified Data.Aeson as Aeson import Data.Aeson.Encoding (unsafeToEncoding) import qualified Data.Aeson.Types as Aeson +import Data.Time.Clock (UTCTime) +import qualified Data.Time.Clock.POSIX as Time +import Data.Time.Format (formatTime, defaultTimeLocale) import Data.Swagger (NamedSchema (..), ToParamSchema (..), ToSchema (..)) @@ -113,7 +120,7 @@ checkIfUserValid (ApplicationUsers applicationUsers) applicationUser@(Applicatio -- TODO(KS): Temporarily, validation!? instance FromHttpApiData PoolId where - parseUrlPiece poolId = Right $ PoolId (encodeUtf8 poolId) + parseUrlPiece poolId = Right $ PoolId poolId --TODO: parse hex or bech32 instance ToSchema PoolMetadataHash where @@ -122,7 +129,7 @@ instance ToSchema PoolMetadataHash where -- TODO(KS): Temporarily, validation!? instance FromHttpApiData PoolMetadataHash where - parseUrlPiece poolMetadataHash = Right $ PoolMetadataHash (encodeUtf8 poolMetadataHash) + parseUrlPiece poolMetadataHash = Right $ PoolMetadataHash poolMetadataHash --TODO: parse hex or bech32 newtype PoolName = PoolName @@ -273,4 +280,33 @@ instance (ToJSON err, ToJSON a) => ToJSON (ApiResult err a) where toEncoding (ApiResult (Left result)) = toEncoding result toEncoding (ApiResult (Right result)) = toEncoding result +-- |Fetch error for the HTTP client fetching the pool. +data FetchError + = FEHashMismatch !Text !Text + | FEDataTooLong + | FEUrlParseFail !Text + | FEJsonDecodeFail !Text + | FEHttpException !Text + | FEHttpResponse !Int + | FEIOException !Text + | FETimeout !Text + | FEConnectionFailure + +-- |Fetch error for the specific @PoolId@ and the @PoolMetadataHash@. +data PoolFetchError = PoolFetchError !Time.POSIXTime !PoolId !PoolMetadataHash !Text !Word + deriving (Eq, Show) + +instance ToJSON PoolFetchError where + toJSON (PoolFetchError time poolId poolHash errorCause retryCount) = + object + [ "time" .= formatTimeToNormal time + , "utcTime" .= (show time :: Text) + , "poolId" .= getPoolId poolId + , "poolHash" .= getPoolMetadataHash poolHash + , "cause" .= errorCause + , "retryCount" .= retryCount + ] + +formatTimeToNormal :: Time.POSIXTime -> Text +formatTimeToNormal = toS . formatTime defaultTimeLocale "%d.%m.%Y. %T" . Time.posixSecondsToUTCTime diff --git a/test/SmashSpecSM.hs b/test/SmashSpecSM.hs index dc94b1b..60380b8 100644 --- a/test/SmashSpecSM.hs +++ b/test/SmashSpecSM.hs @@ -194,10 +194,10 @@ doNotUse :: a doNotUse = panic "Should not be used!" genPoolId :: Gen PoolId -genPoolId = PoolId . encodeUtf8 <$> genSafeText +genPoolId = PoolId <$> genSafeText genPoolHash :: Gen PoolMetadataHash -genPoolHash = PoolMetadataHash . encodeUtf8 <$> genSafeText +genPoolHash = PoolMetadataHash <$> genSafeText -- |Improve this. genPoolOfflineMetadataText :: Gen Text