refactor(cardano-chain-gen): Add a Query module

Author: sgillespie

cardano-chain-gen/cardano-chain-gen.cabal

@@ -44,6 +44,7 @@ library
                         Cardano.Mock.ChainDB
                         Cardano.Mock.ChainSync.Server
                         Cardano.Mock.ChainSync.State
+                        Cardano.Mock.Query
                         Cardano.Mock.Forging.Crypto
                         Cardano.Mock.Forging.Interpreter
                         Cardano.Mock.Forging.Tx.Alonzo
@@ -63,6 +64,7 @@ library
                       , bytestring
                       , cardano-binary
                       , cardano-crypto-class
+                      , cardano-db
                       , cardano-ledger-allegra
                       , cardano-ledger-alonzo
                       , cardano-ledger-babbage
@@ -78,6 +80,7 @@ library
                       , containers
                       , contra-tracer
                       , directory
+                      , esqueleto
                       , extra
                       , mtl
                       , microlens

cardano-chain-gen/src/Cardano/Mock/Query.hs

@@ -0,0 +1,43 @@
+{-# LANGUAGE TypeApplications #-}
+
+module Cardano.Mock.Query (
+  queryVersionMajorFromEpoch,
+  queryParamProposalFromEpoch,
+) where
+
+import qualified Cardano.Db as Db
+import Cardano.Prelude hiding (from)
+import Database.Esqueleto.Experimental
+import Prelude ()
+
+-- | Query protocol parameters from @EpochParam@ by epoch number. Note that epoch
+--   parameters are inserted at the beginning of the next epoch.
+--
+-- TODO[sgillespie]: It would probably be better to return @Db.EpochParam@, but
+-- persistent seems to be having trouble with the data:
+--
+--     PersistMarshalError "Couldn't parse field `govActionLifetime` from table
+--     `epoch_param`. Failed to parse Haskell type `Word64`; expected integer from
+--     database, but received: PersistRational (0 % 1).
+queryVersionMajorFromEpoch ::
+  MonadIO io =>
+  Word64 ->
+  ReaderT SqlBackend io (Maybe Word16)
+queryVersionMajorFromEpoch epochNo = do
+  res <- selectOne $ do
+    prop <- from $ table @Db.EpochParam
+    where_ (prop ^. Db.EpochParamEpochNo ==. val epochNo)
+    pure (prop ^. Db.EpochParamProtocolMajor)
+  pure $ unValue <$> res
+
+-- | Query protocol parameter proposals from @ParamProposal@ by epoch number.
+queryParamProposalFromEpoch ::
+  MonadIO io =>
+  Word64 ->
+  ReaderT SqlBackend io (Maybe Db.ParamProposal)
+queryParamProposalFromEpoch epochNo = do
+  res <- selectOne $ do
+    prop <- from $ table @Db.ParamProposal
+    where_ $ prop ^. Db.ParamProposalEpochNo ==. val (Just epochNo)
+    pure prop
+  pure $ entityVal <$> res

cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Other.hs

@@ -4,7 +4,6 @@
 {-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications #-}
 
 module Test.Cardano.Db.Mock.Unit.Conway.Other (
   -- * Different configs
@@ -33,16 +32,16 @@ import Cardano.Ledger.Credential (StakeCredential ())
 import Cardano.Ledger.Crypto (StandardCrypto ())
 import Cardano.Ledger.Keys (KeyHash (), KeyRole (..))
 import Cardano.Mock.ChainSync.Server (IOManager (), addBlock, rollback)
-import Cardano.Mock.Forging.Interpreter (Interpreter (), forgeNext, getCurrentEpoch)
+import Cardano.Mock.Forging.Interpreter (forgeNext, getCurrentEpoch)
 import qualified Cardano.Mock.Forging.Tx.Babbage as Babbage
 import qualified Cardano.Mock.Forging.Tx.Conway as Conway
 import Cardano.Mock.Forging.Tx.Generic (resolvePool)
 import Cardano.Mock.Forging.Types
+import Cardano.Mock.Query (queryParamProposalFromEpoch, queryVersionMajorFromEpoch)
 import Cardano.Prelude hiding (from)
 import Cardano.SMASH.Server.PoolDataLayer (PoolDataLayer (..), dbToServantPoolId)
 import Cardano.SMASH.Server.Types (DBFail (..))
 import Data.List (last)
-import Database.Esqueleto.Experimental
 import Ouroboros.Consensus.Shelley.Eras (StandardConway ())
 import Ouroboros.Network.Block (blockPoint)
 import Test.Cardano.Db.Mock.Config
@@ -497,35 +496,9 @@ forkParam =
   where
     testLabel = "conwayForkParam"
     configDir = babbageConfigDir
-
-    queryCurrentMajVer ::
-      MonadIO m =>
-      Interpreter ->
-      ReaderT SqlBackend m (Maybe Word16)
-    queryCurrentMajVer interpreter = do
-      -- Look up current epoch from ledger
-      EpochNo currentEpoch <- liftIO $ getCurrentEpoch interpreter
-
-      -- Query epoch params from database
-      res <- selectOne $ do
-        param <- from $ table @Db.EpochParam
-        where_ (param ^. Db.EpochParamEpochNo ==. val currentEpoch)
-        pure (param ^. Db.EpochParamProtocolMajor)
-
-      pure $ unValue <$> res
-
-    queryMajVerProposal ::
-      MonadIO m =>
-      Interpreter ->
-      ReaderT SqlBackend m (Maybe Word16)
+    queryCurrentMajVer interpreter = queryVersionMajorFromEpoch =<< getEpochNo interpreter
     queryMajVerProposal interpreter = do
-      -- Look up current epoch from ledger
-      EpochNo currentEpoch <- liftIO $ getCurrentEpoch interpreter
-
-      -- Query proposals from database
-      res <- selectOne $ do
-        prop <- from $ table @Db.ParamProposal
-        where_ $ prop ^. Db.ParamProposalEpochNo ==. val (Just currentEpoch)
-        pure (prop ^. Db.ParamProposalProtocolMajor)
-
-      pure $ join (unValue <$> res)
+      epochNo <- getEpochNo interpreter
+      prop <- queryParamProposalFromEpoch epochNo
+      pure (Db.paramProposalProtocolMajor =<< prop)
+    getEpochNo = fmap unEpochNo . liftIO . getCurrentEpoch