View on GitHub
File Changes

                      
import           Database.Persist.Postgresql (withPostgresqlConn, openSimpleConn)
import           Database.PostgreSQL.Simple (connectPostgreSQL)
-
import           Database.Persist.Sql (SqlBackend, runSqlConn)
+
import           Database.Persist.Sql (SqlBackend, IsolationLevel (..), runSqlConnWithIsolation)

                      
import           Database.Esqueleto
import           Database.Esqueleto.Internal.Sql
    pgconf <- readPGPassFileEnv
    runHandleLoggerT .
      withPostgresqlConn (toConnectionString pgconf) $ \backend ->
-
        -- The 'runSqlConn' function starts a transaction, runs the 'dbAction'
+
        -- The 'runSqlConnWithIsolation' function starts a transaction, runs the 'dbAction'
        -- and then commits the transaction.
-
        runSqlConn dbAction backend
+
        runSqlConnWithIsolation dbAction backend Serializable
  where
    runHandleLoggerT :: LoggingT m a -> m a
    runHandleLoggerT action =
    pgconf <- readPGPassFileEnv
    (runIohkLogging tracer) .
      withPostgresqlConn (toConnectionString pgconf) $ \backend ->
-
        runSqlConn dbAction backend
+
        runSqlConnWithIsolation dbAction backend Serializable

                      
runIohkLogging :: Trace IO Text -> LoggingT m a -> m a
runIohkLogging tracer action =
  pgconfig <- readPGPassFileEnv
  runNoLoggingT .
    withPostgresqlConn (toConnectionString pgconfig) $ \backend ->
-
      runSqlConn action backend
+
      runSqlConnWithIsolation action backend Serializable

                      
-- | Run a DB action with stdout logging. Mainly for debugging.
runDbStdoutLogging :: ReaderT SqlBackend (LoggingT IO) b -> IO b
runDbStdoutLogging action = do
  pgconfig <- readPGPassFileEnv
  runStdoutLoggingT .
    withPostgresqlConn (toConnectionString pgconfig) $ \backend ->
-
      runSqlConn action backend
+
      runSqlConnWithIsolation action backend Serializable

                      
-- from Control.Monad.Logger, wasnt exported
defaultOutput :: Handle
                      , cardano-explorer-db-test
                      , containers
                      , monad-logger
+
                      , persistent
                      , persistent-postgresql
                      , tasty
                      , tasty-hunit
                      , text
                      , transformers
+
                      , unliftio-core
import           Data.Time.Clock.POSIX (POSIXTime, utcTimeToPOSIXSeconds)
import           Data.Word (Word16, Word64)

                      
-
import           Database.Persist.Sql (SqlBackend, runSqlConn)
+
import           Database.Persist.Sql (IsolationLevel (..), SqlBackend, runSqlConnWithIsolation)

                      
import           Explorer.DB (Block (..), TxId)

                      

                      
runQuery :: MonadIO m => SqlBackend -> ReaderT SqlBackend IO a -> m a
runQuery backend query =
-
  liftIO $ runSqlConn query backend
+
  liftIO $ runSqlConnWithIsolation query backend Serializable

                      
