diff --git a/smash-servant-types/src/Cardano/SMASH/DBSync/Db/Error.hs b/smash-servant-types/src/Cardano/SMASH/DBSync/Db/Error.hs index dc76d57..f77514c 100644 --- a/smash-servant-types/src/Cardano/SMASH/DBSync/Db/Error.hs +++ b/smash-servant-types/src/Cardano/SMASH/DBSync/Db/Error.hs @@ -27,6 +27,7 @@ data DBFail | UnknownError !Text | ReservedTickerAlreadyInserted !Text | RecordDoesNotExist + | DbInsertError !Text deriving (Eq, Show, Generic) {- @@ -92,6 +93,11 @@ instance ToJSON DBFail where [ "code" .= String "RecordDoesNotExist" , "description" .= String (renderLookupFail failure) ] + toJSON failure@(DbInsertError _err) = + object + [ "code" .= String "DbInsertError" + , "description" .= String (renderLookupFail failure) + ] renderLookupFail :: DBFail -> Text renderLookupFail lf = @@ -106,4 +112,5 @@ renderLookupFail lf = UnknownError text -> "Unknown error. Context: " <> text ReservedTickerAlreadyInserted tickerName -> "Ticker '" <> tickerName <> "' has already been inserted." RecordDoesNotExist -> "The requested record does not exist." + DbInsertError text -> "The database got an error while trying to insert a record. Error: " <> text diff --git a/smash/smash.cabal b/smash/smash.cabal index 107621f..cc5f23a 100644 --- a/smash/smash.cabal +++ b/smash/smash.cabal @@ -212,6 +212,7 @@ test-suite db-spec-test , quickcheck-state-machine >=0.6 , smash , smash-servant-types + , iohk-monitoring , tree-diff default-language: Haskell2010 diff --git a/smash/src/Cardano/SMASH/DB.hs b/smash/src/Cardano/SMASH/DB.hs index 3f25009..a496356 100644 --- a/smash/src/Cardano/SMASH/DB.hs +++ b/smash/src/Cardano/SMASH/DB.hs @@ -70,7 +70,7 @@ 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 + , dlAddMetaDataReference :: PoolId -> PoolUrl -> PoolMetadataHash -> IO (Either DBFail PoolMetadataReferenceId) , dlAddReservedTicker :: Text -> PoolMetadataHash -> IO (Either DBFail ReservedTickerId) , dlCheckReservedTicker :: Text -> IO (Maybe ReservedTicker) @@ -181,8 +181,11 @@ postgresqlDataLayer = DataLayer return $ (,) <$> poolTickerName <*> poolMetadata' , dlAddPoolMetadata = \mRefId poolId poolHash poolMetadata poolTicker -> do let poolTickerName = Types.TickerName $ getPoolTicker poolTicker - _ <- runDbAction Nothing $ insertPoolMetadata $ PoolMetadata poolId poolTickerName poolHash (Types.PoolMetadataRaw poolMetadata) mRefId - return $ Right poolMetadata + poolMetadataId <- runDbAction Nothing $ insertPoolMetadata $ PoolMetadata poolId poolTickerName poolHash (Types.PoolMetadataRaw poolMetadata) mRefId + + case poolMetadataId of + Left err -> return $ Left err + Right _id -> return $ Right poolMetadata , dlAddMetaDataReference = \poolId poolUrl poolMetadataHash -> do poolMetadataRefId <- runDbAction Nothing $ insertPoolMetadataReference $ @@ -206,7 +209,10 @@ postgresqlDataLayer = DataLayer runDbAction Nothing $ queryDelistedPool poolId , dlAddDelistedPool = \poolId -> do delistedPoolId <- runDbAction Nothing $ insertDelistedPool $ DelistedPool poolId - return $ Right poolId + + case delistedPoolId of + Left err -> return $ Left err + Right _id -> return $ Right poolId , dlRemoveDelistedPool = \poolId -> do isDeleted <- runDbAction Nothing $ deleteDelistedPool poolId -- Up for a discussion, but this might be more sensible in the lower DB layer. @@ -215,8 +221,11 @@ postgresqlDataLayer = DataLayer else return $ Left RecordDoesNotExist , dlAddRetiredPool = \poolId -> do - _retiredPoolId <- runDbAction Nothing $ insertRetiredPool $ RetiredPool poolId - return $ Right poolId + retiredPoolId <- runDbAction Nothing $ insertRetiredPool $ RetiredPool poolId + + case retiredPoolId of + Left err -> return $ Left err + Right _id -> return $ Right poolId , dlGetRetiredPools = do retiredPools <- runDbAction Nothing $ queryAllRetiredPools return $ Right $ map retiredPoolPoolId retiredPools @@ -227,7 +236,7 @@ postgresqlDataLayer = DataLayer , dlAddFetchError = \poolMetadataFetchError -> do poolMetadataFetchErrorId <- runDbAction Nothing $ insertPoolMetadataFetchError poolMetadataFetchError - return $ Right poolMetadataFetchErrorId + return poolMetadataFetchErrorId , dlGetFetchErrors = \poolId mTimeFrom -> do poolMetadataFetchErrors <- runDbAction Nothing (queryPoolMetadataFetchErrorByTime poolId mTimeFrom) pure $ sequence $ Right <$> map convertPoolMetadataFetchError poolMetadataFetchErrors diff --git a/smash/src/Cardano/SMASH/DBSync/Db/Insert.hs b/smash/src/Cardano/SMASH/DBSync/Db/Insert.hs index 60cb391..c711fc3 100644 --- a/smash/src/Cardano/SMASH/DBSync/Db/Insert.hs +++ b/smash/src/Cardano/SMASH/DBSync/Db/Insert.hs @@ -1,5 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} module Cardano.SMASH.DBSync.Db.Insert ( insertBlock @@ -16,32 +16,35 @@ module Cardano.SMASH.DBSync.Db.Insert , insertByReturnKey ) where -import Cardano.Prelude hiding (Meta) +import Cardano.Prelude hiding (Meta) -import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Trans.Reader (ReaderT) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Trans.Reader (ReaderT, mapReaderT) -import Database.Persist.Class (AtLeastOneUniqueKey, Key, PersistEntityBackend, - getByValue, insert, checkUnique) -import Database.Persist.Sql (SqlBackend) -import Database.Persist.Types (entityKey) +import Database.Persist.Class (AtLeastOneUniqueKey, Key, + PersistEntityBackend, + checkUnique, getByValue, + insert) +import Database.Persist.Sql (SqlBackend) +import Database.Persist.Types (entityKey) +import Database.PostgreSQL.Simple (SqlError) -import Cardano.SMASH.DBSync.Db.Schema import Cardano.SMASH.DBSync.Db.Error +import Cardano.SMASH.DBSync.Db.Schema -insertBlock :: (MonadIO m) => Block -> ReaderT SqlBackend m BlockId +insertBlock :: (MonadIO m) => Block -> ReaderT SqlBackend m (Either DBFail BlockId) insertBlock = insertByReturnKey -insertMeta :: (MonadIO m) => Meta -> ReaderT SqlBackend m MetaId +insertMeta :: (MonadIO m) => Meta -> ReaderT SqlBackend m (Either DBFail MetaId) insertMeta = insertByReturnKey -insertPoolMetadata :: (MonadIO m) => PoolMetadata -> ReaderT SqlBackend m PoolMetadataId +insertPoolMetadata :: (MonadIO m) => PoolMetadata -> ReaderT SqlBackend m (Either DBFail PoolMetadataId) insertPoolMetadata = insertByReturnKey insertPoolMetadataReference :: MonadIO m => PoolMetadataReference - -> ReaderT SqlBackend m PoolMetadataReferenceId + -> ReaderT SqlBackend m (Either DBFail PoolMetadataReferenceId) insertPoolMetadataReference = insertByReturnKey insertReservedTicker :: (MonadIO m) => ReservedTicker -> ReaderT SqlBackend m (Either DBFail ReservedTickerId) @@ -49,22 +52,22 @@ insertReservedTicker reservedTicker = do isUnique <- checkUnique reservedTicker -- If there is no unique constraint violated, insert, otherwise return error. case isUnique of - Nothing -> Right <$> insertByReturnKey reservedTicker + Nothing -> insertByReturnKey reservedTicker Just _key -> return . Left . ReservedTickerAlreadyInserted $ reservedTickerName reservedTicker -insertDelistedPool :: (MonadIO m) => DelistedPool -> ReaderT SqlBackend m DelistedPoolId +insertDelistedPool :: (MonadIO m) => DelistedPool -> ReaderT SqlBackend m (Either DBFail DelistedPoolId) insertDelistedPool = insertByReturnKey -insertRetiredPool :: (MonadIO m) => RetiredPool -> ReaderT SqlBackend m RetiredPoolId +insertRetiredPool :: (MonadIO m) => RetiredPool -> ReaderT SqlBackend m (Either DBFail RetiredPoolId) insertRetiredPool = insertByReturnKey -insertAdminUser :: (MonadIO m) => AdminUser -> ReaderT SqlBackend m AdminUserId +insertAdminUser :: (MonadIO m) => AdminUser -> ReaderT SqlBackend m (Either DBFail AdminUserId) insertAdminUser = insertByReturnKey insertPoolMetadataFetchError :: (MonadIO m) => PoolMetadataFetchError - -> ReaderT SqlBackend m PoolMetadataFetchErrorId + -> ReaderT SqlBackend m (Either DBFail PoolMetadataFetchErrorId) insertPoolMetadataFetchError = insertByReturnKey ------------------------------------------------------------------------------- @@ -76,10 +79,16 @@ insertByReturnKey , MonadIO m , PersistEntityBackend record ~ SqlBackend ) - => record -> ReaderT SqlBackend m (Key record) + => record -> ReaderT SqlBackend m (Either DBFail (Key record)) insertByReturnKey value = do - res <- getByValue value - case res of - Nothing -> insert value - Just r -> pure $ entityKey r + res <- getByValue value + case res of + -- handle :: Exception e => (e -> IO a) -> IO a -> IO a + Nothing -> mapReaderT (\insertedValue -> liftIO $ handle exceptionHandler insertedValue) (Right <$> insert value) + Just r -> pure . Right $ entityKey r + where + exceptionHandler :: MonadIO m => SqlError -> m (Either DBFail a) + exceptionHandler e = + liftIO . pure . Left . DbInsertError . show $ e + diff --git a/smash/src/Cardano/SMASH/DBSyncPlugin.hs b/smash/src/Cardano/SMASH/DBSyncPlugin.hs index fcefda2..d2aa560 100644 --- a/smash/src/Cardano/SMASH/DBSyncPlugin.hs +++ b/smash/src/Cardano/SMASH/DBSyncPlugin.hs @@ -19,8 +19,7 @@ import Control.Monad.Trans.Except.Extra (firstExceptT, import Control.Monad.Trans.Reader (ReaderT) import Cardano.SMASH.DB (DBFail (..), - DataLayer (..), - postgresqlDataLayer) + DataLayer (..)) import Cardano.SMASH.Offline (fetchInsertNewPoolMetadata) import Cardano.SMASH.Types (PoolId (..), PoolMetadataHash (..), PoolUrl (..)) @@ -189,7 +188,10 @@ insertPoolRegister dataLayer tracer params = do let metadataHash = PoolMetadataHash . decodeUtf8 . B16.encode $ Shelley._poolMDHash md let addMetaDataReference = dlAddMetaDataReference dataLayer - refId <- lift . liftIO $ addMetaDataReference poolId metadataUrl metadataHash + + -- We need to map this to ExceptT + refId <- firstExceptT (\(e :: DBFail) -> NEError $ show e) . newExceptT . liftIO $ + addMetaDataReference poolId metadataUrl metadataHash liftIO $ fetchInsertNewPoolMetadata dataLayer tracer refId poolId md diff --git a/smash/test/MigrationSpec.hs b/smash/test/MigrationSpec.hs index e33bc96..4e4656b 100644 --- a/smash/test/MigrationSpec.hs +++ b/smash/test/MigrationSpec.hs @@ -11,6 +11,7 @@ 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.DBSync.Db.Migration (SmashLogFileDir (..), SmashMigrationDir (..), runMigrations) @@ -32,7 +33,7 @@ migrationSpec = do migrationTest :: IO () migrationTest = do let schemaDir = SmashMigrationDir "../schema" - runMigrations (\x -> x) True schemaDir (Just $ SmashLogFileDir "/tmp") + runMigrations Logging.nullTracer (\x -> x) schemaDir (Just $ SmashLogFileDir "/tmp") -- TODO(KS): This version HAS to be changed manually so we don't mess up the -- migration.