update entity, convert runs and make a start on queries

Author: Cmdv

cardano-db-sync/src/Cardano/DbSync.hs

@@ -57,7 +57,7 @@ import Ouroboros.Network.NodeToClient (IOManager, withIOManager)
 import Paths_cardano_db_sync (version)
 import System.Directory (createDirectoryIfMissing)
 import Prelude (id)
-import Hasql.Connection as HC
+import qualified Hasql.Connection as HsqlC
 
 runDbSyncNode :: MetricSetters -> [(Text, Text)] -> SyncNodeParams -> SyncNodeConfig -> IO ()
 runDbSyncNode metricsSetters knownMigrations params syncNodeConfigFromFile =
@@ -113,8 +113,7 @@ runDbSync metricsSetters knownMigrations iomgr trce params syncNodeConfigFromFil
     then logInfo trce "All user indexes were created"
     else logInfo trce "New user indexes were not created. They may be created later if necessary."
 
-  let setting = Db.toConnectionSetting pgConfig
-
+  let dbConnectionSetting = Db.toConnectionSetting pgConfig
 
   -- For testing and debugging.
   whenJust (enpMaybeRollback params) $ \slotNo ->
@@ -123,7 +122,7 @@ runDbSync metricsSetters knownMigrations iomgr trce params syncNodeConfigFromFil
     metricsSetters
     trce
     iomgr
-    connectionString
+    dbConnectionSetting
     (void . runMigration)
     syncNodeConfigFromFile
     params
@@ -150,6 +149,7 @@ runSyncNode ::
   MetricSetters ->
   Trace IO Text ->
   IOManager ->
+  -- | Database connection settings
   Setting ->
   -- | run migration function
   RunMigration ->
@@ -168,11 +168,11 @@ runSyncNode metricsSetters trce iomgr connSetting runMigrationFnc syncNodeConfig
   let useLedger = shouldUseLedger (sioLedger $ dncInsertOptions syncNodeConfigFromFile)
   -- Our main thread
   bracket
-    (runOrThrowIO $ HC.acquire [connSetting])
+    (runOrThrowIO $ HsqlC.acquire [dbConnSetting])
     release
