[CAD-2181] All queries that don't return anything should return 404

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
 

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

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

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,55 +16,58 @@ 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)
 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
+
 

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
 

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.