Merge pull request #67 from input-output-hk/ksaric/CAD-1744

[CAD-1744] Easily query reason for pool metadata lookup failure.

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
+

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() ;

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
 

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

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

src/Cardano/Db/Schema.hs

@@ -60,15 +60,15 @@ 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.
 
   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.

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
 

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

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
+

src/DbSyncPlugin.hs

@@ -127,20 +127,20 @@ 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
     Just md -> 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."
 

src/FetchQueue.hs

@@ -2,6 +2,7 @@ module FetchQueue
   ( FetchQueue -- opaque
   , PoolFetchRetry (..)
   , Retry -- opaque
+  , retryCount
   , emptyFetchQueue
   , lenFetchQueue
   , nullFetchQueue

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