slotsPerEpoch :: Word64
slotsPerEpoch = k * 10
{-# LANGUAGE OverloadedStrings #-}
+
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -Wno-error=orphans #-}
-
{-# LANGUAGE ScopedTypeVariables #-}
+
{-# OPTIONS_GHC -fno-warn-orphans #-}

                      
module Test.IO.Explorer.Web.Query where

                      
-
import           Test.Tasty (TestTree, testGroup)
-
import           Test.Tasty.HUnit (testCase)
-

                      
-
import           Explorer.DB
-
import           Explorer.Web.Query
-
import           Test.IO.Explorer.DB.Util (assertBool, dummyUTCTime, mkBlockHash, testSlotLeader)
+
import           Control.Monad.IO.Class (MonadIO, liftIO)
+
import           Control.Monad.IO.Unlift (MonadUnliftIO)
+
import           Control.Monad.Logger (LoggingT, runLoggingT, runStdoutLoggingT)
+
import           Control.Monad.Trans.Reader (ReaderT, runReaderT)

                      
-
import           Control.Monad.IO.Class (liftIO, MonadIO)
-
import           Control.Monad.Logger
-
import           Control.Monad.Trans.Reader
import           Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as BS
import           Data.Set (fromList, empty)
import           Data.Text (Text)
import           Data.Text.Encoding (decodeUtf8)
import           Data.Word (Word16, Word64)
-
import           Database.Persist.Postgresql
+
import           Database.Persist.Sql (PersistValue, IsolationLevel (..), SqlBackend,
+
                    runSqlConnWithIsolation)
+
import           Database.Persist.Postgresql (rawExecute, withPostgresqlConn)
+

                      
+
import           Explorer.DB
+
import           Explorer.Web.Query
+

                      
+
import           Test.IO.Explorer.DB.Util (assertBool, dummyUTCTime, mkBlockHash, testSlotLeader)
+

                      
+
import           Test.Tasty (TestTree, testGroup)
+
import           Test.Tasty.HUnit (testCase)
+

                      

                      
tests :: TestTree
tests =
  print pgconfig
  loggingMode . withPostgresqlConn (toConnectionString pgconfig) $ action

                      
+

                      
testEmptyUtxo :: IO ()
testEmptyUtxo = do
-
  dropAndRemakeDbThenTest $ \backend -> flip runSqlConn backend $ do
+
  dropAndRemakeDbThenTest $ \backend -> runSqlAction backend $ do
    slid <- insertSlotLeader testSlotLeader
    bid0 <- insertBlock (blockZero slid)
    snapshot <- queryUtxoSnapshot bid0
testCase1 :: IO ()
testCase1 = do
  dropAndRemakeDbThenTest $ \backend -> do
-
    let
-
      g = flip runSqlConn backend
-
    (slid, bid0) <- g $ do
+
    (slid, bid0) <- runSqlAction backend $ do
      slid <- insertSlotLeader testSlotLeader
      bid0 <- insertBlock $ blockZero slid
      pure (slid, bid0)

                      
-
    snapshot00 <- g $ do
+
    snapshot00 <- runSqlAction backend $ do
      snapshot00 <- fromList <$> queryUtxoSnapshot bid0
      assertBool "utxo must be empty when no outputs exist" (snapshot00 == empty)
      pure snapshot00

                      
-
    (bid1, expected1, out1, tx0, tx0id) <- g $ do
+
    (bid1, expected1, out1, tx0, tx0id) <- runSqlAction backend $ do
      bid1 <- insertBlock $ mkBlock 1 slid bid0
      let tx0 = mkTx 0 bid1
      tx0id <- insertTx tx0
      mapM_ insertTxOut [ out0, out1 ]
      pure (bid1, expected1, out1, tx0, tx0id)

                      
-
    snapshot10 <- g $ do
+
    snapshot10 <- runSqlAction backend $ do
      snapshot01 <- fromList <$> queryUtxoSnapshot bid0
      assertBool "snapshot at point 0 must not change when inserting new blocks" (snapshot00 == snapshot01)
      snapshot10 <- fromList <$> queryUtxoSnapshot bid1
      assertBool "snapshot at point 1 should be expected value" (snapshot10 == expected1)
      pure snapshot10

                      
-
    (bid2, tx1, out2, expected2) <- g $ do
+
    (bid2, tx1, out2, expected2) <- runSqlAction backend $ do
      bid2 <- insertBlock $ mkBlock 2 slid bid1
      let tx1 = mkTx 1 bid2
      tx1id <- insertTx tx1
      _ <- insertTxOut out2
      pure (bid2, tx1, out2, expected2)

                      
-
    (snapshot20) <- g $ do
+
    (snapshot20) <- runSqlAction backend $ do
      snapshot02 <- fromList <$> queryUtxoSnapshot bid0
      snapshot11 <- fromList <$> queryUtxoSnapshot bid1
      snapshot20 <- fromList <$> queryUtxoSnapshot bid2
      assertBool "snapshot at point 2 should be expected value" (snapshot20 == expected2)
      pure (snapshot20)

                      
-
    (bid3, expected3) <- g $ do
+
    (bid3, expected3) <- runSqlAction backend $ do
      bid3 <- insertBlock $ mkBlock 3 slid bid2
      let tx2 = mkTx 2 bid3
      tx2id <- insertTx tx2
      _ <- insertTxOut out3
      pure (bid3, expected3)

                      
-
    g $ do
+
    runSqlAction backend $ do
      snapshot03 <- fromList <$> queryUtxoSnapshot bid0
      snapshot12 <- fromList <$> queryUtxoSnapshot bid1
      snapshot21 <- fromList <$> queryUtxoSnapshot bid2
deriving instance Eq TxOut
deriving instance Ord TxOut

                      
+
runSqlAction :: MonadUnliftIO m => SqlBackend -> ReaderT SqlBackend m a -> m a
+
runSqlAction backend action =
+
  runSqlConnWithIsolation action backend Serializable
+

                      
blockZero :: SlotLeaderId -> Block
blockZero slid =
  Block (mkHash '\0') Nothing Nothing Nothing Nothing Nothing slid 0 dummyUTCTime 0
+
# Atomicity of PostgreSQL Interactions
+

                      
+
Both the webapi and the node which populates the database operate on the database within a
+
database transaction. All operations on the database from Haskell code is done in a function
+
which has a type signatures of :
+
```
+
ReaderT SqlBackend m a
+
```
+
Any function without the `ReaderT SqlBackend` component will not be able to access the database
+
and any attempt to access the database without the required type signature will result in a compile
+
error at compile time.
+

                      
+
All functions with the required file type are run with the function provided by Haskell's
+
[Persistent][Persistent] library:
+
```
+
runSqlConnWithIsolation action backend Serializable
+
```
+
where:
+
* `runSqlConnWithIsolation` is the function that runs the provided `action` on a connection to
+
  the database within a database transaction.
+
* `action` is the action to be performed on the database (eg write or query).
+
* `backend` contains the database connection data.
+
* `Serializable` specifies the transaction isolation level.
+

                      
+
In this case the `Serializable` [transaction isolation][PosgresIso] level is used which is the
+
*maximum* level of transaction isolation.
+

                      
+
[Persistent]: https://hackage.haskell.org/package/persistent
+
[PosgresIso]: https://www.postgresql.org/docs/current/transaction-iso.html
+

                      
            (hsPkgs."cardano-explorer-db-test" or (buildDepError "cardano-explorer-db-test"))
            (hsPkgs."containers" or (buildDepError "containers"))
            (hsPkgs."monad-logger" or (buildDepError "monad-logger"))
+
            (hsPkgs."persistent" or (buildDepError "persistent"))
            (hsPkgs."persistent-postgresql" or (buildDepError "persistent-postgresql"))
            (hsPkgs."tasty" or (buildDepError "tasty"))
            (hsPkgs."tasty-hunit" or (buildDepError "tasty-hunit"))
            (hsPkgs."text" or (buildDepError "text"))
            (hsPkgs."transformers" or (buildDepError "transformers"))
+
            (hsPkgs."unliftio-core" or (buildDepError "unliftio-core"))
            ];
          buildable = true;
          };