-    (\connection -> do
+    (\dbConn -> do
         runOrThrowIO $ runExceptT $ do
-          let dbEnv = Db.DbEnv connection (dncEnableDbLogging syncNodeConfigFromFile)
+          let dbEnv = Db.DbEnv dbConn (dncEnableDbLogging syncNodeConfigFromFile)
           genCfg <- readCardanoGenesisConfig syncNodeConfigFromFile
           isJsonbInSchema <- queryIsJsonbInSchema dbEnv
           logProtocolMagicId trce $ genesisProtocolMagicId genCfg

cardano-db-sync/src/Cardano/DbSync/Api.hs

@@ -119,7 +119,7 @@ getIsConsumedFixed env =
   where
     txOutTableType = getTxOutTableType env
     pcm = soptPruneConsumeMigration $ envOptions env
-    backend = envBackend env
+    backend = envDbEnv env
 
 getDisableInOutState :: SyncEnv -> IO Bool
 getDisableInOutState syncEnv = do
@@ -172,7 +172,7 @@ runRemoveJsonbFromSchema
   => SyncEnv
   -> DbAction e m ()
 runRemoveJsonbFromSchema syncEnv = do
-  DB.runDbTx DB.Write transx
+  DB.runDbT DB.Write transx
   where
     dbEnv = envDbEnv syncEnv
     transx = mkDbTransaction "runRemoveJsonbFromSchema" mkCallSite (DB.disableJsonbInSchema (dbConnection dbEnv))
@@ -285,12 +285,12 @@ getDbLatestBlockInfo backend = do
 
 getDbTipBlockNo :: SyncEnv -> IO (Point.WithOrigin BlockNo)
 getDbTipBlockNo env = do
-  mblk <- getDbLatestBlockInfo (envBackend env)
+  mblk <- getDbLatestBlockInfo (envDbEnv env)
   pure $ maybe Point.Origin (Point.At . bBlockNo) mblk
 
 logDbState :: SyncEnv -> IO ()
 logDbState env = do
-  mblk <- getDbLatestBlockInfo (envBackend env)
+  mblk <- getDbLatestBlockInfo (envDbEnv env)
   case mblk of
     Nothing -> logInfo tracer "Database is empty"
     Just tip -> logInfo tracer $ mconcat ["Database tip is at ", showTip tip]
@@ -309,7 +309,7 @@ logDbState env = do
 
 getCurrentTipBlockNo :: SyncEnv -> IO (WithOrigin BlockNo)
 getCurrentTipBlockNo env = do
-  maybeTip <- getDbLatestBlockInfo (envBackend env)
+  maybeTip <- getDbLatestBlockInfo (envDbEnv env)
   case maybeTip of
     Just tip -> pure $ At (bBlockNo tip)
     Nothing -> pure Origin
@@ -512,7 +512,7 @@ getLatestPoints env = do
       verifySnapshotPoint env snapshotPoints
     NoLedger _ -> do
       -- Brings the 5 latest.
-      lastPoints <- DB.runDbIohkNoLogging (envBackend env) DB.queryLatestPoints
+      lastPoints <- DB.runDbIohkNoLogging (envDbEnv env) DB.queryLatestPoints
       pure $ mapMaybe convert lastPoints
   where
     convert (Nothing, _) = Nothing
@@ -524,7 +524,7 @@ verifySnapshotPoint env snapPoints =
   where
     validLedgerFileToPoint :: SnapshotPoint -> IO (Maybe (CardanoPoint, Bool))
     validLedgerFileToPoint (OnDisk lsf) = do
-      hashes <- getSlotHash (envBackend env) (lsfSlotNo lsf)
+      hashes <- getSlotHash (envDbEnv env) (lsfSlotNo lsf)
       let valid = find (\(_, h) -> lsfHash lsf == hashToAnnotation h) hashes
       case valid of
         Just (slot, hash) | slot == lsfSlotNo lsf -> pure $ convertToDiskPoint slot hash
@@ -533,7 +533,7 @@ verifySnapshotPoint env snapPoints =
       case pnt of
         GenesisPoint -> pure Nothing
         BlockPoint slotNo hsh -> do
-          hashes <- getSlotHash (envBackend env) slotNo
+          hashes <- getSlotHash (envDbEnv env) slotNo
           let valid = find (\(_, dbHash) -> getHeaderHash hsh == dbHash) hashes
           case valid of
             Just (dbSlotNo, _) | slotNo == dbSlotNo -> pure $ Just (pnt, True)

cardano-db-sync/src/Cardano/DbSync/Default.hs

@@ -51,7 +51,7 @@ insertListBlocks ::
   [CardanoBlock] ->
   IO (Either SyncNodeError ())
 insertListBlocks synEnv blocks = do
-  DB.runDbIohkLogging (envBackend synEnv) tracer
+  DB.runDbIohkLogging (envDbEnv synEnv) tracer
     . runExceptT
     $ traverse_ (applyAndInsertBlockMaybe synEnv tracer) blocks
   where

cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/GovAction.hs

@@ -335,7 +335,7 @@ insertCommitteeHash cred = do
 insertDrep :: (MonadBaseControl IO m, MonadIO m) => DRep -> ReaderT SqlBackend m DB.DrepHashId
 insertDrep = \case
   DRepCredential cred -> insertCredDrepHash cred
-  DRepAlwaysAbstain -> DB.insertAlwaysAbstainDrep
+  DRepAlwaysAbstain -> DB.insertDrepHashAlwaysAbstain
   DRepAlwaysNoConfidence -> DB.insertAlwaysNoConfidence
 
 insertCredDrepHash :: (MonadBaseControl IO m, MonadIO m) => Ledger.Credential 'DRepRole -> ReaderT SqlBackend m DB.DrepHashId

cardano-db-sync/src/Cardano/DbSync/Error.hs

@@ -42,7 +42,7 @@ data SyncInvariant
 
 data SyncNodeError
   = SNErrDefault !Text
-  | SNErrDbTransaction !DB.DbError
+  | SNErrDatabase !DB.DbError
   | SNErrInvariant !Text !SyncInvariant
   | SNEErrBlockMismatch !Word64 !ByteString !ByteString
   | SNErrIgnoreShelleyInitiation
@@ -67,7 +67,7 @@ instance Show SyncNodeError where
   show =
     \case
       SNErrDefault t -> "Error SNErrDefault: " <> show t
-      SNErrDbTransaction err -> "Error SNErrDbTransaction: " <> show err
+      SNErrDatabase err -> "Error SNErrDatabase: " <> show err
       SNErrInvariant loc i -> "Error SNErrInvariant: " <> Show.show loc <> ": " <> show (renderSyncInvariant i)
       SNEErrBlockMismatch blkNo hashDb hashBlk ->
         mconcat

cardano-db/src/Cardano/Db/Error.hs

@@ -7,78 +7,85 @@ module Cardano.Db.Error (
   AsDbError (..),
   CallSite (..),
   DbError (..),
-  LookupFail (..),
   runOrThrowIODb,
+  runOrThrowIO,
   logAndThrowIO,
+  base16encode
 ) where
 
 import Cardano.BM.Trace (Trace, logError)
 import Cardano.Db.Schema.Ids
-import Cardano.Prelude (throwIO)
+import Cardano.Prelude (throwIO, MonadIO)
 import Control.Exception (Exception)
 import Data.ByteString.Char8 (ByteString)
 import Data.Text (Text)
 import Data.Word (Word16, Word64)
 import GHC.Generics (Generic)
 import qualified Data.ByteString.Base16 as Base16
 import qualified Data.Text.Encoding as Text
-import qualified Hasql.Session as HasqlS
+import qualified Hasql.Session as HsqlS
 
 class AsDbError e where
   toDbError :: DbError -> e
   fromDbError :: e -> Maybe DbError
 
 data DbError
-  = QueryError !Text !CallSite !HasqlS.SessionError
-  | DecodingError !Text !CallSite !HasqlS.RowError
-  | ConnectionError !Text !CallSite
-  | TransactionError !Text !CallSite
+  = DbError !CallSite !Text !HsqlS.SessionError
+  | DbLookupError !CallSite !Text !LookupContext
   deriving (Show, Eq)
 
+instance Exception DbError
+
 data CallSite = CallSite
   { csModule :: !Text
   , csFile :: !Text
   , csLine :: !Int
   } deriving (Show, Eq)
 
-data LookupFail
-  = DbLookupBlockHash !ByteString
-  | DbLookupBlockId !Word64
-  | DbLookupMessage !Text
-  | DbLookupTxHash !ByteString
-  | DbLookupTxOutPair !ByteString !Word16
-  | DbLookupEpochNo !Word64
-  | DbLookupSlotNo !Word64
-  | DbLookupGovActionPair !TxId !Word64
-  | DbMetaEmpty
-  | DbMetaMultipleRows
-  | DBMultipleGenesis
-  | DBExtraMigration !String
-  | DBPruneConsumed !String
-  | DBRJsonbInSchema !String
-  | DBTxOutVariant !String
-  deriving (Eq, Generic)
+data LookupContext
+  = BlockHashContext !ByteString
+  | BlockIdContext !Word64
+  | MessageContext !Text
+  | TxHashContext !ByteString
+  | TxOutPairContext !ByteString !Word16
+  | EpochNoContext !Word64
+  | SlotNoContext !Word64
+  | GovActionPairContext !TxId !Word64
+  | MetaEmptyContext
+  | MetaMultipleRowsContext
+  | MultipleGenesisContext
+  | ExtraMigrationContext !String
+  | PruneConsumedContext !String
+  | RJsonbInSchemaContext !String
+  | TxOutVariantContext !String
+  deriving (Show, Eq, Generic)
+
+instance Exception LookupContext
 
-instance Exception LookupFail
+-- catchDbError :: String -> HsqlT.Transaction a -> HsqlT.Transaction a
+-- catchDbError context action =
+--   action `catch` \e ->
+--     throwError $ DbError $ context ++ ": " ++ show e
 
-instance Show LookupFail where
-  show =
-    \case
-      DbLookupBlockHash h -> "The block hash " <> show (base16encode h) <> " is missing from the DB."
-      DbLookupBlockId blkid -> "block id " <> show blkid
-      DbLookupMessage txt -> show txt
-      DbLookupTxHash h -> "tx hash " <> show (base16encode h)
-      DbLookupTxOutPair h i -> concat ["tx out pair (", show $ base16encode h, ", ", show i, ")"]
-      DbLookupEpochNo e -> "epoch number " ++ show e
-      DbLookupSlotNo s -> "slot number " ++ show s
-      DbLookupGovActionPair txId index -> concat ["missing GovAction (", show txId, ", ", show index, ")"]
-      DbMetaEmpty -> "Meta table is empty"
-      DbMetaMultipleRows -> "Multiple rows in Meta table which should only contain one"
-      DBMultipleGenesis -> "Multiple Genesis blocks found. These are blocks without an EpochNo"
-      DBExtraMigration e -> "DBExtraMigration : " <> e
-      DBPruneConsumed e -> "DBExtraMigration" <> e
-      DBRJsonbInSchema e -> "DBRJsonbInSchema" <> e
-      DBTxOutVariant e -> "DbTxOutVariant" <> e
+
+-- instance Show LookupFail where
+--   show =
+--     \case
+--       DbLookupBlockHash h -> "The block hash " <> show (base16encode h) <> " is missing from the DB."
+--       DbLookupBlockId blkid -> "block id " <> show blkid
+--       DbLookupMessage txt -> show txt
+--       DbLookupTxHash h -> "tx hash " <> show (base16encode h)
+--       DbLookupTxOutPair h i -> concat ["tx out pair (", show $ base16encode h, ", ", show i, ")"]
+--       DbLookupEpochNo e -> "epoch number " ++ show e
+--       DbLookupSlotNo s -> "slot number " ++ show s
+--       DbLookupGovActionPair txId index -> concat ["missing GovAction (", show txId, ", ", show index, ")"]
+--       DbMetaEmpty -> "Meta table is empty"
+--       DbMetaMultipleRows -> "Multiple rows in Meta table which should only contain one"
+--       DBMultipleGenesis -> "Multiple Genesis blocks found. These are blocks without an EpochNo"
+--       DBExtraMigration e -> "DBExtraMigration : " <> e
+--       DBPruneConsumed e -> "DBExtraMigration" <> e
+--       DBRJsonbInSchema e -> "DBRJsonbInSchema" <> e
+--       DBTxOutVariant e -> "DbTxOutVariant" <> e
 
 base16encode :: ByteString -> Text
 base16encode = Text.decodeUtf8 . Base16.encode
@@ -90,6 +97,13 @@ runOrThrowIODb ioEither = do
     Left err -> throwIO err
     Right a -> pure a
 
+runOrThrowIO :: forall e a m. (MonadIO m) => (Exception e) => m (Either e a) -> m a
+runOrThrowIO ioEither = do
+  et <- ioEither
+  case et of
+    Left err -> throwIO err
+    Right a -> pure a
+
 logAndThrowIO :: Trace IO Text -> Text -> IO a
 logAndThrowIO tracer msg = do
   logError tracer msg