From 4b8378042d9e794d4468b2ba3898bc6b10a0cb06 Mon Sep 17 00:00:00 2001 From: Cmdv Date: Fri, 13 Dec 2024 19:03:18 +0000 Subject: [PATCH] fourmolu the whole project with new version --- .../src/Cardano/Mock/Forging/Tx/Babbage.hs | 2 +- .../src/Cardano/Mock/Forging/Tx/Conway.hs | 146 ++++++------ .../Mock/Forging/Tx/Conway/Scenarios.hs | 4 +- cardano-chain-gen/src/Cardano/Mock/Query.hs | 34 +-- .../Conway/CommandLineArg/EpochDisabled.hs | 24 +- .../Config/MigrateConsumedPruneTxOut.hs | 48 ++-- .../Db/Mock/Unit/Conway/Config/Parse.hs | 11 +- .../Cardano/Db/Mock/Unit/Conway/Governance.hs | 35 +-- .../Db/Mock/Unit/Conway/InlineAndReference.hs | 126 +++++----- .../Test/Cardano/Db/Mock/Unit/Conway/Other.hs | 152 ++++++------ .../Cardano/Db/Mock/Unit/Conway/Plutus.hs | 170 +++++++------- .../Cardano/Db/Mock/Unit/Conway/Reward.hs | 30 +-- .../Cardano/Db/Mock/Unit/Conway/Rollback.hs | 24 +- .../Cardano/Db/Mock/Unit/Conway/Simple.hs | 5 +- .../Test/Cardano/Db/Mock/Unit/Conway/Stake.hs | 90 ++++---- .../Test/Cardano/Db/Mock/Unit/Conway/Tx.hs | 42 ++-- cardano-db-sync/app/cardano-db-sync.hs | 6 +- .../app/test-http-get-json-metadata.hs | 6 +- cardano-db-sync/src/Cardano/DbSync.hs | 98 ++++---- cardano-db-sync/src/Cardano/DbSync/Api.hs | 60 ++--- cardano-db-sync/src/Cardano/DbSync/Cache.hs | 102 ++++---- .../src/Cardano/DbSync/Cache/LRU.hs | 4 +- .../src/Cardano/DbSync/Cache/Types.hs | 9 +- cardano-db-sync/src/Cardano/DbSync/Config.hs | 4 +- .../src/Cardano/DbSync/Config/Conway.hs | 4 +- .../src/Cardano/DbSync/Config/Types.hs | 126 +++++++--- .../src/Cardano/DbSync/Database.hs | 40 ++-- cardano-db-sync/src/Cardano/DbSync/Default.hs | 48 ++-- cardano-db-sync/src/Cardano/DbSync/Epoch.hs | 30 +-- .../src/Cardano/DbSync/Era/Byron/Genesis.hs | 118 +++++----- .../src/Cardano/DbSync/Era/Byron/Insert.hs | 98 ++++---- .../src/Cardano/DbSync/Era/Cardano/Insert.hs | 5 +- .../DbSync/Era/Shelley/Generic/Script.hs | 18 +- .../DbSync/Era/Shelley/Generic/StakeDist.hs | 14 +- .../DbSync/Era/Shelley/Generic/Tx/Allegra.hs | 6 +- .../DbSync/Era/Shelley/Generic/Tx/Alonzo.hs | 40 ++-- .../src/Cardano/DbSync/Era/Shelley/Genesis.hs | 148 ++++++------ .../DbSync/Era/Shelley/ValidateWithdrawal.hs | 8 +- .../Cardano/DbSync/Era/Universal/Adjust.hs | 5 +- .../src/Cardano/DbSync/Era/Universal/Block.hs | 17 +- .../src/Cardano/DbSync/Era/Universal/Epoch.hs | 12 +- .../Era/Universal/Insert/Certificate.hs | 68 +++--- .../DbSync/Era/Universal/Insert/GovAction.hs | 129 +++++------ .../DbSync/Era/Universal/Insert/Grouped.hs | 30 ++- .../Era/Universal/Insert/LedgerEvent.hs | 14 +- .../DbSync/Era/Universal/Insert/Other.hs | 30 +-- .../DbSync/Era/Universal/Insert/Pool.hs | 12 +- .../Cardano/DbSync/Era/Universal/Insert/Tx.hs | 118 +++++----- .../Cardano/DbSync/Era/Universal/Validate.hs | 24 +- .../src/Cardano/DbSync/Era/Util.hs | 5 +- cardano-db-sync/src/Cardano/DbSync/Error.hs | 8 +- .../src/Cardano/DbSync/Ledger/Event.hs | 16 +- .../src/Cardano/DbSync/Ledger/State.hs | 105 ++++----- .../src/Cardano/DbSync/Ledger/Types.hs | 60 ++++- cardano-db-sync/src/Cardano/DbSync/Metrics.hs | 4 +- .../src/Cardano/DbSync/OffChain.hs | 74 +++--- .../src/Cardano/DbSync/OffChain/Http.hs | 14 +- .../src/Cardano/DbSync/OffChain/Query.hs | 41 ++-- .../src/Cardano/DbSync/OffChain/Types.hs | 12 +- .../src/Cardano/DbSync/OffChain/Vote/Types.hs | 2 +- .../src/Cardano/DbSync/Rollback.hs | 4 +- .../src/Cardano/DbSync/StateQuery.hs | 9 +- cardano-db-sync/src/Cardano/DbSync/Sync.hs | 217 +++++++++--------- .../src/Cardano/DbSync/Util/Bech32.hs | 4 +- .../src/Cardano/DbSync/Util/Cbor.hs | 8 +- .../test/Cardano/DbSync/ApiTest.hs | 4 +- .../test/Cardano/DbSync/Config/TypesTest.hs | 4 +- .../Era/Shelley/Generic/ScriptDataTest.hs | 4 +- .../DbSync/Era/Shelley/Generic/ScriptTest.hs | 4 +- .../test/Cardano/DbSync/Util/AddressTest.hs | 4 +- .../test/Cardano/DbSync/Util/Bech32Test.hs | 4 +- .../test/Cardano/DbSync/Util/CborTest.hs | 16 +- cardano-db-sync/test/Cardano/DbSyncTest.hs | 4 +- .../src/Cardano/DbTool/Report/Balance.hs | 24 +- .../DbTool/Report/StakeReward/History.hs | 16 +- .../DbTool/Report/StakeReward/Latest.hs | 16 +- .../src/Cardano/DbTool/Report/Transactions.hs | 52 ++--- .../src/Cardano/DbTool/Validate/AdaPots.hs | 8 +- .../src/Cardano/DbTool/Validate/BlockTxs.hs | 6 +- .../Cardano/DbTool/Validate/TxAccounting.hs | 14 +- .../src/Cardano/Db/Operations/Delete.hs | 2 +- .../Db/Operations/Other/ConsumedTxOut.hs | 2 +- .../Cardano/Db/Operations/Other/JsonbQuery.hs | 2 +- .../src/Cardano/Db/Operations/Other/MinId.hs | 20 +- cardano-db/src/Cardano/Db/Operations/Query.hs | 116 +++++----- .../Cardano/Db/Operations/TxOut/TxOutQuery.hs | 120 +++++----- cardano-db/src/Cardano/Db/Operations/Types.hs | 4 +- .../src/Cardano/Db/Version/V13_0/Query.hs | 30 +-- .../app/cardano-smash-server.hs | 11 +- .../src/Cardano/SMASH/Server/Config.hs | 4 +- .../src/Cardano/SMASH/Server/FetchPolicies.hs | 4 +- .../src/Cardano/SMASH/Server/Impl.hs | 14 +- .../src/Cardano/SMASH/Server/PoolDataLayer.hs | 19 +- .../src/Cardano/SMASH/Server/Run.hs | 16 +- .../src/Cardano/SMASH/Server/Types.hs | 10 +- 95 files changed, 1862 insertions(+), 1669 deletions(-) diff --git a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Babbage.hs b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Babbage.hs index f3dcd1156..af2a8d068 100644 --- a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Babbage.hs +++ b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Babbage.hs @@ -462,7 +462,7 @@ mkUTxOBabbage :: AlonzoTx StandardBabbage -> [(TxIn StandardCrypto, BabbageTxOut mkUTxOBabbage = mkUTxOAlonzo mkUTxOCollBabbage :: - (BabbageEraTxBody era) => + BabbageEraTxBody era => AlonzoTx era -> [(TxIn (EraCrypto era), TxOut era)] mkUTxOCollBabbage tx = Map.toList $ unUTxO $ collOuts $ getField @"body" tx diff --git a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Conway.hs b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Conway.hs index 92595988c..6df2adf87 100644 --- a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Conway.hs +++ b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Conway.hs @@ -227,17 +227,17 @@ mkPaymentTx' inputIndex outputIndices fees donation state' = do NoDatum SNothing - pure $ - mkSimpleTx True $ - consPaymentTxBody - inputs - mempty - mempty - (StrictSeq.fromList $ outputs <> [change]) - SNothing - (Coin fees) - mempty - (Coin donation) + pure + $ mkSimpleTx True + $ consPaymentTxBody + inputs + mempty + mempty + (StrictSeq.fromList $ outputs <> [change]) + SNothing + (Coin fees) + mempty + (Coin donation) where mkOutputs (outIx, val) = do addr <- resolveAddress outIx state' @@ -268,17 +268,17 @@ mkLockByScriptTx inputIndex txOutTypes amount fees state' = do NoDatum SNothing - pure $ - mkSimpleTx True $ - consPaymentTxBody - inputs - mempty - mempty - (StrictSeq.fromList $ outputs <> [change]) - SNothing - (Coin fees) - mempty - (Coin 0) + pure + $ mkSimpleTx True + $ consPaymentTxBody + inputs + mempty + mempty + (StrictSeq.fromList $ outputs <> [change]) + SNothing + (Coin fees) + mempty + (Coin 0) mkUnlockScriptTx :: [ConwayUTxOIndex] -> @@ -348,9 +348,9 @@ mkDCertPoolTx consDCert state' = do mkDCertTxPools :: ConwayLedgerState -> Either ForgingError (AlonzoTx StandardConway) mkDCertTxPools state' = - Right $ - mkSimpleTx True $ - consCertTxBody Nothing (allPoolStakeCert' state') (Withdrawals mempty) + Right + $ mkSimpleTx True + $ consCertTxBody Nothing (allPoolStakeCert' state') (Withdrawals mempty) mkSimpleTx :: Bool -> ConwayTxBody StandardConway -> AlonzoTx StandardConway mkSimpleTx isValid' txBody = @@ -394,9 +394,9 @@ mkScriptDCertTx consCert isValid' state' = do cred <- resolveStakeCreds stakeIndex state' pure $ mkDCert cred - pure $ - mkScriptTx isValid' (mapMaybe prepareRedeemer . zip [0 ..] $ consCert) $ - consCertTxBody Nothing dcerts (Withdrawals mempty) + pure + $ mkScriptTx isValid' (mapMaybe prepareRedeemer . zip [0 ..] $ consCert) + $ consCertTxBody Nothing dcerts (Withdrawals mempty) where prepareRedeemer (n, (StakeIndexScript bl, shouldAddRedeemer, _)) | not shouldAddRedeemer = Nothing @@ -428,24 +428,24 @@ mkMultiAssetsScriptTx inputIx colInputIx outputIx refInput minted succeeds fees refInputs' = Set.fromList $ map (fst . fst) refs colInputs' = Set.singleton $ fst colInput - pure $ - mkScriptTx succeeds (mkScriptInps (map fst inputs) ++ mkScriptMint' minted) $ - consTxBody - inputs' - colInputs' - refInputs' - (StrictSeq.fromList outputs) - SNothing - (Coin fees) - mempty - mempty -- TODO[sgillespie]: minted? - (Withdrawals mempty) - (Coin 0) + pure + $ mkScriptTx succeeds (mkScriptInps (map fst inputs) ++ mkScriptMint' minted) + $ consTxBody + inputs' + colInputs' + refInputs' + (StrictSeq.fromList outputs) + SNothing + (Coin fees) + mempty + mempty -- TODO[sgillespie]: minted? + (Withdrawals mempty) + (Coin 0) where mkOuts (outIx, val) = do addr <- resolveAddress outIx state' - pure $ - BabbageTxOut + pure + $ BabbageTxOut addr val (DatumHash $ hashData @StandardConway plutusDataList) @@ -468,19 +468,19 @@ mkDepositTxPools inputIndex deposit state' = do NoDatum SNothing - pure $ - mkSimpleTx True $ - consTxBody - input - mempty - mempty - (StrictSeq.fromList [change]) - SNothing - (Coin 0) - mempty - (allPoolStakeCert' state') - (Withdrawals mempty) - (Coin 0) + pure + $ mkSimpleTx True + $ consTxBody + input + mempty + mempty + (StrictSeq.fromList [change]) + SNothing + (Coin 0) + mempty + (allPoolStakeCert' state') + (Withdrawals mempty) + (Coin 0) mkRegisterDRepTx :: Credential 'DRepRole StandardCrypto -> @@ -663,8 +663,8 @@ mkFullTx n m state' = do refInputPairs <- fmap fst <$> mapM (`resolveUTxOIndex` state') refInputs collateralInput <- Set.singleton . fst . fst <$> resolveUTxOIndex collateralInputs state' - pure $ - AlonzoTx + pure + $ AlonzoTx { body = txBody (mkInputs inputPairs) @@ -748,8 +748,8 @@ mkFullTx n m state' = do , ConwayTxCertPool $ Core.RegPool poolParams1 , ConwayTxCertPool $ Core.RetirePool (Prelude.head unregisteredPools) (EpochNo 0) , ConwayTxCertDeleg $ ConwayUnRegCert (unregisteredStakeCredentials !! 2) SNothing - , ConwayTxCertDeleg $ - ConwayDelegCert + , ConwayTxCertDeleg + $ ConwayDelegCert (unregisteredStakeCredentials !! 1) (DelegStake $ unregisteredPools !! 2) ] @@ -766,8 +766,8 @@ mkFullTx n m state' = do -- Withdrawals withdrawals = - Withdrawals $ - Map.fromList + Withdrawals + $ Map.fromList [ (RewardAccount Testnet (unregisteredStakeCredentials !! 1), Coin 100) , (RewardAccount Testnet (unregisteredStakeCredentials !! 1), Coin 100) ] @@ -899,17 +899,17 @@ mkUnlockScriptTx' inputIndex colInputIndex outputIndex refInput colOut succeeds NoDatum SNothing - pure $ - mkScriptTx succeeds (mkScriptInps inputPairs) $ - consPaymentTxBody - inputs - colInputs - refInputs - (StrictSeq.singleton output) - (maybeToStrictMaybe colOut) - (Coin fees) - mempty - (Coin 0) + pure + $ mkScriptTx succeeds (mkScriptInps inputPairs) + $ consPaymentTxBody + inputs + colInputs + refInputs + (StrictSeq.singleton output) + (maybeToStrictMaybe colOut) + (Coin fees) + mempty + (Coin 0) allPoolStakeCert' :: ConwayLedgerState -> [ConwayTxCert StandardConway] allPoolStakeCert' st = map (mkRegTxCert SNothing) (getCreds st) diff --git a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Conway/Scenarios.hs b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Conway/Scenarios.hs index f3a3c4fba..9db1691d6 100644 --- a/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Conway/Scenarios.hs +++ b/cardano-chain-gen/src/Cardano/Mock/Forging/Tx/Conway/Scenarios.hs @@ -97,8 +97,8 @@ forgeBlocksChunked interpreter vs f = forM (chunksOf 500 vs) $ \blockCreds -> do registerDRepsAndDelegateVotes :: Interpreter -> IO CardanoBlock registerDRepsAndDelegateVotes interpreter = do blockTxs <- - withConwayLedgerState interpreter $ - registerDRepAndDelegateVotes' + withConwayLedgerState interpreter + $ registerDRepAndDelegateVotes' (Prelude.head unregisteredDRepIds) (StakeIndex 4) diff --git a/cardano-chain-gen/src/Cardano/Mock/Query.hs b/cardano-chain-gen/src/Cardano/Mock/Query.hs index a9ae27cde..4a6bd2727 100644 --- a/cardano-chain-gen/src/Cardano/Mock/Query.hs +++ b/cardano-chain-gen/src/Cardano/Mock/Query.hs @@ -98,8 +98,8 @@ queryDRepDistrAmount drepHash epochNo = do (distr :& hash) <- from $ table @Db.DrepDistr - `innerJoin` table @Db.DrepHash - `on` (\(distr :& hash) -> (hash ^. Db.DrepHashId) ==. (distr ^. Db.DrepDistrHashId)) + `innerJoin` table @Db.DrepHash + `on` (\(distr :& hash) -> (hash ^. Db.DrepHashId) ==. (distr ^. Db.DrepDistrHashId)) where_ $ hash ^. Db.DrepHashRaw ==. just (val drepHash) where_ $ distr ^. Db.DrepDistrEpochNo ==. val epochNo @@ -140,14 +140,14 @@ queryConstitutionAnchor epochNo = do (_ :& anchor :& epochState) <- from $ table @Db.Constitution - `innerJoin` table @Db.VotingAnchor - `on` ( \(constit :& anchor) -> - (constit ^. Db.ConstitutionVotingAnchorId) ==. (anchor ^. Db.VotingAnchorId) - ) - `innerJoin` table @Db.EpochState - `on` ( \(constit :& _ :& epoch) -> - just (constit ^. Db.ConstitutionId) ==. (epoch ^. Db.EpochStateConstitutionId) - ) + `innerJoin` table @Db.VotingAnchor + `on` ( \(constit :& anchor) -> + (constit ^. Db.ConstitutionVotingAnchorId) ==. (anchor ^. Db.VotingAnchorId) + ) + `innerJoin` table @Db.EpochState + `on` ( \(constit :& _ :& epoch) -> + just (constit ^. Db.ConstitutionId) ==. (epoch ^. Db.EpochStateConstitutionId) + ) where_ (epochState ^. Db.EpochStateEpochNo ==. val epochNo) @@ -193,11 +193,13 @@ queryVoteCounts txHash idx = do (vote :& tx) <- from $ table @Db.VotingProcedure - `innerJoin` table @Db.Tx - `on` (\(vote :& tx) -> vote ^. Db.VotingProcedureTxId ==. tx ^. Db.TxId) - where_ $ - vote ^. Db.VotingProcedureVote ==. val v - &&. tx ^. Db.TxHash ==. val txHash - &&. vote ^. Db.VotingProcedureIndex ==. val idx + `innerJoin` table @Db.Tx + `on` (\(vote :& tx) -> vote ^. Db.VotingProcedureTxId ==. tx ^. Db.TxId) + where_ + $ vote + ^. Db.VotingProcedureVote + ==. val v + &&. tx ^. Db.TxHash ==. val txHash + &&. vote ^. Db.VotingProcedureIndex ==. val idx pure countRows pure (maybe 0 unValue res) diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/CommandLineArg/EpochDisabled.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/CommandLineArg/EpochDisabled.hs index 607a72821..a51b21722 100644 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/CommandLineArg/EpochDisabled.hs +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/CommandLineArg/EpochDisabled.hs @@ -24,12 +24,12 @@ checkEpochDisabledArg = -- Forge some blocks void $ forgeAndSubmitBlocks interpreter mockServer 50 -- Add two blocks with transactions - void $ - withConwayFindLeaderAndSubmitTx interpreter mockServer $ - Conway.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10_000 10_000 0 - void $ - withConwayFindLeaderAndSubmitTx interpreter mockServer $ - Conway.mkPaymentTx (UTxOIndex 1) (UTxOIndex 0) 10_000 10_000 0 + void + $ withConwayFindLeaderAndSubmitTx interpreter mockServer + $ Conway.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10_000 10_000 0 + void + $ withConwayFindLeaderAndSubmitTx interpreter mockServer + $ Conway.mkPaymentTx (UTxOIndex 1) (UTxOIndex 0) 10_000 10_000 0 -- Add some more empty blocks void $ forgeAndSubmitBlocks interpreter mockServer 60 @@ -48,12 +48,12 @@ checkEpochEnabled = -- Forge some blocks void $ forgeAndSubmitBlocks interpreter mockServer 50 -- Add two blocks with transactions - void $ - withConwayFindLeaderAndSubmitTx interpreter mockServer $ - Conway.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10_000 10_000 0 - void $ - withConwayFindLeaderAndSubmitTx interpreter mockServer $ - Conway.mkPaymentTx (UTxOIndex 1) (UTxOIndex 0) 10_000 10_000 0 + void + $ withConwayFindLeaderAndSubmitTx interpreter mockServer + $ Conway.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10_000 10_000 0 + void + $ withConwayFindLeaderAndSubmitTx interpreter mockServer + $ Conway.mkPaymentTx (UTxOIndex 1) (UTxOIndex 0) 10_000 10_000 0 -- Add some more empty blocks void $ forgeAndSubmitBlocks interpreter mockServer 60 diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Config/MigrateConsumedPruneTxOut.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Config/MigrateConsumedPruneTxOut.hs index 2d8f723f9..e13be4fd1 100644 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Config/MigrateConsumedPruneTxOut.hs +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Config/MigrateConsumedPruneTxOut.hs @@ -66,12 +66,12 @@ performBasicPrune useTxOutAddress = do blks <- forgeAndSubmitBlocks interpreter mockServer 50 -- Add blocks with transactions - void $ - withConwayFindLeaderAndSubmitTx interpreter mockServer $ - Conway.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10_000 10_000 0 - void $ - withConwayFindLeaderAndSubmitTx interpreter mockServer $ - Conway.mkPaymentTx (UTxOIndex 1) (UTxOIndex 0) 10_000 10_000 0 + void + $ withConwayFindLeaderAndSubmitTx interpreter mockServer + $ Conway.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10_000 10_000 0 + void + $ withConwayFindLeaderAndSubmitTx interpreter mockServer + $ Conway.mkPaymentTx (UTxOIndex 1) (UTxOIndex 0) 10_000 10_000 0 -- Check tx-out count before pruning assertBlockNoBackoff dbSync (fullBlockSize blks) @@ -109,12 +109,12 @@ performPruneWithSimpleRollback useTxOutAddress = atomically $ addBlock mockServer blk1 -- Create some payment transactions - void $ - withConwayFindLeaderAndSubmitTx interpreter mockServer $ - Conway.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10_000 10_000 0 - void $ - withConwayFindLeaderAndSubmitTx interpreter mockServer $ - Conway.mkPaymentTx (UTxOIndex 1) (UTxOIndex 0) 10_000 10_000 0 + void + $ withConwayFindLeaderAndSubmitTx interpreter mockServer + $ Conway.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10_000 10_000 0 + void + $ withConwayFindLeaderAndSubmitTx interpreter mockServer + $ Conway.mkPaymentTx (UTxOIndex 1) (UTxOIndex 0) 10_000 10_000 0 assertEqQuery dbSync (DB.queryTxOutCount txOutTableType) 14 "" -- Submit some blocks @@ -193,12 +193,12 @@ performPruningShouldKeepSomeTx useTxOutAddress = do blk1 <- forgeAndSubmitBlocks interpreter mockServer 80 -- These two blocks/transactions will fall within the last (2 * securityParam) 20 -- blocks so should not be pruned - void $ - withConwayFindLeaderAndSubmitTx interpreter mockServer $ - Conway.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10_000 10_000 0 - void $ - withConwayFindLeaderAndSubmitTx interpreter mockServer $ - Conway.mkPaymentTx (UTxOIndex 2) (UTxOIndex 3) 10_000 10_000 0 + void + $ withConwayFindLeaderAndSubmitTx interpreter mockServer + $ Conway.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10_000 10_000 0 + void + $ withConwayFindLeaderAndSubmitTx interpreter mockServer + $ Conway.mkPaymentTx (UTxOIndex 2) (UTxOIndex 3) 10_000 10_000 0 blk2 <- forgeAndSubmitBlocks interpreter mockServer 18 -- Verify the two transactions above weren't pruned assertBlockNoBackoff dbSync (fromIntegral $ length (blk1 <> blk2) + 2) @@ -230,9 +230,9 @@ performPruneAndRollBackOneBlock useTxOutAddress = void $ forgeAndSubmitBlocks interpreter mockServer 98 -- These transactions will fall within the last (2 * securityParam) 20 -- blocks so should not be pruned - void $ - withConwayFindLeaderAndSubmitTx interpreter mockServer $ - Conway.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10_000 10_000 0 + void + $ withConwayFindLeaderAndSubmitTx interpreter mockServer + $ Conway.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10_000 10_000 0 -- Create a block to rollback to blk100 <- forgeNextFindLeaderAndSubmit interpreter mockServer [] state' <- getConwayLedgerState interpreter @@ -275,9 +275,9 @@ performNoPruneAndRollBack useTxOutAddress = -- Forge some blocks void $ forgeAndSubmitBlocks interpreter mockServer 98 -- Add a block with transactions - void $ - withConwayFindLeaderAndSubmitTx interpreter mockServer $ - Conway.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10_000 10_000 0 + void + $ withConwayFindLeaderAndSubmitTx interpreter mockServer + $ Conway.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10_000 10_000 0 -- Create a block to rollback to blk100 <- forgeNextFindLeaderAndSubmit interpreter mockServer [] -- Add some more blocks diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Config/Parse.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Config/Parse.hs index 50dedf206..048cd85e6 100644 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Config/Parse.hs +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Config/Parse.hs @@ -23,7 +23,8 @@ import Prelude () conwayGenesis :: Assertion conwayGenesis = mkSyncNodeConfig configDir initCommandLineArgs - >>= void . mkConfig configDir mutableDir cmdLineArgs + >>= void + . mkConfig configDir mutableDir cmdLineArgs where configDir = "config-conway" mutableDir = mkMutableDir "conwayConfigSimple" @@ -44,8 +45,8 @@ noConwayGenesis :: Assertion noConwayGenesis = do cfg <- mkSyncNodeConfig configDir initCommandLineArgs let cfg' = cfg {dncConwayGenesisFile = Nothing} - void $ - mkConfig configDir mutableDir cmdLineArgs cfg' + void + $ mkConfig configDir mutableDir cmdLineArgs cfg' where configDir = "config-conway" mutableDir = mkMutableDir "conwayConfigNoGenesis" @@ -55,8 +56,8 @@ noConwayGenesisHash :: Assertion noConwayGenesisHash = do cfg <- mkSyncNodeConfig configDir initCommandLineArgs let cfg' = cfg {dncConwayGenesisHash = Nothing} - void $ - mkConfig configDir mutableDir initCommandLineArgs cfg' + void + $ mkConfig configDir mutableDir initCommandLineArgs cfg' where configDir = "config-conway" mutableDir = mkMutableDir "conwayConfigNoGenesis" diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Governance.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Governance.hs index 455b06aea..d50714d08 100644 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Governance.hs +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Governance.hs @@ -88,8 +88,9 @@ newCommittee = let committeeHash = "e0a714319812c3f773ba04ec5d6b3ffcd5aad85006805b047b082541" committeeCred = KeyHashObj (KeyHash committeeHash) - void $ - Api.withConwayFindLeaderAndSubmit interpreter server $ \ledger -> do + void + $ Api.withConwayFindLeaderAndSubmit interpreter server + $ \ledger -> do let -- Create gov action tx addCcTx = Conway.mkAddCommitteeTx committeeCred @@ -145,8 +146,9 @@ updateConstitution = anchor = Governance.Anchor newUrl dataHash -- Create and vote for a governance proposal - void $ - Api.withConwayFindLeaderAndSubmit interpreter server $ \_ -> do + void + $ Api.withConwayFindLeaderAndSubmit interpreter server + $ \_ -> do let -- Create gov action tx proposalTx = Conway.mkNewConstitutionTx anchor @@ -199,13 +201,15 @@ treasuryWithdrawal = void (Api.registerCommitteeCreds interpreter server) -- Make sure we have treasury to spend - void $ - Api.withConwayFindLeaderAndSubmitTx interpreter server $ \_ -> + void + $ Api.withConwayFindLeaderAndSubmitTx interpreter server + $ \_ -> Right $ Conway.mkDonationTx (Coin 50_000) -- Create and vote for a governance proposal - void $ - Api.withConwayFindLeaderAndSubmit interpreter server $ \ledger -> do + void + $ Api.withConwayFindLeaderAndSubmit interpreter server + $ \ledger -> do rewardAccount <- RewardAccount Testnet <$> Forging.resolveStakeCreds (StakeIndex 0) ledger @@ -259,8 +263,9 @@ parameterChange = void (Api.registerCommitteeCreds interpreter server) -- Create and vote for gov action - void $ - Api.withConwayFindLeaderAndSubmit interpreter server $ \ledger -> do + void + $ Api.withConwayFindLeaderAndSubmit interpreter server + $ \ledger -> do let -- Create gov action tx govActionTx = Conway.mkParamChangeTx @@ -323,8 +328,9 @@ hardFork = void (Api.registerCommitteeCreds interpreter server) -- Create and vote for gov action - void $ - Api.withConwayFindLeaderAndSubmit interpreter server $ \ledger -> do + void + $ Api.withConwayFindLeaderAndSubmit interpreter server + $ \ledger -> do let -- Create gov action tx govActionTx = Conway.mkHardForkInitTx @@ -412,8 +418,9 @@ infoAction = } -- Submit them - void $ - Api.withConwayFindLeaderAndSubmit interpreter server $ \_ -> + void + $ Api.withConwayFindLeaderAndSubmit interpreter server + $ \_ -> pure [govActionTx, addVoteTx] -- There is no ratification/enactment for info actions, so let it expire diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/InlineAndReference.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/InlineAndReference.hs index 3a7e5b7b2..2478f43cd 100644 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/InlineAndReference.hs +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/InlineAndReference.hs @@ -47,29 +47,29 @@ unlockDatumOutput = void $ Api.registerAllStakeCreds interpreter mockServer -- Forge a tx with a lock script tx <- - withConwayLedgerState interpreter $ - Conway.mkLockByScriptTx + withConwayLedgerState interpreter + $ Conway.mkLockByScriptTx (UTxOIndex 0) [Conway.TxOutInline True Conway.InlineDatum Conway.NoReferenceScript] 20_000 20_000 -- Add it to a block - void $ - Api.forgeNextAndSubmit interpreter mockServer $ - MockBlock [TxConway tx] (NodeId 1) + void + $ Api.forgeNextAndSubmit interpreter mockServer + $ MockBlock [TxConway tx] (NodeId 1) let utxo = head (Conway.mkUTxOConway tx) - void $ - Api.withConwayFindLeaderAndSubmitTx interpreter mockServer $ - Conway.mkUnlockScriptTxBabbage - [UTxOPair utxo] - (UTxOIndex 1) - (UTxOIndex 2) - [UTxOPair utxo] - False - True - 10_000 - 500 + void + $ Api.withConwayFindLeaderAndSubmitTx interpreter mockServer + $ Conway.mkUnlockScriptTxBabbage + [UTxOPair utxo] + (UTxOIndex 1) + (UTxOIndex 2) + [UTxOPair utxo] + False + True + 10_000 + 500 -- Wait for it to sync assertBlockNoBackoff dbSync 3 @@ -118,9 +118,9 @@ unlockDatumOutputSameBlock = pure [tx0, tx1] -- Add the transactions to a block - void $ - Api.forgeNextAndSubmit interpreter mockServer $ - MockBlock (TxConway <$> txs') (NodeId 1) + void + $ Api.forgeNextAndSubmit interpreter mockServer + $ MockBlock (TxConway <$> txs') (NodeId 1) -- Wait for it to sync assertBlockNoBackoff dbSync 2 @@ -140,8 +140,8 @@ inlineDatumCBOR = void $ Api.registerAllStakeCreds interpreter mockServer -- Forge a transaction with inline datum cbor tx <- - withConwayLedgerState interpreter $ - Conway.mkLockByScriptTx + withConwayLedgerState interpreter + $ Conway.mkLockByScriptTx (UTxOIndex 0) [ Conway.TxOutInline True @@ -151,9 +151,9 @@ inlineDatumCBOR = 20_000 20_000 -- Add it to a block - void $ - Api.forgeNextAndSubmit interpreter mockServer $ - MockBlock [TxConway tx] (NodeId 1) + void + $ Api.forgeNextAndSubmit interpreter mockServer + $ MockBlock [TxConway tx] (NodeId 1) -- Wait for it to sync assertBlockNoBackoff dbSync 2 @@ -171,30 +171,30 @@ spendRefScript = void $ Api.registerAllStakeCreds interpreter mockServer -- Forge a tx with a script tx <- - withConwayLedgerState interpreter $ - Conway.mkLockByScriptTx + withConwayLedgerState interpreter + $ Conway.mkLockByScriptTx (UTxOIndex 0) [Conway.TxOutInline True Conway.NotInlineDatum (Conway.ReferenceScript True)] 20_000 20_000 -- Add it to a block - void $ - Api.forgeNextAndSubmit interpreter mockServer $ - MockBlock [TxConway tx] (NodeId 1) + void + $ Api.forgeNextAndSubmit interpreter mockServer + $ MockBlock [TxConway tx] (NodeId 1) -- Spend the utxo from above let utxo = head (Conway.mkUTxOConway tx) - void $ - Api.withConwayFindLeaderAndSubmitTx interpreter mockServer $ - Conway.mkUnlockScriptTxBabbage - [UTxOPair utxo] - (UTxOIndex 1) - (UTxOAddress Examples.alwaysSucceedsScriptAddr) - [UTxOPair utxo] - False - True - 10_000 - 500 + void + $ Api.withConwayFindLeaderAndSubmitTx interpreter mockServer + $ Conway.mkUnlockScriptTxBabbage + [UTxOPair utxo] + (UTxOIndex 1) + (UTxOAddress Examples.alwaysSucceedsScriptAddr) + [UTxOPair utxo] + False + True + 10_000 + 500 -- Wait for it to sync assertBlockNoBackoff dbSync 3 @@ -243,9 +243,9 @@ spendRefScriptSameBlock = pure [tx0, tx1] -- Add them to a block - void $ - Api.forgeNextAndSubmit interpreter mockServer $ - MockBlock (TxConway <$> txs') (NodeId 1) + void + $ Api.forgeNextAndSubmit interpreter mockServer + $ MockBlock (TxConway <$> txs') (NodeId 1) -- Wait for it to sync assertBlockNoBackoff dbSync 2 @@ -266,16 +266,16 @@ spendCollateralOutput = -- Forge a transaction with a script tx0 <- - withConwayLedgerState interpreter $ - Conway.mkLockByScriptTx (UTxOIndex 0) [Conway.TxOutNoInline False] 20_000 20_000 + withConwayLedgerState interpreter + $ Conway.mkLockByScriptTx (UTxOIndex 0) [Conway.TxOutNoInline False] 20_000 20_000 -- Add it to a block void $ Api.forgeNextFindLeaderAndSubmit interpreter mockServer [TxConway tx0] -- tx fails, so its collateral output becomes actual output let utxo0 = head (Conway.mkUTxOConway tx0) tx1 <- - withConwayLedgerState interpreter $ - Conway.mkUnlockScriptTxBabbage + withConwayLedgerState interpreter + $ Conway.mkUnlockScriptTxBabbage [UTxOInput (fst utxo0)] (UTxOIndex 1) (UTxOIndex 2) @@ -292,8 +292,8 @@ spendCollateralOutput = -- Spend collateral output from tx1 let utxo1 = head (Conway.mkUTxOCollConway tx1) tx2 <- - withConwayLedgerState interpreter $ - Conway.mkUnlockScriptTxBabbage + withConwayLedgerState interpreter + $ Conway.mkUnlockScriptTxBabbage [UTxOPair utxo1] (UTxOIndex 3) (UTxOIndex 1) @@ -342,16 +342,16 @@ spendCollateralOutputRollback = mkSpendCollOutput interpreter mockServer dbSync n = do -- Forge a tx with a lock script tx0 <- - withConwayLedgerState interpreter $ - Conway.mkLockByScriptTx (UTxOIndex 0) [Conway.TxOutNoInline False] 20_000 20_000 + withConwayLedgerState interpreter + $ Conway.mkLockByScriptTx (UTxOIndex 0) [Conway.TxOutNoInline False] 20_000 20_000 -- Add it to a block void $ Api.forgeNextFindLeaderAndSubmit interpreter mockServer [TxConway tx0] -- Create a failing tx so its collateral becomes actual output let utxo0 = head (Conway.mkUTxOConway tx0) tx1 <- - withConwayLedgerState interpreter $ - Conway.mkUnlockScriptTxBabbage + withConwayLedgerState interpreter + $ Conway.mkUnlockScriptTxBabbage [UTxOInput (fst utxo0)] (UTxOIndex 1) (UTxOIndex 2) @@ -368,8 +368,8 @@ spendCollateralOutputRollback = -- Create a succeeding transaction that spends the failing tx's outputs let utxo1 = head (Conway.mkUTxOCollConway tx1) tx2 <- - withConwayLedgerState interpreter $ - Conway.mkUnlockScriptTxBabbage + withConwayLedgerState interpreter + $ Conway.mkUnlockScriptTxBabbage [UTxOPair utxo1] (UTxOIndex 3) (UTxOIndex 1) @@ -497,8 +497,8 @@ supplyScriptsTwoWays = void $ Api.registerAllStakeCreds interpreter mockServer -- Create a lock script tx0 <- - withConwayLedgerState interpreter $ - Conway.mkLockByScriptTx + withConwayLedgerState interpreter + $ Conway.mkLockByScriptTx (UTxOIndex 0) [ Conway.TxOutInline True Conway.InlineDatum (Conway.ReferenceScript True) , Conway.TxOutNoInline True @@ -512,8 +512,8 @@ supplyScriptsTwoWays = let utxos = Conway.mkUTxOConway tx0 (utxo0, utxo1) = (head utxos, utxos !! 1) tx1 <- - withConwayLedgerState interpreter $ - Conway.mkUnlockScriptTxBabbage + withConwayLedgerState interpreter + $ Conway.mkUnlockScriptTxBabbage [UTxOPair utxo0, UTxOPair utxo1] (UTxOIndex 1) (UTxOIndex 2) @@ -598,8 +598,8 @@ referenceMintingScript = -- Use a reference to an output which has a minting script let utxo = head (Conway.mkUTxOConway tx0) val = - MultiAsset $ - Map.singleton + MultiAsset + $ Map.singleton (PolicyID Examples.alwaysSucceedsScriptHash) (Map.singleton (head Examples.assetNames) 1) tx1 <- @@ -646,8 +646,8 @@ referenceDelegation = -- Create a tx with a reference to an output which has a minting script let utxo = head (Conway.mkUTxOConway tx0) val = - MultiAsset $ - Map.singleton + MultiAsset + $ Map.singleton (PolicyID Examples.alwaysSucceedsScriptHash) (Map.singleton (head Examples.assetNames) 1) tx1 <- diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Other.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Other.hs index 08d24d37c..144ed1ddc 100644 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Other.hs +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Other.hs @@ -124,15 +124,15 @@ poolReg = assertEqual "Unexpected init pool counter" (3, 0, 3, 2, 0, 0) initCounter -- Forge a pool registration - void $ - Api.withConwayFindLeaderAndSubmitTx interpreter mockServer $ - Conway.mkDCertPoolTx - [ - ( [StakeIndexNew 0, StakeIndexNew 1, StakeIndexNew 2] - , PoolIndexNew 0 - , Conway.consTxCertPool - ) - ] + void + $ Api.withConwayFindLeaderAndSubmitTx interpreter mockServer + $ Conway.mkDCertPoolTx + [ + ( [StakeIndexNew 0, StakeIndexNew 1, StakeIndexNew 2] + , PoolIndexNew 0 + , Conway.consTxCertPool + ) + ] -- Verify pool counts assertBlockNoBackoff dbSync 2 @@ -181,18 +181,18 @@ poolDeReg = assertEqual "Unexpected init pool counter" (3, 0, 3, 2, 0, 0) initCounter -- Forge a registration/deregistration - void $ - Api.withConwayFindLeaderAndSubmitTx interpreter mockServer $ - Conway.mkDCertPoolTx - [ -- Register a pool - - ( [StakeIndexNew 0, StakeIndexNew 1, StakeIndexNew 2] - , PoolIndexNew 0 - , Conway.consTxCertPool - ) - , -- Retire it - ([], PoolIndexNew 0, \_ poolId -> ConwayTxCertPool $ RetirePool poolId (EpochNo 1)) - ] + void + $ Api.withConwayFindLeaderAndSubmitTx interpreter mockServer + $ Conway.mkDCertPoolTx + [ -- Register a pool + + ( [StakeIndexNew 0, StakeIndexNew 1, StakeIndexNew 2] + , PoolIndexNew 0 + , Conway.consTxCertPool + ) + , -- Retire it + ([], PoolIndexNew 0, \_ poolId -> ConwayTxCertPool $ RetirePool poolId (EpochNo 1)) + ] -- Wait for it to sync assertBlockNoBackoff dbSync 2 -- Should have added two pool owners @@ -236,31 +236,31 @@ poolDeRegMany = assertEqual "Unexpected init pool counter" (3, 0, 3, 2, 0, 0) initCounter -- Forge pool registrations and deregistrations - void $ - Api.withConwayFindLeaderAndSubmitTx interpreter mockServer $ - Conway.mkDCertPoolTx - [ -- Register - - ( [StakeIndexNew 0, StakeIndexNew 1, StakeIndexNew 2] - , PoolIndexNew 0 - , Conway.consTxCertPool - ) - , -- Deregister - ([], PoolIndexNew 0, mkPoolDereg (EpochNo 4)) - , -- Register--this will be deduplicated by the ledger, so counts - -- below will not include this cert - - ( [StakeIndexNew 0, StakeIndexNew 1, StakeIndexNew 2] - , PoolIndexNew 0 - , Conway.consTxCertPool - ) - , -- Register with different owner and reward address - - ( [StakeIndexNew 2, StakeIndexNew 1, StakeIndexNew 0] - , PoolIndexNew 0 - , Conway.consTxCertPool - ) - ] + void + $ Api.withConwayFindLeaderAndSubmitTx interpreter mockServer + $ Conway.mkDCertPoolTx + [ -- Register + + ( [StakeIndexNew 0, StakeIndexNew 1, StakeIndexNew 2] + , PoolIndexNew 0 + , Conway.consTxCertPool + ) + , -- Deregister + ([], PoolIndexNew 0, mkPoolDereg (EpochNo 4)) + , -- Register--this will be deduplicated by the ledger, so counts + -- below will not include this cert + + ( [StakeIndexNew 0, StakeIndexNew 1, StakeIndexNew 2] + , PoolIndexNew 0 + , Conway.consTxCertPool + ) + , -- Register with different owner and reward address + + ( [StakeIndexNew 2, StakeIndexNew 1, StakeIndexNew 0] + , PoolIndexNew 0 + , Conway.consTxCertPool + ) + ] -- Forge another block with more reg/dereg void $ Api.withConwayFindLeaderAndSubmit interpreter mockServer $ \state' -> @@ -334,16 +334,16 @@ poolDelist = assertEqual "Unexpected init pool counter" (3, 0, 3, 2, 0, 0) initCounter -- Register a new pool - void $ - Api.withConwayFindLeaderAndSubmitTx interpreter mockServer $ - Conway.mkDCertPoolTx - [ -- Register - - ( [StakeIndexNew 0, StakeIndexNew 1, StakeIndexNew 2] - , PoolIndexNew 0 - , Conway.consTxCertPool - ) - ] + void + $ Api.withConwayFindLeaderAndSubmitTx interpreter mockServer + $ Conway.mkDCertPoolTx + [ -- Register + + ( [StakeIndexNew 0, StakeIndexNew 1, StakeIndexNew 2] + , PoolIndexNew 0 + , Conway.consTxCertPool + ) + ] -- Forge another block void $ Api.forgeNextFindLeaderAndSubmit interpreter mockServer [] @@ -371,9 +371,9 @@ poolDelist = [(PoolIndexNew 0, (Right False, True, True))] state' - void $ - Api.withConwayFindLeaderAndSubmitTx interpreter mockServer $ - Conway.mkDCertPoolTx [([], PoolIndexNew 0, mkPoolDereg (EpochNo 1))] + void + $ Api.withConwayFindLeaderAndSubmitTx interpreter mockServer + $ Conway.mkDCertPoolTx [([], PoolIndexNew 0, mkPoolDereg (EpochNo 1))] void $ Api.forgeNextFindLeaderAndSubmit interpreter mockServer [] where @@ -392,16 +392,16 @@ forkFixedEpoch = startDBSync dbSync -- Add a Babbage tx - void $ - Api.withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10_000 500 + void + $ Api.withBabbageFindLeaderAndSubmitTx interpreter mockServer + $ Babbage.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10_000 500 -- Initiate a hard fork epochs0 <- Api.fillEpochs interpreter mockServer 2 -- Add a simple Conway tx - void $ - Api.withConwayFindLeaderAndSubmitTx interpreter mockServer $ - Conway.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10_000 500 0 + void + $ Api.withConwayFindLeaderAndSubmitTx interpreter mockServer + $ Conway.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10_000 500 0 -- Fill the rest of the epoch epochs1 <- Api.fillUntilNextEpoch interpreter mockServer @@ -417,9 +417,9 @@ rollbackFork = startDBSync dbSync -- Forge a Babbage tx - void $ - Api.withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - Babbage.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10_000 500 + void + $ Api.withBabbageFindLeaderAndSubmitTx interpreter mockServer + $ Babbage.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10_000 500 -- Fill the rest of the epoch epoch0 <- Api.fillUntilNextEpoch interpreter mockServer -- Create a point to rollback to @@ -428,8 +428,8 @@ rollbackFork = epoch1' <- Api.fillUntilNextEpoch interpreter mockServer -- Forge a Conway tx blk <- - Api.withConwayFindLeaderAndSubmitTx interpreter mockServer $ - Conway.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10_000 500 0 + Api.withConwayFindLeaderAndSubmitTx interpreter mockServer + $ Conway.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10_000 500 0 -- Wait for it to sync assertBlockNoBackoff dbSync $ 2 + length (epoch0 <> epoch1 <> epoch1') @@ -462,9 +462,9 @@ forkParam = "Unexpected protocol major version" -- Propose a parameter update - void $ - Api.withBabbageFindLeaderAndSubmitTx interpreter mockServer $ - const Babbage.mkParamUpdateTx + void + $ Api.withBabbageFindLeaderAndSubmitTx interpreter mockServer + $ const Babbage.mkParamUpdateTx -- Wait for it to sync assertBlockNoBackoff dbSync (1 + length epoch0) -- Query protocol param proposals @@ -488,9 +488,9 @@ forkParam = "Unexpected protocol major version" -- Add a simple Conway tx - void $ - Api.withConwayFindLeaderAndSubmitTx interpreter mockServer $ - Conway.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10_000 500 0 + void + $ Api.withConwayFindLeaderAndSubmitTx interpreter mockServer + $ Conway.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10_000 500 0 -- Wait for it to sync assertBlockNoBackoff dbSync $ 2 + length (epoch0 <> epoch1) where diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Plutus.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Plutus.hs index 541786e3e..300617fd9 100644 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Plutus.hs +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Plutus.hs @@ -88,9 +88,9 @@ simpleScript = epoch <- Api.fillUntilNextEpoch interpreter mockServer -- Forge a block with a script - void $ - Api.withConwayFindLeaderAndSubmitTx interpreter mockServer $ - Conway.mkLockByScriptTx (UTxOIndex 0) [Conway.TxOutNoInline True] 20_000 20_000 + void + $ Api.withConwayFindLeaderAndSubmitTx interpreter mockServer + $ Conway.mkLockByScriptTx (UTxOIndex 0) [Conway.TxOutNoInline True] 20_000 20_000 -- Verify the outputs match expected assertBlockNoBackoff dbSync (length epoch + 2) @@ -123,8 +123,8 @@ simpleScript = ( renderAddress Examples.alwaysSucceedsScriptAddr , True , DB.DbLovelace 20_000 - , Just $ - hashToBytes (extractHash $ hashData @StandardConway Examples.plutusDataList) + , Just + $ hashToBytes (extractHash $ hashData @StandardConway Examples.plutusDataList) ) unlockScriptSameBlock :: IOManager -> [(Text, Text)] -> Assertion @@ -171,17 +171,17 @@ unlockScriptNoPlutus = -- Lock some funds lockTx <- - withConwayLedgerState interpreter $ - Conway.mkLockByScriptTx (UTxOIndex 0) [Conway.TxOutNoInline True] 20_000 20_000 + withConwayLedgerState interpreter + $ Conway.mkLockByScriptTx (UTxOIndex 0) [Conway.TxOutNoInline True] 20_000 20_000 -- Unlock the funds above with a script let utxos = map UTxOPair (Conway.mkUTxOConway lockTx) unlockTx <- - withConwayLedgerState interpreter $ - Conway.mkUnlockScriptTx utxos (UTxOIndex 1) (UTxOIndex 2) True 10_000 500 + withConwayLedgerState interpreter + $ Conway.mkUnlockScriptTx utxos (UTxOIndex 1) (UTxOIndex 2) True 10_000 500 -- Submit them - void $ - Api.forgeNextFindLeaderAndSubmit + void + $ Api.forgeNextFindLeaderAndSubmit interpreter mockServer (map TxConway [lockTx, unlockTx]) @@ -204,23 +204,23 @@ failedScript = -- Forge a block with a script tx <- - withConwayLedgerState interpreter $ - Conway.mkLockByScriptTx (UTxOIndex 0) [Conway.TxOutNoInline False] 20_000 20_000 - void $ - Api.forgeNextAndSubmit interpreter mockServer $ - MockBlock [TxConway tx] (NodeId 1) + withConwayLedgerState interpreter + $ Conway.mkLockByScriptTx (UTxOIndex 0) [Conway.TxOutNoInline False] 20_000 20_000 + void + $ Api.forgeNextAndSubmit interpreter mockServer + $ MockBlock [TxConway tx] (NodeId 1) -- Forge another block with a failing unlock script let utxo = head (Conway.mkUTxOConway tx) - void $ - Api.withConwayFindLeaderAndSubmitTx interpreter mockServer $ - Conway.mkUnlockScriptTx - [UTxOPair utxo] - (UTxOIndex 1) - (UTxOIndex 2) - False -- Force failure - 10_000 - 500 + void + $ Api.withConwayFindLeaderAndSubmitTx interpreter mockServer + $ Conway.mkUnlockScriptTx + [UTxOPair utxo] + (UTxOIndex 1) + (UTxOIndex 2) + False -- Force failure + 10_000 + 500 -- Verify the invalid tx counts assertBlockNoBackoff dbSync 2 @@ -235,23 +235,23 @@ failedScriptFees = -- Forge a block with a lock script tx <- - withConwayLedgerState interpreter $ - Conway.mkLockByScriptTx (UTxOIndex 0) [Conway.TxOutNoInline False] 20_000 20_000 - void $ - Api.forgeNextAndSubmit interpreter mockServer $ - MockBlock [TxConway tx] (NodeId 1) + withConwayLedgerState interpreter + $ Conway.mkLockByScriptTx (UTxOIndex 0) [Conway.TxOutNoInline False] 20_000 20_000 + void + $ Api.forgeNextAndSubmit interpreter mockServer + $ MockBlock [TxConway tx] (NodeId 1) -- Forge another block with a failing unlock script let utxo = head (Conway.mkUTxOConway tx) - void $ - Api.withConwayFindLeaderAndSubmitTx interpreter mockServer $ - Conway.mkUnlockScriptTx - [UTxOPair utxo] - (UTxOIndex 1) - (UTxOIndex 2) - False -- Force failure - 10_000 - 500 + void + $ Api.withConwayFindLeaderAndSubmitTx interpreter mockServer + $ Conway.mkUnlockScriptTx + [UTxOPair utxo] + (UTxOIndex 1) + (UTxOIndex 2) + False -- Force failure + 10_000 + 500 -- Verify fees assertBlockNoBackoff dbSync 2 @@ -305,8 +305,8 @@ multipleScripts = -- Forge multiple script transactions tx0 <- - withConwayLedgerState interpreter $ - Conway.mkLockByScriptTx + withConwayLedgerState interpreter + $ Conway.mkLockByScriptTx (UTxOIndex 0) (map Conway.TxOutNoInline [True, False, True]) 20_000 @@ -315,8 +315,8 @@ multipleScripts = pair1 = head utxo pair2 = utxo !! 2 tx1 <- - withConwayLedgerState interpreter $ - Conway.mkUnlockScriptTx + withConwayLedgerState interpreter + $ Conway.mkUnlockScriptTx [UTxOPair pair1, UTxOPair pair2] (UTxOIndex 1) (UTxOIndex 2) @@ -325,12 +325,12 @@ multipleScripts = 500 -- Submit the txs in separate blocks - void $ - Api.forgeNextAndSubmit interpreter mockServer $ - MockBlock [TxConway tx0] (NodeId 1) - void $ - Api.forgeNextAndSubmit interpreter mockServer $ - MockBlock [TxConway tx1] (NodeId 1) + void + $ Api.forgeNextAndSubmit interpreter mockServer + $ MockBlock [TxConway tx0] (NodeId 1) + void + $ Api.forgeNextAndSubmit interpreter mockServer + $ MockBlock [TxConway tx1] (NodeId 1) -- Verify tx counts assertBlockNoBackoff dbSync 2 @@ -345,8 +345,8 @@ multipleScriptsRollback = -- Create multiple scripts tx0 <- - withConwayLedgerState interpreter $ - Conway.mkLockByScriptTx + withConwayLedgerState interpreter + $ Conway.mkLockByScriptTx (UTxOIndex 0) (map Conway.TxOutNoInline [True, False, True]) 20_000 @@ -355,8 +355,8 @@ multipleScriptsRollback = pair1 = head utxo pair2 = utxo !! 2 tx1 <- - withConwayLedgerState interpreter $ - Conway.mkUnlockScriptTx + withConwayLedgerState interpreter + $ Conway.mkUnlockScriptTx [UTxOPair pair1, UTxOPair pair2] (UTxOIndex 1) (UTxOIndex 2) @@ -365,12 +365,12 @@ multipleScriptsRollback = 500 -- Submit the txs in separate blocks - void $ - Api.forgeNextAndSubmit interpreter mockServer $ - MockBlock [TxConway tx0] (NodeId 1) - void $ - Api.forgeNextAndSubmit interpreter mockServer $ - MockBlock [TxConway tx1] (NodeId 1) + void + $ Api.forgeNextAndSubmit interpreter mockServer + $ MockBlock [TxConway tx0] (NodeId 1) + void + $ Api.forgeNextAndSubmit interpreter mockServer + $ MockBlock [TxConway tx1] (NodeId 1) -- Wait for it to sync assertBlockNoBackoff dbSync 2 @@ -382,12 +382,12 @@ multipleScriptsRollback = void $ Api.forgeNextFindLeaderAndSubmit interpreter mockServer [] -- Submit the txs again - void $ - Api.forgeNextAndSubmit interpreter mockServer $ - MockBlock [TxConway tx0] (NodeId 1) - void $ - Api.forgeNextAndSubmit interpreter mockServer $ - MockBlock [TxConway tx1] (NodeId 1) + void + $ Api.forgeNextAndSubmit interpreter mockServer + $ MockBlock [TxConway tx0] (NodeId 1) + void + $ Api.forgeNextAndSubmit interpreter mockServer + $ MockBlock [TxConway tx1] (NodeId 1) -- Verify tx counts assertBlockNoBackoff dbSync 3 @@ -435,30 +435,30 @@ multipleScriptsFailed = -- Forge a block with multiple scripts tx0 <- - withConwayLedgerState interpreter $ - Conway.mkLockByScriptTx + withConwayLedgerState interpreter + $ Conway.mkLockByScriptTx (UTxOIndex 0) (map Conway.TxOutNoInline [True, False, True]) 20_000 20_000 - void $ - Api.forgeNextAndSubmit interpreter mockServer $ - MockBlock [TxConway tx0] (NodeId 1) + void + $ Api.forgeNextAndSubmit interpreter mockServer + $ MockBlock [TxConway tx0] (NodeId 1) -- Forge another block with failing scripts let utxos = Conway.mkUTxOConway tx0 tx1 <- - withConwayLedgerState interpreter $ - Conway.mkUnlockScriptTx + withConwayLedgerState interpreter + $ Conway.mkUnlockScriptTx (map UTxOPair utxos) (UTxOIndex 1) (UTxOIndex 2) False -- Force failure 10_000 500 - void $ - Api.forgeNextAndSubmit interpreter mockServer $ - MockBlock [TxConway tx1] (NodeId 1) + void + $ Api.forgeNextAndSubmit interpreter mockServer + $ MockBlock [TxConway tx1] (NodeId 1) -- Verify failed txs assertBlockNoBackoff dbSync 2 @@ -505,9 +505,9 @@ registrationScriptTx = startDBSync dbSync -- Forge a transaction with a registration cert - void $ - Api.withConwayFindLeaderAndSubmitTx interpreter mockServer $ - Conway.mkSimpleDCertTx [(StakeIndexScript True, Conway.mkRegTxCert SNothing)] + void + $ Api.withConwayFindLeaderAndSubmitTx interpreter mockServer + $ Conway.mkSimpleDCertTx [(StakeIndexScript True, Conway.mkRegTxCert SNothing)] -- Verify stake address script counts assertBlockNoBackoff dbSync 1 @@ -676,8 +676,8 @@ mintMultiAsset = -- Forge a block with a multi-asset script void $ Api.withConwayFindLeaderAndSubmitTx interpreter mockServer $ \state' -> do let val = - MultiAsset $ - Map.singleton + MultiAsset + $ Map.singleton (PolicyID Examples.alwaysMintScriptHash) (Map.singleton (head Examples.assetNames) 1) Conway.mkMultiAssetsScriptTx @@ -747,14 +747,14 @@ swapMultiAssets = policy0 = PolicyID Examples.alwaysMintScriptHash policy1 = PolicyID Examples.alwaysSucceedsScriptHash mintValue = - MultiAsset $ - Map.fromList [(policy0, assetsMinted), (policy1, assetsMinted)] + MultiAsset + $ Map.fromList [(policy0, assetsMinted), (policy1, assetsMinted)] assets = Map.fromList [(head Examples.assetNames, 5), (Examples.assetNames !! 1, 2)] outValue = - MaryValue (Coin 20) $ - MultiAsset $ - Map.fromList [(policy0, assets), (policy1, assets)] + MaryValue (Coin 20) + $ MultiAsset + $ Map.fromList [(policy0, assets), (policy1, assets)] -- Forge a multi-asset script tx0 <- diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Reward.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Reward.hs index 2799a942e..2c51d4961 100644 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Reward.hs +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Reward.hs @@ -30,9 +30,9 @@ simpleRewards = void $ Api.registerAllStakeCreds interpreter mockServer -- Pools are not registered yet, this takes 2 epochs, so fees of this tx should not -- create any rewards - void $ - Api.withConwayFindLeaderAndSubmitTx interpreter mockServer $ - Conway.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 1000 1000 0 + void + $ Api.withConwayFindLeaderAndSubmitTx interpreter mockServer + $ Conway.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 1000 1000 0 -- Fill up epochs epochs <- Api.fillEpochs interpreter mockServer 3 @@ -54,9 +54,9 @@ simpleRewards = -- Now that pools are registered, add a tx to fill the fees pot so rewards will be -- distributed - void $ - Api.withConwayFindLeaderAndSubmitTx interpreter mockServer $ - Conway.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10_000 10_000 0 + void + $ Api.withConwayFindLeaderAndSubmitTx interpreter mockServer + $ Conway.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10_000 10_000 0 -- Fill more epochs epochs' <- Api.fillEpochs interpreter mockServer 2 -- Wait for it to sync @@ -95,9 +95,9 @@ rewardsShelley = void $ Api.registerAllStakeCreds interpreter mockServer -- Pools are not registered yet, this takes 2 epochs, so fees of this tx should not -- create any rewards - void $ - Api.withShelleyFindLeaderAndSubmitTx interpreter mockServer $ - Shelley.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10_000 10_000 + void + $ Api.withShelleyFindLeaderAndSubmitTx interpreter mockServer + $ Shelley.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10_000 10_000 -- Fill up epochs epochs <- Api.fillEpochs interpreter mockServer 3 -- Wait for it to sync @@ -105,9 +105,9 @@ rewardsShelley = -- Now that pools are registered, add a tx to fill the fees pot so rewards will be -- distributed - void $ - Api.withShelleyFindLeaderAndSubmitTx interpreter mockServer $ - Shelley.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10_000 10_000 + void + $ Api.withShelleyFindLeaderAndSubmitTx interpreter mockServer + $ Shelley.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10_000 10_000 -- Fill more epochs epochs' <- Api.fillEpochs interpreter mockServer 2 @@ -151,9 +151,9 @@ rollbackBoundary = -- It takes 2 epochs to create rewards epochs <- Api.fillEpochs interpreter mockServer 2 -- Forge a transaction to distribute rewards - void $ - Api.withConwayFindLeaderAndSubmitTx interpreter mockServer $ - Conway.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10_000 10_000 0 + void + $ Api.withConwayFindLeaderAndSubmitTx interpreter mockServer + $ Conway.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10_000 10_000 0 -- Create a point to rollback to blks <- Api.forgeAndSubmitBlocks interpreter mockServer 50 -- Fill up the rest of the epoch diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Rollback.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Rollback.hs index 3bb4482f7..c9d4b33d0 100644 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Rollback.hs +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Rollback.hs @@ -123,9 +123,9 @@ lazyRollback = rollbackTo interpreter mockServer (blockPoint lastBlk) -- Here we create the fork - void $ - withConwayFindLeaderAndSubmitTx interpreter mockServer $ - Conway.mkSimpleDCertTx [(StakeIndexNew 1, Conway.mkRegTxCert SNothing)] + void + $ withConwayFindLeaderAndSubmitTx interpreter mockServer + $ Conway.mkSimpleDCertTx [(StakeIndexNew 1, Conway.mkRegTxCert SNothing)] -- Add some more blocks void $ forgeAndSubmitBlocks interpreter mockServer 40 -- Verify the new block count @@ -151,9 +151,9 @@ lazyRollbackRestart = startDBSync dbSync -- Here we create the fork - void $ - withConwayFindLeaderAndSubmitTx interpreter mockServer $ - Conway.mkSimpleDCertTx [(StakeIndexNew 1, Conway.mkRegTxCert SNothing)] + void + $ withConwayFindLeaderAndSubmitTx interpreter mockServer + $ Conway.mkSimpleDCertTx [(StakeIndexNew 1, Conway.mkRegTxCert SNothing)] -- Add some more blocks void $ forgeAndSubmitBlocks interpreter mockServer 30 -- Verify the new block count @@ -177,18 +177,18 @@ doubleRollback = -- Rollback to second block point rollbackTo interpreter mockServer (blockPoint lastBlk2) -- Here we create a fork - void $ - withConwayFindLeaderAndSubmitTx interpreter mockServer $ - Conway.mkSimpleDCertTx [(StakeIndexNew 1, Conway.mkRegTxCert SNothing)] + void + $ withConwayFindLeaderAndSubmitTx interpreter mockServer + $ Conway.mkSimpleDCertTx [(StakeIndexNew 1, Conway.mkRegTxCert SNothing)] -- Add some more blocks void $ forgeAndSubmitBlocks interpreter mockServer 50 -- Rollback to first block point rollbackTo interpreter mockServer (blockPoint lastBlk1) -- Create another fork - void $ - withConwayFindLeaderAndSubmitTx interpreter mockServer $ - Conway.mkSimpleDCertTx [(StakeIndexNew 0, Conway.mkRegTxCert $ SJust (Coin 100))] + void + $ withConwayFindLeaderAndSubmitTx interpreter mockServer + $ Conway.mkSimpleDCertTx [(StakeIndexNew 0, Conway.mkRegTxCert $ SJust (Coin 100))] -- Add some more blocks void $ forgeAndSubmitBlocks interpreter mockServer 50 -- Wait for it to sync diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Simple.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Simple.hs index 3c4216265..993e6d824 100644 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Simple.hs +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Simple.hs @@ -27,8 +27,9 @@ forgeBlocks = do block <- forgeNext interpreter mockBlock2 let blkNo = blockNo block - assertBool (show blkNo <> " /= " <> "3") $ - blkNo == BlockNo 3 + assertBool (show blkNo <> " /= " <> "3") + $ blkNo + == BlockNo 3 where testLabel = "conwayForgeBlocks" diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Stake.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Stake.hs index 778d3eb5e..453cc73ea 100644 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Stake.hs +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Stake.hs @@ -43,22 +43,22 @@ registrationTx = startDBSync dbSync -- Forge some registration txs - void $ - Api.withConwayFindLeaderAndSubmitTx interpreter mockServer $ - Conway.mkSimpleDCertTx [(StakeIndexNew 1, Conway.mkRegTxCert SNothing)] - void $ - Api.withConwayFindLeaderAndSubmitTx interpreter mockServer $ - Conway.mkSimpleDCertTx [(StakeIndexNew 1, Conway.mkUnRegTxCert SNothing)] + void + $ Api.withConwayFindLeaderAndSubmitTx interpreter mockServer + $ Conway.mkSimpleDCertTx [(StakeIndexNew 1, Conway.mkRegTxCert SNothing)] + void + $ Api.withConwayFindLeaderAndSubmitTx interpreter mockServer + $ Conway.mkSimpleDCertTx [(StakeIndexNew 1, Conway.mkUnRegTxCert SNothing)] -- Add interval so txs don't have the same ID - void $ - Api.withConwayFindLeaderAndSubmitTx interpreter mockServer $ - fmap (Conway.addValidityInterval 1000) - . Conway.mkSimpleDCertTx [(StakeIndexNew 1, Conway.mkRegTxCert SNothing)] - void $ - Api.withConwayFindLeaderAndSubmitTx interpreter mockServer $ - fmap (Conway.addValidityInterval 2000) - . Conway.mkSimpleDCertTx [(StakeIndex 1, Conway.mkUnRegTxCert SNothing)] + void + $ Api.withConwayFindLeaderAndSubmitTx interpreter mockServer + $ fmap (Conway.addValidityInterval 1000) + . Conway.mkSimpleDCertTx [(StakeIndexNew 1, Conway.mkRegTxCert SNothing)] + void + $ Api.withConwayFindLeaderAndSubmitTx interpreter mockServer + $ fmap (Conway.addValidityInterval 2000) + . Conway.mkSimpleDCertTx [(StakeIndex 1, Conway.mkUnRegTxCert SNothing)] -- Wait for it to sync and verify counts assertBlockNoBackoff dbSync 4 @@ -100,15 +100,15 @@ registrationsSameTx = startDBSync dbSync -- Forge a transaction with some registrations - void $ - Api.withConwayFindLeaderAndSubmitTx interpreter mockServer $ - Conway.mkSimpleDCertTx - [ (StakeIndexNew 1, Conway.mkRegTxCert SNothing) - , (StakeIndexNew 1, Conway.mkUnRegTxCert SNothing) - , -- The certificates need to be unique, otherwise they'll be deduplicated - (StakeIndexNew 1, Conway.mkRegTxCert (SJust $ Coin 0)) - , (StakeIndexNew 1, Conway.mkUnRegTxCert (SJust $ Coin 0)) - ] + void + $ Api.withConwayFindLeaderAndSubmitTx interpreter mockServer + $ Conway.mkSimpleDCertTx + [ (StakeIndexNew 1, Conway.mkRegTxCert SNothing) + , (StakeIndexNew 1, Conway.mkUnRegTxCert SNothing) + , -- The certificates need to be unique, otherwise they'll be deduplicated + (StakeIndexNew 1, Conway.mkRegTxCert (SJust $ Coin 0)) + , (StakeIndexNew 1, Conway.mkUnRegTxCert (SJust $ Coin 0)) + ] -- Wait for it to sync and verify counts assertBlockNoBackoff dbSync 1 @@ -123,14 +123,14 @@ stakeAddressPtr = -- Forge a block with a cert blk <- - Api.withConwayFindLeaderAndSubmitTx interpreter mockServer $ - Conway.mkSimpleDCertTx [(StakeIndexNew 1, Conway.mkRegTxCert SNothing)] + Api.withConwayFindLeaderAndSubmitTx interpreter mockServer + $ Conway.mkSimpleDCertTx [(StakeIndexNew 1, Conway.mkRegTxCert SNothing)] -- Forge a block pointing to the cert let ptr = Ptr (blockSlot blk) (TxIx 0) (CertIx 0) - void $ - Api.withConwayFindLeaderAndSubmitTx interpreter mockServer $ - Conway.mkPaymentTx (UTxOIndex 0) (UTxOAddressNewWithPtr 0 ptr) 20_000 20_000 0 + void + $ Api.withConwayFindLeaderAndSubmitTx interpreter mockServer + $ Conway.mkPaymentTx (UTxOIndex 0) (UTxOAddressNewWithPtr 0 ptr) 20_000 20_000 0 -- Wait for it to sync and verify counts assertBlockNoBackoff dbSync 2 @@ -145,8 +145,8 @@ stakeAddressPtrDereg = -- Forge a block with a registration blk <- - Api.withConwayFindLeaderAndSubmitTx interpreter mockServer $ - Conway.mkSimpleDCertTx [(StakeIndexNew 0, Conway.mkRegTxCert SNothing)] + Api.withConwayFindLeaderAndSubmitTx interpreter mockServer + $ Conway.mkSimpleDCertTx [(StakeIndexNew 0, Conway.mkRegTxCert SNothing)] -- Forge a block with a pointer let ptr0 = Ptr (blockSlot blk) (TxIx 0) (CertIx 0) blk' <- Api.withConwayFindLeaderAndSubmit interpreter mockServer $ \state' -> @@ -202,23 +202,23 @@ stakeAddressPtrUseBefore = startDBSync dbSync -- Use a stake credential - void $ - Api.withConwayFindLeaderAndSubmitTx interpreter mockServer $ - Conway.mkPaymentTx - (UTxOIndex 1) - (UTxOAddressNewWithStake 0 $ StakeIndexNew 1) - 10_000 - 500 - 0 + void + $ Api.withConwayFindLeaderAndSubmitTx interpreter mockServer + $ Conway.mkPaymentTx + (UTxOIndex 1) + (UTxOAddressNewWithStake 0 $ StakeIndexNew 1) + 10_000 + 500 + 0 -- Register it blk <- - Api.withConwayFindLeaderAndSubmitTx interpreter mockServer $ - Conway.mkSimpleDCertTx [(StakeIndexNew 1, Conway.mkRegTxCert SNothing)] + Api.withConwayFindLeaderAndSubmitTx interpreter mockServer + $ Conway.mkSimpleDCertTx [(StakeIndexNew 1, Conway.mkRegTxCert SNothing)] -- Create a pointer to it let ptr = Ptr (blockSlot blk) (TxIx 0) (CertIx 0) - void $ - Api.withConwayFindLeaderAndSubmitTx interpreter mockServer $ - Conway.mkPaymentTx (UTxOIndex 0) (UTxOAddressNewWithPtr 0 ptr) 20_000 20_000 0 + void + $ Api.withConwayFindLeaderAndSubmitTx interpreter mockServer + $ Conway.mkPaymentTx (UTxOIndex 0) (UTxOAddressNewWithPtr 0 ptr) 20_000 20_000 0 -- Wait for it to sync and verify count assertBlockNoBackoff dbSync 3 @@ -384,8 +384,8 @@ delegationsManyNotDense = -- Blocks come on average every 5 slots. If we skip 15 slots before each block, -- we are expected to get only 1/4 of the expected blocks. The adjusted slices -- should still be long enough to cover everything. - replicateM_ 40 $ - Api.forgeNextSkipSlotsFindLeaderAndSubmit interpreter mockServer 15 [] + replicateM_ 40 + $ Api.forgeNextSkipSlotsFindLeaderAndSubmit interpreter mockServer 15 [] -- Even if the chain is sparse, all distributions are inserted. assertEpochStakeEpoch dbSync 7 40_005 diff --git a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Tx.hs b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Tx.hs index 4adeac2b3..bb160c872 100644 --- a/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Tx.hs +++ b/cardano-chain-gen/test/Test/Cardano/Db/Mock/Unit/Conway/Tx.hs @@ -35,9 +35,9 @@ addSimpleTx :: IOManager -> [(Text, Text)] -> Assertion addSimpleTx = withFullConfig conwayConfigDir testLabel $ \interpreter mockServer dbSync -> do -- Forge a block - void $ - UnifiedApi.withConwayFindLeaderAndSubmitTx interpreter mockServer $ - Conway.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10_000 500 0 + void + $ UnifiedApi.withConwayFindLeaderAndSubmitTx interpreter mockServer + $ Conway.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10_000 500 0 startDBSync dbSync -- Verify it syncs @@ -52,9 +52,9 @@ addSimpleTxShelley :: IOManager -> [(Text, Text)] -> Assertion addSimpleTxShelley = withFullConfig shelleyConfigDir testLabel $ \interpreter mockServer dbSync -> do -- Forge a shelley block - void $ - UnifiedApi.withShelleyFindLeaderAndSubmitTx interpreter mockServer $ - Shelley.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10_000 500 + void + $ UnifiedApi.withShelleyFindLeaderAndSubmitTx interpreter mockServer + $ Shelley.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10_000 500 startDBSync dbSync -- Verify it syncs @@ -67,9 +67,9 @@ addSimpleTxNoLedger :: IOManager -> [(Text, Text)] -> Assertion addSimpleTxNoLedger = do withCustomConfig args (Just configLedgerIgnore) conwayConfigDir testLabel $ \interpreter mockServer dbSync -> do -- Forge a block - void $ - UnifiedApi.withConwayFindLeaderAndSubmitTx interpreter mockServer $ - Conway.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10_000 500 0 + void + $ UnifiedApi.withConwayFindLeaderAndSubmitTx interpreter mockServer + $ Conway.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10_000 500 0 startDBSync dbSync -- Verify it syncs @@ -90,9 +90,9 @@ addTxTreasuryDonation = startDBSync dbSync -- Forge a block - void $ - UnifiedApi.withConwayFindLeaderAndSubmitTx interpreter mockServer $ - Conway.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10_000 500 1_000 + void + $ UnifiedApi.withConwayFindLeaderAndSubmitTx interpreter mockServer + $ Conway.mkPaymentTx (UTxOIndex 0) (UTxOIndex 1) 10_000 500 1_000 -- Wait for it to sync assertBlockNoBackoff dbSync 1 @@ -124,12 +124,13 @@ consumeSameBlock = addTxMetadata :: IOManager -> [(Text, Text)] -> Assertion addTxMetadata = do - withCustomConfigAndDropDB args (Just configMetadataEnable) cfgDir testLabel $ - \interpreter mockServer dbSync -> do + withCustomConfigAndDropDB args (Just configMetadataEnable) cfgDir testLabel + $ \interpreter mockServer dbSync -> do startDBSync dbSync -- Add blocks with transactions - void $ - UnifiedApi.withConwayFindLeaderAndSubmitTx interpreter mockServer $ \_ -> + void + $ UnifiedApi.withConwayFindLeaderAndSubmitTx interpreter mockServer + $ \_ -> let txBody = Conway.mkDummyTxBody auxData = Map.fromList [(1, I 1), (2, I 2)] in Right (Conway.mkAuxDataTx True txBody auxData) @@ -169,12 +170,13 @@ addTxMetadataWhitelist = do addTxMetadataDisabled :: IOManager -> [(Text, Text)] -> Assertion addTxMetadataDisabled = do - withCustomConfigAndDropDB args (Just configMetadataDisable) cfgDir testLabel $ - \interpreter mockServer dbSync -> do + withCustomConfigAndDropDB args (Just configMetadataDisable) cfgDir testLabel + $ \interpreter mockServer dbSync -> do startDBSync dbSync -- Add blocks with transactions - void $ - UnifiedApi.withConwayFindLeaderAndSubmitTx interpreter mockServer $ \_ -> + void + $ UnifiedApi.withConwayFindLeaderAndSubmitTx interpreter mockServer + $ \_ -> let txBody = Conway.mkDummyTxBody auxData = Map.fromList [(1, I 1), (2, I 2)] in Right (Conway.mkAuxDataTx True txBody auxData) diff --git a/cardano-db-sync/app/cardano-db-sync.hs b/cardano-db-sync/app/cardano-db-sync.hs index 7e6e0162a..cf5259da2 100644 --- a/cardano-db-sync/app/cardano-db-sync.hs +++ b/cardano-db-sync/app/cardano-db-sync.hs @@ -409,9 +409,9 @@ pBootstrap = command' :: String -> String -> Parser a -> Opt.Mod Opt.CommandFields a command' c descr p = - Opt.command c $ - Opt.info (p <**> Opt.helper) $ - mconcat [Opt.progDesc descr] + Opt.command c + $ Opt.info (p <**> Opt.helper) + $ mconcat [Opt.progDesc descr] runVersionCommand :: IO () runVersionCommand = do diff --git a/cardano-db-sync/app/test-http-get-json-metadata.hs b/cardano-db-sync/app/test-http-get-json-metadata.hs index 5fb02f07a..47ec0ea13 100644 --- a/cardano-db-sync/app/test-http-get-json-metadata.hs +++ b/cardano-db-sync/app/test-http-get-json-metadata.hs @@ -142,10 +142,10 @@ queryTestOffChainData :: MonadIO m => ReaderT SqlBackend m [TestOffChain] queryTestOffChainData = do res <- select $ do (pod :& pmr) <- - from - $ table @OffChainPoolData + from $ + table @OffChainPoolData `innerJoin` table @PoolMetadataRef - `on` (\(pod :& pmr) -> pod ^. OffChainPoolDataPmrId ==. pmr ^. PoolMetadataRefId) + `on` (\(pod :& pmr) -> pod ^. OffChainPoolDataPmrId ==. pmr ^. PoolMetadataRefId) where_ $ notExists (from (table @PoolRetire) >>= \pr -> where_ (pod ^. OffChainPoolDataPoolId ==. pr ^. PoolRetireHashId)) pure ( pod ^. OffChainPoolDataTickerName diff --git a/cardano-db-sync/src/Cardano/DbSync.hs b/cardano-db-sync/src/Cardano/DbSync.hs index 9df654d4c..8ea5a27d0 100644 --- a/cardano-db-sync/src/Cardano/DbSync.hs +++ b/cardano-db-sync/src/Cardano/DbSync.hs @@ -102,10 +102,10 @@ runDbSync metricsSetters knownMigrations iomgr trce params syncNodeConfigFromFil when (mode `elem` [Db.Indexes, Db.Full]) $ logWarning trce indexesMsg Db.runMigrations pgConfig True dbMigrationDir (Just $ Db.LogFileDir "/tmp") mode (txOutConfigToTableType txOutConfig) (ranMigrations, unofficial) <- if enpForceIndexes params then runMigration Db.Full else runMigration Db.Initial - unless (null unofficial) $ - logWarning trce $ - "Unofficial migration scripts found: " - <> textShow unofficial + unless (null unofficial) + $ logWarning trce + $ "Unofficial migration scripts found: " + <> textShow unofficial if ranMigrations then logInfo trce "All migrations were executed" @@ -162,8 +162,8 @@ runSyncNode :: SyncOptions -> IO () runSyncNode metricsSetters trce iomgr dbConnString ranMigrations runMigrationFnc syncNodeConfigFromFile syncNodeParams syncOptions = do - whenJust maybeLedgerDir $ - \enpLedgerStateDir -> do + whenJust maybeLedgerDir + $ \enpLedgerStateDir -> do createDirectoryIfMissing True (unLedgerStateDir enpLedgerStateDir) logInfo trce $ "Using byron genesis file from: " <> (show . unGenesisFile $ dncByronGenesisFile syncNodeConfigFromFile) logInfo trce $ "Using shelley genesis file from: " <> (show . unGenesisFile $ dncShelleyGenesisFile syncNodeConfigFromFile) @@ -171,52 +171,52 @@ runSyncNode metricsSetters trce iomgr dbConnString ranMigrations runMigrationFnc let useLedger = shouldUseLedger (sioLedger $ dncInsertOptions syncNodeConfigFromFile) - Db.runIohkLogging trce $ - withPostgresqlConn dbConnString $ - \backend -> liftIO $ do - runOrThrowIO $ runExceptT $ do - genCfg <- readCardanoGenesisConfig syncNodeConfigFromFile - isJsonbInSchema <- queryIsJsonbInSchema backend - logProtocolMagicId trce $ genesisProtocolMagicId genCfg - syncEnv <- - ExceptT $ - mkSyncEnvFromConfig - trce - backend - dbConnString - syncOptions - genCfg - syncNodeConfigFromFile - syncNodeParams - ranMigrations - runMigrationFnc + Db.runIohkLogging trce + $ withPostgresqlConn dbConnString + $ \backend -> liftIO $ do + runOrThrowIO $ runExceptT $ do + genCfg <- readCardanoGenesisConfig syncNodeConfigFromFile + isJsonbInSchema <- queryIsJsonbInSchema backend + logProtocolMagicId trce $ genesisProtocolMagicId genCfg + syncEnv <- + ExceptT + $ mkSyncEnvFromConfig + trce + backend + dbConnString + syncOptions + genCfg + syncNodeConfigFromFile + syncNodeParams + ranMigrations + runMigrationFnc - -- Warn the user that jsonb datatypes are being removed from the database schema. - when (isJsonbInSchema && removeJsonbFromSchemaConfig) $ do - liftIO $ logWarning trce "Removing jsonb datatypes from the database. This can take time." - liftIO $ runRemoveJsonbFromSchema syncEnv + -- Warn the user that jsonb datatypes are being removed from the database schema. + when (isJsonbInSchema && removeJsonbFromSchemaConfig) $ do + liftIO $ logWarning trce "Removing jsonb datatypes from the database. This can take time." + liftIO $ runRemoveJsonbFromSchema syncEnv - -- Warn the user that jsonb datatypes are being added to the database schema. - when (not isJsonbInSchema && not removeJsonbFromSchemaConfig) $ do - liftIO $ logWarning trce "Adding jsonb datatypes back to the database. This can take time." - liftIO $ runAddJsonbToSchema syncEnv - liftIO $ runExtraMigrationsMaybe syncEnv - unless useLedger $ liftIO $ do - logInfo trce "Migrating to a no ledger schema" - Db.noLedgerMigrations backend trce - insertValidateGenesisDist syncEnv (dncNetworkName syncNodeConfigFromFile) genCfg (useShelleyInit syncNodeConfigFromFile) + -- Warn the user that jsonb datatypes are being added to the database schema. + when (not isJsonbInSchema && not removeJsonbFromSchemaConfig) $ do + liftIO $ logWarning trce "Adding jsonb datatypes back to the database. This can take time." + liftIO $ runAddJsonbToSchema syncEnv + liftIO $ runExtraMigrationsMaybe syncEnv + unless useLedger $ liftIO $ do + logInfo trce "Migrating to a no ledger schema" + Db.noLedgerMigrations backend trce + insertValidateGenesisDist syncEnv (dncNetworkName syncNodeConfigFromFile) genCfg (useShelleyInit syncNodeConfigFromFile) - -- communication channel between datalayer thread and chainsync-client thread - threadChannels <- liftIO newThreadChannels - liftIO $ - mapConcurrently_ - id - [ runDbThread syncEnv metricsSetters threadChannels - , runSyncNodeClient metricsSetters syncEnv iomgr trce threadChannels (enpSocketPath syncNodeParams) - , runFetchOffChainPoolThread syncEnv - , runFetchOffChainVoteThread syncEnv - , runLedgerStateWriteThread (getTrace syncEnv) (envLedgerEnv syncEnv) - ] + -- communication channel between datalayer thread and chainsync-client thread + threadChannels <- liftIO newThreadChannels + liftIO + $ mapConcurrently_ + id + [ runDbThread syncEnv metricsSetters threadChannels + , runSyncNodeClient metricsSetters syncEnv iomgr trce threadChannels (enpSocketPath syncNodeParams) + , runFetchOffChainPoolThread syncEnv + , runFetchOffChainVoteThread syncEnv + , runLedgerStateWriteThread (getTrace syncEnv) (envLedgerEnv syncEnv) + ] where useShelleyInit :: SyncNodeConfig -> Bool useShelleyInit cfg = diff --git a/cardano-db-sync/src/Cardano/DbSync/Api.hs b/cardano-db-sync/src/Cardano/DbSync/Api.hs index 02f0b9745..0b5da4443 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Api.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Api.hs @@ -180,8 +180,8 @@ runExtraMigrationsMaybe syncEnv = do let pcm = getPruneConsume syncEnv txOutTableType = getTxOutTableType syncEnv logInfo (getTrace syncEnv) $ "runExtraMigrationsMaybe: " <> textShow pcm - DB.runDbIohkNoLogging (envBackend syncEnv) $ - DB.runExtraMigrations + DB.runDbIohkNoLogging (envBackend syncEnv) + $ DB.runExtraMigrations (getTrace syncEnv) txOutTableType (getSafeBlockNoDiff syncEnv) @@ -201,11 +201,11 @@ getSafeBlockNoDiff syncEnv = 2 * getSecurityParam syncEnv getPruneInterval :: SyncEnv -> Word64 getPruneInterval syncEnv = 10 * getSecurityParam syncEnv -whenConsumeOrPruneTxOut :: (MonadIO m) => SyncEnv -> m () -> m () +whenConsumeOrPruneTxOut :: MonadIO m => SyncEnv -> m () -> m () whenConsumeOrPruneTxOut env = when (DB.pcmConsumedTxOut $ getPruneConsume env) -whenPruneTxOut :: (MonadIO m) => SyncEnv -> m () -> m () +whenPruneTxOut :: MonadIO m => SyncEnv -> m () -> m () whenPruneTxOut env = when (DB.pcmPruneTxOut $ getPruneConsume env) @@ -293,8 +293,8 @@ getDbLatestBlockInfo backend = do block <- MaybeT $ DB.runDbIohkNoLogging backend DB.queryLatestBlock -- The EpochNo, SlotNo and BlockNo can only be zero for the Byron -- era, but we need to make the types match, hence `fromMaybe`. - pure $ - TipInfo + pure + $ TipInfo { bHash = DB.blockHash block , bEpochNo = EpochNo . fromMaybe 0 $ DB.blockEpochNo block , bSlotNo = SlotNo . fromMaybe 0 $ DB.blockSlotNo block @@ -384,15 +384,15 @@ mkSyncEnv trce backend connectionString syncOptions protoInfo nw nwMagic systemS syncOptions (Nothing, False) -> NoLedger <$> mkNoLedgerEnv trce protoInfo nw systemStart (Just _, False) -> do - logWarning trce $ - "Disabling the ledger doesn't require having a --state-dir." - <> " For more details view https://github.com/IntersectMBO/cardano-db-sync/blob/master/doc/configuration.md#ledger" + logWarning trce + $ "Disabling the ledger doesn't require having a --state-dir." + <> " For more details view https://github.com/IntersectMBO/cardano-db-sync/blob/master/doc/configuration.md#ledger" NoLedger <$> mkNoLedgerEnv trce protoInfo nw systemStart -- This won't ever call because we error out this combination at parse time (Nothing, True) -> NoLedger <$> mkNoLedgerEnv trce protoInfo nw systemStart - pure $ - SyncEnv + pure + $ SyncEnv { envBackend = backend , envBootstrap = bootstrapVar , envCache = cache @@ -523,7 +523,7 @@ getSecurityParam syncEnv = NoLedger nle -> getMaxRollbacks $ nleProtocolInfo nle getMaxRollbacks :: - (ConsensusProtocol (BlockProtocol blk)) => + ConsensusProtocol (BlockProtocol blk) => ProtocolInfo blk -> Word64 getMaxRollbacks = maxRollbacks . configSecurityParam . pInfoConfig @@ -546,27 +546,27 @@ getBootstrapInProgress trce bootstrapFlag sqlBackend = do (False, DB.BootstrapInProgress) -> do liftIO $ DB.logAndThrowIO trce "Bootstrap flag not set, but still in progress" (True, DB.BootstrapNotStarted) -> do - liftIO $ - logInfo trce $ - mconcat - [ "Syncing with bootstrap. " - , "This won't populate tx_out until the tip of the chain." - ] + liftIO + $ logInfo trce + $ mconcat + [ "Syncing with bootstrap. " + , "This won't populate tx_out until the tip of the chain." + ] DB.insertExtraMigration DB.BootstrapStarted pure True (True, DB.BootstrapInProgress) -> do - liftIO $ - logInfo trce $ - mconcat - [ "Syncing with bootstrap is in progress. " - , "This won't populate tx_out until the tip of the chain." - ] + liftIO + $ logInfo trce + $ mconcat + [ "Syncing with bootstrap is in progress. " + , "This won't populate tx_out until the tip of the chain." + ] pure True (True, DB.BootstrapDone) -> do - liftIO $ - logWarning trce $ - mconcat - [ "Bootstrap flag is set, but it will be ignored, " - , "since bootstrap is already done." - ] + liftIO + $ logWarning trce + $ mconcat + [ "Bootstrap flag is set, but it will be ignored, " + , "since bootstrap is already done." + ] pure False diff --git a/cardano-db-sync/src/Cardano/DbSync/Cache.hs b/cardano-db-sync/src/Cardano/DbSync/Cache.hs index ae0bcc04d..7454d9216 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Cache.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Cache.hs @@ -89,8 +89,9 @@ optimiseCaches cache = case cache of NoCache -> pure () ActiveCache c -> - withCacheOptimisationCheck c (pure ()) $ - liftIO $ do + withCacheOptimisationCheck c (pure ()) + $ liftIO + $ do -- empty caches not to be used anymore atomically $ modifyTVar (cTxIds c) FIFO.cleanupCache atomically $ writeTVar (cStake c) (StakeCache Map.empty (LRU.empty 0)) @@ -139,8 +140,8 @@ insertStakeAddress :: Maybe ByteString -> ReaderT SqlBackend m DB.StakeAddressId insertStakeAddress rewardAddr stakeCredBs = do - DB.insertStakeAddress $ - DB.StakeAddress + DB.insertStakeAddress + $ DB.StakeAddress { DB.stakeAddressHashRaw = addrBs , DB.stakeAddressView = Generic.renderRewardAccount rewardAddr , DB.stakeAddressScriptHash = Generic.getCredentialScriptHash $ Ledger.raCredential rewardAddr @@ -195,9 +196,9 @@ queryStakeAddrWithCacheRetBs _trce cache cacheUA ra@(Ledger.RewardAccount _ cred UpdateCache -> stakeCache {scLruCache = LRU.insert cred stakeAddrsId (scLruCache stakeCache)} UpdateCacheStrong -> stakeCache {scStableCache = Map.insert cred stakeAddrsId (scStableCache stakeCache)} _otherwise -> stakeCache - liftIO $ - atomically $ - writeTVar (cStake ci) stakeCache' + liftIO + $ atomically + $ writeTVar (cStake ci) stakeCache' pure $ Right stakeAddrsId where rsStkAdrrs bs = mapLeft (,bs) <$> resolveStakeAddress bs @@ -233,11 +234,11 @@ queryPoolKeyWithCache cache cacheUA hsh = Just phId -> do liftIO $ hitPools (cStats ci) -- hit so we can't cache even with 'CacheNew' - when (cacheUA == EvictAndUpdateCache) $ - liftIO $ - atomically $ - modifyTVar (cPools ci) $ - Map.delete hsh + when (cacheUA == EvictAndUpdateCache) + $ liftIO + $ atomically + $ modifyTVar (cPools ci) + $ Map.delete hsh pure $ Right phId Nothing -> do liftIO $ missPools (cStats ci) @@ -246,11 +247,11 @@ queryPoolKeyWithCache cache cacheUA hsh = Nothing -> pure $ Left (DB.DbLookupMessage "PoolKeyHash") Just phId -> do -- missed so we can't evict even with 'EvictAndReturn' - when (shouldCache cacheUA) $ - liftIO $ - atomically $ - modifyTVar (cPools ci) $ - Map.insert hsh phId + when (shouldCache cacheUA) + $ liftIO + $ atomically + $ modifyTVar (cPools ci) + $ Map.insert hsh phId pure $ Right phId insertPoolKeyWithCache :: @@ -262,8 +263,8 @@ insertPoolKeyWithCache :: insertPoolKeyWithCache cache cacheUA pHash = case cache of NoCache -> - DB.insertPoolHash $ - DB.PoolHash + DB.insertPoolHash + $ DB.PoolHash { DB.poolHashHashRaw = Generic.unKeyHashRaw pHash , DB.poolHashView = Generic.unKeyHashView pHash } @@ -272,25 +273,25 @@ insertPoolKeyWithCache cache cacheUA pHash = case Map.lookup pHash mp of Just phId -> do liftIO $ hitPools (cStats ci) - when (cacheUA == EvictAndUpdateCache) $ - liftIO $ - atomically $ - modifyTVar (cPools ci) $ - Map.delete pHash + when (cacheUA == EvictAndUpdateCache) + $ liftIO + $ atomically + $ modifyTVar (cPools ci) + $ Map.delete pHash pure phId Nothing -> do liftIO $ missPools (cStats ci) phId <- - DB.insertPoolHash $ - DB.PoolHash + DB.insertPoolHash + $ DB.PoolHash { DB.poolHashHashRaw = Generic.unKeyHashRaw pHash , DB.poolHashView = Generic.unKeyHashView pHash } - when (shouldCache cacheUA) $ - liftIO $ - atomically $ - modifyTVar (cPools ci) $ - Map.insert pHash phId + when (shouldCache cacheUA) + $ liftIO + $ atomically + $ modifyTVar (cPools ci) + $ Map.insert pHash phId pure phId queryPoolKeyOrInsert :: @@ -307,18 +308,18 @@ queryPoolKeyOrInsert txt trce cache cacheUA logsWarning hsh = do case pk of Right poolHashId -> pure poolHashId Left err -> do - when logsWarning $ - liftIO $ - logWarning trce $ - mconcat - [ "Failed with " - , textShow err - , " while trying to find pool " - , textShow hsh - , " for " - , txt - , ". We will assume that the pool exists and move on." - ] + when logsWarning + $ liftIO + $ logWarning trce + $ mconcat + [ "Failed with " + , textShow err + , " while trying to find pool " + , textShow hsh + , " for " + , txt + , ". We will assume that the pool exists and move on." + ] insertPoolKeyWithCache cache cacheUA hsh queryMAWithCache :: @@ -344,8 +345,11 @@ queryMAWithCache cache policyId asset = let !policyBs = Generic.unScriptHash $ policyID policyId let !assetNameBs = Generic.unAssetName asset maId <- maybe (Left (policyBs, assetNameBs)) Right <$> DB.queryMultiAssetId policyBs assetNameBs - whenRight maId $ - liftIO . atomically . modifyTVar (cMultiAssets ci) . LRU.insert (policyId, asset) + whenRight maId + $ liftIO + . atomically + . modifyTVar (cMultiAssets ci) + . LRU.insert (policyId, asset) pure maId where queryDb = do @@ -481,10 +485,10 @@ insertDatumAndCache cache hsh dt = do NoCache -> pure datumId ActiveCache ci -> withCacheOptimisationCheck ci (pure datumId) $ do - liftIO $ - atomically $ - modifyTVar (cDatum ci) $ - LRU.insert hsh datumId + liftIO + $ atomically + $ modifyTVar (cDatum ci) + $ LRU.insert hsh datumId pure datumId withCacheOptimisationCheck :: diff --git a/cardano-db-sync/src/Cardano/DbSync/Cache/LRU.hs b/cardano-db-sync/src/Cardano/DbSync/Cache/LRU.hs index 5bbf00ef1..d748bc873 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Cache/LRU.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Cache/LRU.hs @@ -68,8 +68,8 @@ trim cache -- It trims the cache if necessary to maintain the capacity. insert :: Ord k => k -> v -> LRUCache k v -> LRUCache k v insert k v cache = - trim $! - cache + trim + $! cache { cTick = cTick cache + 1 -- Increment the tick counter , cQueue = queue } diff --git a/cardano-db-sync/src/Cardano/DbSync/Cache/Types.hs b/cardano-db-sync/src/Cardano/DbSync/Cache/Types.hs index 187898a6b..3e9ff1814 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Cache/Types.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Cache/Types.hs @@ -137,8 +137,8 @@ textShowStats (ActiveCache ic) = do datums <- readTVarIO (cDatum ic) mAssets <- readTVarIO (cMultiAssets ic) txIds <- readTVarIO (cTxIds ic) - pure $ - mconcat + pure + $ mconcat [ "\nCache Statistics:" , "\n Caches Optimised: " <> textShow isCacheOptimised , "\n Stake Addresses: " @@ -224,8 +224,9 @@ newEmptyCache CacheCapacity {..} = liftIO $ do cEpoch <- newTVarIO initCacheEpoch cTxIds <- newTVarIO (FIFO.empty cacheCapacityTx) - pure . ActiveCache $ - CacheInternal + pure + . ActiveCache + $ CacheInternal { cIsCacheOptimised = cIsCacheOptimised , cStake = cStake , cPools = cPools diff --git a/cardano-db-sync/src/Cardano/DbSync/Config.hs b/cardano-db-sync/src/Cardano/DbSync/Config.hs index f38e65307..d5d245923 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Config.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Config.hs @@ -59,8 +59,8 @@ coalesceConfig :: IO SyncNodeConfig coalesceConfig pcfg ncfg adjustGenesisPath = do lc <- Logging.setupFromRepresentation $ pcLoggingConfig pcfg - pure $ - SyncNodeConfig + pure + $ SyncNodeConfig { dncNetworkName = pcNetworkName pcfg , dncLoggingConfig = lc , dncNodeConfigFile = pcNodeConfigFile pcfg diff --git a/cardano-db-sync/src/Cardano/DbSync/Config/Conway.hs b/cardano-db-sync/src/Cardano/DbSync/Config/Conway.hs index f06e21c14..957afddbc 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Config/Conway.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Config/Conway.hs @@ -44,8 +44,8 @@ readConwayGenesisConfig SyncNodeConfig {..} = Nothing -> pure (ConwayGenesis defaultUpgradeConwayPParams def def mempty mempty) where readConwayGenesisConfig' file hash = - firstExceptT (SNErrConwayConfig (unGenesisFile file) . renderConwayGenesisError) $ - readGenesis file hash + firstExceptT (SNErrConwayConfig (unGenesisFile file) . renderConwayGenesisError) + $ readGenesis file hash defaultUpgradeConwayPParams :: UpgradeConwayPParams Identity defaultUpgradeConwayPParams = UpgradeConwayPParams diff --git a/cardano-db-sync/src/Cardano/DbSync/Config/Types.hs b/cardano-db-sync/src/Cardano/DbSync/Config/Types.hs index 813ce2956..4093e5c27 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Config/Types.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Config/Types.hs @@ -399,11 +399,17 @@ parseGenSyncNodeConfig o = <*> parseJSON (Object o) <*> fmap NodeConfigFile (o .: "NodeConfigFile") <*> fmap (fromMaybe True) (o .:? "EnableFutureGenesis") - <*> o .: "EnableLogging" - <*> o .: "EnableLogMetrics" + <*> o + .: "EnableLogging" + <*> o + .: "EnableLogMetrics" <*> fmap (fromMaybe 8080) (o .:? "PrometheusPort") - <*> o .:? "insert_options" .!= def - <*> o .:? "ipfs_gateway" .!= ["https://ipfs.io/ipfs"] + <*> o + .:? "insert_options" + .!= def + <*> o + .:? "ipfs_gateway" + .!= ["https://ipfs.io/ipfs"] instance FromJSON SyncProtocol where parseJSON o = @@ -440,19 +446,43 @@ instance FromJSON SyncInsertConfig where parseOverrides :: Aeson.Object -> SyncInsertOptions -> Parser SyncInsertOptions parseOverrides obj baseOptions = do SyncInsertOptions - <$> obj .:? "tx_cbor" .!= sioTxCBOR baseOptions - <*> obj .:? "tx_out" .!= sioTxOut baseOptions - <*> obj .:? "ledger" .!= sioLedger baseOptions - <*> obj .:? "shelley" .!= sioShelley baseOptions + <$> obj + .:? "tx_cbor" + .!= sioTxCBOR baseOptions + <*> obj + .:? "tx_out" + .!= sioTxOut baseOptions + <*> obj + .:? "ledger" + .!= sioLedger baseOptions + <*> obj + .:? "shelley" + .!= sioShelley baseOptions <*> pure (sioRewards baseOptions) - <*> obj .:? "multi_asset" .!= sioMultiAsset baseOptions - <*> obj .:? "metadata" .!= sioMetadata baseOptions - <*> obj .:? "plutus" .!= sioPlutus baseOptions - <*> obj .:? "governance" .!= sioGovernance baseOptions - <*> obj .:? "offchain_pool_data" .!= sioOffchainPoolData baseOptions - <*> obj .:? "pool_stat" .!= sioPoolStats baseOptions - <*> obj .:? "json_type" .!= sioJsonType baseOptions - <*> obj .:? "remove_jsonb_from_schema" .!= sioRemoveJsonbFromSchema baseOptions + <*> obj + .:? "multi_asset" + .!= sioMultiAsset baseOptions + <*> obj + .:? "metadata" + .!= sioMetadata baseOptions + <*> obj + .:? "plutus" + .!= sioPlutus baseOptions + <*> obj + .:? "governance" + .!= sioGovernance baseOptions + <*> obj + .:? "offchain_pool_data" + .!= sioOffchainPoolData baseOptions + <*> obj + .:? "pool_stat" + .!= sioPoolStats baseOptions + <*> obj + .:? "json_type" + .!= sioJsonType baseOptions + <*> obj + .:? "remove_jsonb_from_schema" + .!= sioRemoveJsonbFromSchema baseOptions instance ToJSON SyncInsertConfig where toJSON (SyncInsertConfig preset options) = @@ -482,19 +512,43 @@ toJsonIfSet key value = Just $ fromText key .= value instance FromJSON SyncInsertOptions where parseJSON = Aeson.withObject "SyncInsertOptions" $ \obj -> SyncInsertOptions - <$> obj .:? "tx_cbor" .!= sioTxCBOR def - <*> obj .:? "tx_out" .!= sioTxOut def - <*> obj .:? "ledger" .!= sioLedger def - <*> obj .:? "shelley" .!= sioShelley def + <$> obj + .:? "tx_cbor" + .!= sioTxCBOR def + <*> obj + .:? "tx_out" + .!= sioTxOut def + <*> obj + .:? "ledger" + .!= sioLedger def + <*> obj + .:? "shelley" + .!= sioShelley def <*> pure (sioRewards def) - <*> obj .:? "multi_asset" .!= sioMultiAsset def - <*> obj .:? "metadata" .!= sioMetadata def - <*> obj .:? "plutus" .!= sioPlutus def - <*> obj .:? "governance" .!= sioGovernance def - <*> obj .:? "offchain_pool_data" .!= sioOffchainPoolData def - <*> obj .:? "pool_stat" .!= sioPoolStats def - <*> obj .:? "json_type" .!= sioJsonType def - <*> obj .:? "remove_jsonb_from_schema" .!= sioRemoveJsonbFromSchema def + <*> obj + .:? "multi_asset" + .!= sioMultiAsset def + <*> obj + .:? "metadata" + .!= sioMetadata def + <*> obj + .:? "plutus" + .!= sioPlutus def + <*> obj + .:? "governance" + .!= sioGovernance def + <*> obj + .:? "offchain_pool_data" + .!= sioOffchainPoolData def + <*> obj + .:? "pool_stat" + .!= sioPoolStats def + <*> obj + .:? "json_type" + .!= sioJsonType def + <*> obj + .:? "remove_jsonb_from_schema" + .!= sioRemoveJsonbFromSchema def instance ToJSON SyncInsertOptions where toJSON SyncInsertOptions {..} = @@ -604,8 +658,8 @@ instance FromJSON ShelleyInsertConfig where enable <- obj .: "enable" stakeAddrs <- obj .:? "stake_addresses" - pure $ - case (enable, stakeAddrs) of + pure + $ case (enable, stakeAddrs) of (False, _) -> ShelleyDisable (True, Nothing) -> ShelleyEnable (True, Just addrs) -> ShelleyStakeAddrs (map parseShortByteString addrs) @@ -625,8 +679,8 @@ instance FromJSON MultiAssetConfig where enable <- obj .: "enable" policies <- obj .:? "policies" - pure $ - case (enable, policies) of + pure + $ case (enable, policies) of (False, _) -> MultiAssetDisable (True, Nothing) -> MultiAssetEnable (True, Just ps) -> MultiAssetPolicies (map parseShortByteString ps) @@ -646,8 +700,8 @@ instance FromJSON MetadataConfig where enable <- obj .: "enable" keys <- obj .:? "keys" - pure $ - case (enable, keys) of + pure + $ case (enable, keys) of (False, _) -> MetadataDisable (True, Nothing) -> MetadataEnable (True, Just ks) -> MetadataKeys ks @@ -667,8 +721,8 @@ instance FromJSON PlutusConfig where enable <- obj .: "enable" scriptHashes <- obj .:? "script_hashes" - pure $ - case (enable, scriptHashes) of + pure + $ case (enable, scriptHashes) of (False, _) -> PlutusDisable (True, Nothing) -> PlutusEnable (True, Just hs) -> PlutusScripts (map parseShortByteString hs) diff --git a/cardano-db-sync/src/Cardano/DbSync/Database.hs b/cardano-db-sync/src/Cardano/DbSync/Database.hs index 4583b8204..99fe83765 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Database.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Database.hs @@ -129,16 +129,16 @@ rollbackLedger syncEnv point = Right st -> do let statePoint = headerStatePoint $ headerState $ clsState st -- This is an extra validation that should always succeed. - unless (point == statePoint) $ - logAndThrowIO (getTrace syncEnv) $ - SNErrDatabaseRollBackLedger $ - mconcat - [ "Ledger " - , show statePoint - , " and ChainSync " - , show point - , " don't match." - ] + unless (point == statePoint) + $ logAndThrowIO (getTrace syncEnv) + $ SNErrDatabaseRollBackLedger + $ mconcat + [ "Ledger " + , show statePoint + , " and ChainSync " + , show point + , " don't match." + ] pure Nothing Left lsfs -> Just . fmap fst <$> verifySnapshotPoint syncEnv (OnDisk <$> lsfs) @@ -153,21 +153,25 @@ validateConsistentLevel syncEnv stPoint = do compareTips stPoint dbTipInfo cLevel where compareTips _ dbTip Unchecked = - logAndThrowIO tracer $ - SNErrDatabaseValConstLevel $ - "Found Unchecked Consistent Level. " <> showContext dbTip Unchecked + logAndThrowIO tracer + $ SNErrDatabaseValConstLevel + $ "Found Unchecked Consistent Level. " + <> showContext dbTip Unchecked compareTips (Point Origin) Nothing Consistent = pure () compareTips (Point Origin) _ DBAheadOfLedger = pure () compareTips (Point (At blk)) (Just tip) Consistent - | getHeaderHash (blockPointHash blk) == bHash tip - && blockPointSlot blk == bSlotNo tip = + | getHeaderHash (blockPointHash blk) + == bHash tip + && blockPointSlot blk + == bSlotNo tip = pure () compareTips (Point (At blk)) (Just tip) DBAheadOfLedger | blockPointSlot blk <= bSlotNo tip = pure () compareTips _ dbTip cLevel = - logAndThrowIO tracer $ - SNErrDatabaseValConstLevel $ - "Unexpected Consistent Level. " <> showContext dbTip cLevel + logAndThrowIO tracer + $ SNErrDatabaseValConstLevel + $ "Unexpected Consistent Level. " + <> showContext dbTip cLevel tracer = getTrace syncEnv showContext dbTip cLevel = diff --git a/cardano-db-sync/src/Cardano/DbSync/Default.hs b/cardano-db-sync/src/Cardano/DbSync/Default.hs index 010ee9fcc..98d3311cf 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Default.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Default.hs @@ -148,38 +148,38 @@ insertBlock syncEnv cblk applyRes firstAfterRollback tookSnapshot = do -- use when updating the Epoch, thus saving us having to recalulating them later. case cblk of BlockByron blk -> - newExceptT $ - insertByronBlock syncEnv isStartEventOrRollback blk details + newExceptT + $ insertByronBlock syncEnv isStartEventOrRollback blk details BlockShelley blk -> - newExceptT $ - insertBlockUniversal' $ - Generic.fromShelleyBlock blk + newExceptT + $ insertBlockUniversal' + $ Generic.fromShelleyBlock blk BlockAllegra blk -> - newExceptT $ - insertBlockUniversal' $ - Generic.fromAllegraBlock blk + newExceptT + $ insertBlockUniversal' + $ Generic.fromAllegraBlock blk BlockMary blk -> - newExceptT $ - insertBlockUniversal' $ - Generic.fromMaryBlock blk + newExceptT + $ insertBlockUniversal' + $ Generic.fromMaryBlock blk BlockAlonzo blk -> - newExceptT $ - insertBlockUniversal' $ - Generic.fromAlonzoBlock (ioPlutusExtra iopts) (getPrices applyResult) blk + newExceptT + $ insertBlockUniversal' + $ Generic.fromAlonzoBlock (ioPlutusExtra iopts) (getPrices applyResult) blk BlockBabbage blk -> - newExceptT $ - insertBlockUniversal' $ - Generic.fromBabbageBlock (ioPlutusExtra iopts) (getPrices applyResult) blk + newExceptT + $ insertBlockUniversal' + $ Generic.fromBabbageBlock (ioPlutusExtra iopts) (getPrices applyResult) blk BlockConway blk -> - newExceptT $ - insertBlockUniversal' $ - Generic.fromConwayBlock (ioPlutusExtra iopts) (getPrices applyResult) blk + newExceptT + $ insertBlockUniversal' + $ Generic.fromConwayBlock (ioPlutusExtra iopts) (getPrices applyResult) blk -- update the epoch updateEpoch details isNewEpochEvent - whenPruneTxOut syncEnv $ - when (unBlockNo blkNo `mod` getPruneInterval syncEnv == 0) $ - do - lift $ DB.deleteConsumedTxOut tracer txOutTableType (getSafeBlockNoDiff syncEnv) + whenPruneTxOut syncEnv + $ when (unBlockNo blkNo `mod` getPruneInterval syncEnv == 0) + $ do + lift $ DB.deleteConsumedTxOut tracer txOutTableType (getSafeBlockNoDiff syncEnv) commitOrIndexes withinTwoMin withinHalfHour where tracer = getTrace syncEnv diff --git a/cardano-db-sync/src/Cardano/DbSync/Epoch.hs b/cardano-db-sync/src/Cardano/DbSync/Epoch.hs index 113c032e4..e4a254fb7 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Epoch.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Epoch.hs @@ -64,7 +64,7 @@ epochHandler syncEnv trce cache isNewEpochEvent (BlockDetails cblk details) = epochSlotTimecheck = do when (sdSlotTime details > sdCurrentTime details) $ liftIO - . logError trce + . logError trce $ mconcat ["Slot time '", textShow (sdSlotTime details), "' is in the future"] updateEpochStart syncEnv cache details isNewEpochEvent False @@ -82,20 +82,20 @@ updateEpochStart syncEnv cache slotDetails isNewEpochEvent isBoundaryBlock = do let curEpochNo = unEpochNo $ sdEpochNo slotDetails if - -- The tip has been reached so now replace/update the epoch every block. - | getSyncStatus slotDetails == SyncFollowing -> - handleEpochWhenFollowing syncEnv cache mLastMapEpochFromCache mEpochBlockDiff curEpochNo - -- When syncing we check if current block is the first block in an epoch. - -- If so then it's time to put the previous epoch into the DB. - | isNewEpochEvent -> - updateEpochWhenSyncing syncEnv cache mEpochBlockDiff mLastMapEpochFromCache curEpochNo isBoundaryBlock - -- we're syncing and the epochNo are the same so we just update the cache until above check passes. - | otherwise -> - handleEpochCachingWhenSyncing - syncEnv - cache - mLastMapEpochFromCache - mEpochBlockDiff + -- The tip has been reached so now replace/update the epoch every block. + | getSyncStatus slotDetails == SyncFollowing -> + handleEpochWhenFollowing syncEnv cache mLastMapEpochFromCache mEpochBlockDiff curEpochNo + -- When syncing we check if current block is the first block in an epoch. + -- If so then it's time to put the previous epoch into the DB. + | isNewEpochEvent -> + updateEpochWhenSyncing syncEnv cache mEpochBlockDiff mLastMapEpochFromCache curEpochNo isBoundaryBlock + -- we're syncing and the epochNo are the same so we just update the cache until above check passes. + | otherwise -> + handleEpochCachingWhenSyncing + syncEnv + cache + mLastMapEpochFromCache + mEpochBlockDiff ----------------------------------------------------------------------------------------------------- -- When Following diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Byron/Genesis.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Byron/Genesis.hs index 8fcf8993c..8b78a5e86 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Byron/Genesis.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Byron/Genesis.hs @@ -64,15 +64,16 @@ insertValidateGenesisDist syncEnv (NetworkName networkName) cfg = do runExceptT $ do liftIO $ logInfo tracer "Inserting Byron Genesis distribution" count <- lift DB.queryBlockCount - when (not disInOut && count > 0) $ - dbSyncNodeError "insertValidateGenesisDist: Genesis data mismatch." - void . lift $ - DB.insertMeta $ - DB.Meta - { DB.metaStartTime = Byron.configStartTime cfg - , DB.metaNetworkName = networkName - , DB.metaVersion = textShow version - } + when (not disInOut && count > 0) + $ dbSyncNodeError "insertValidateGenesisDist: Genesis data mismatch." + void + . lift + $ DB.insertMeta + $ DB.Meta + { DB.metaStartTime = Byron.configStartTime cfg + , DB.metaNetworkName = networkName + , DB.metaVersion = textShow version + } -- Insert an 'artificial' Genesis block (with a genesis specific slot leader). We -- need this block to attach the genesis distribution transactions to. @@ -80,15 +81,17 @@ insertValidateGenesisDist syncEnv (NetworkName networkName) cfg = do -- require plumbing the Genesis.Config into 'insertByronBlockOrEBB' -- which would be a pain in the neck. slid <- - lift . DB.insertSlotLeader $ - DB.SlotLeader + lift + . DB.insertSlotLeader + $ DB.SlotLeader { DB.slotLeaderHash = BS.take 28 $ configGenesisHash cfg , DB.slotLeaderPoolHashId = Nothing , DB.slotLeaderDescription = "Genesis slot leader" } bid <- - lift . DB.insertBlock $ - DB.Block + lift + . DB.insertBlock + $ DB.Block { DB.blockHash = configGenesisHash cfg , DB.blockEpochNo = Nothing , DB.blockSlotNo = Nothing @@ -108,9 +111,10 @@ insertValidateGenesisDist syncEnv (NetworkName networkName) cfg = do , DB.blockOpCertCounter = Nothing } mapM_ (insertTxOutsByron syncEnv disInOut bid) $ genesisTxos cfg - liftIO . logInfo tracer $ - "Initial genesis distribution populated. Hash " - <> renderByteArray (configGenesisHash cfg) + liftIO + . logInfo tracer + $ "Initial genesis distribution populated. Hash " + <> renderByteArray (configGenesisHash cfg) supply <- lift $ DB.queryTotalSupply $ getTxOutTableType syncEnv liftIO $ logInfo tracer ("Total genesis supply of Ada: " <> DB.renderAda supply) @@ -130,47 +134,47 @@ validateGenesisDistribution syncEnv prunes disInOut tracer networkName cfg bid = runExceptT $ do meta <- liftLookupFail "validateGenesisDistribution" DB.queryMeta - when (DB.metaStartTime meta /= Byron.configStartTime cfg) $ - dbSyncNodeError $ - Text.concat - [ "Mismatch chain start time. Config value " - , textShow (Byron.configStartTime cfg) - , " does not match DB value of " - , textShow (DB.metaStartTime meta) - ] + when (DB.metaStartTime meta /= Byron.configStartTime cfg) + $ dbSyncNodeError + $ Text.concat + [ "Mismatch chain start time. Config value " + , textShow (Byron.configStartTime cfg) + , " does not match DB value of " + , textShow (DB.metaStartTime meta) + ] - when (DB.metaNetworkName meta /= networkName) $ - dbSyncNodeError $ - Text.concat - [ "validateGenesisDistribution: Provided network name " - , networkName - , " does not match DB value " - , DB.metaNetworkName meta - ] + when (DB.metaNetworkName meta /= networkName) + $ dbSyncNodeError + $ Text.concat + [ "validateGenesisDistribution: Provided network name " + , networkName + , " does not match DB value " + , DB.metaNetworkName meta + ] txCount <- lift $ DB.queryBlockTxCount bid let expectedTxCount = fromIntegral $ length (genesisTxos cfg) - when (txCount /= expectedTxCount) $ - dbSyncNodeError $ - Text.concat - [ "validateGenesisDistribution: Expected initial block to have " - , textShow expectedTxCount - , " but got " - , textShow txCount - ] + when (txCount /= expectedTxCount) + $ dbSyncNodeError + $ Text.concat + [ "validateGenesisDistribution: Expected initial block to have " + , textShow expectedTxCount + , " but got " + , textShow txCount + ] unless disInOut $ do totalSupply <- lift $ DB.queryGenesisSupply $ getTxOutTableType syncEnv case DB.word64ToAda <$> configGenesisSupply cfg of Left err -> dbSyncNodeError $ "validateGenesisDistribution: " <> textShow err Right expectedSupply -> - when (expectedSupply /= totalSupply && not prunes) $ - dbSyncNodeError $ - Text.concat - [ "validateGenesisDistribution: Expected total supply to be " - , DB.renderAda expectedSupply - , " but got " - , DB.renderAda totalSupply - ] + when (expectedSupply /= totalSupply && not prunes) + $ dbSyncNodeError + $ Text.concat + [ "validateGenesisDistribution: Expected total supply to be " + , DB.renderAda expectedSupply + , " but got " + , DB.renderAda totalSupply + ] liftIO $ do logInfo tracer "Initial genesis distribution present and correct" logInfo tracer ("Total genesis supply of Ada: " <> DB.renderAda totalSupply) @@ -191,8 +195,8 @@ insertTxOutsByron syncEnv disInOut blkId (address, value) = do -- Each address/value pair of the initial coin distribution comes from an artifical transaction -- with a hash generated by hashing the address. txId <- do - DB.insertTx $ - DB.Tx + DB.insertTx + $ DB.Tx { DB.txHash = Byron.unTxHash val , DB.txBlockId = blkId , DB.txBlockIndex = 0 @@ -207,11 +211,12 @@ insertTxOutsByron syncEnv disInOut blkId (address, value) = do , DB.txTreasuryDonation = DB.DbLovelace 0 } -- - unless disInOut $ - case getTxOutTableType syncEnv of + unless disInOut + $ case getTxOutTableType syncEnv of DB.TxOutCore -> - void . DB.insertTxOut $ - DB.CTxOutW + void + . DB.insertTxOut + $ DB.CTxOutW C.TxOut { C.txOutTxId = txId , C.txOutIndex = 0 @@ -229,8 +234,9 @@ insertTxOutsByron syncEnv disInOut blkId (address, value) = do let addrRaw = serialize' address vAddress = mkVAddress addrRaw addrDetailId <- insertAddress addrRaw vAddress - void . DB.insertTxOut $ - DB.VTxOutW (mkVTxOut txId addrDetailId) Nothing + void + . DB.insertTxOut + $ DB.VTxOutW (mkVTxOut txId addrDetailId) Nothing where mkVTxOut :: DB.TxId -> V.AddressId -> V.TxOut mkVTxOut txId addrDetailId = diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Byron/Insert.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Byron/Insert.hs index 90e03c85f..32397e1ac 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Byron/Insert.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Byron/Insert.hs @@ -59,8 +59,8 @@ insertByronBlock :: SlotDetails -> ReaderT SqlBackend m (Either SyncNodeError ()) insertByronBlock syncEnv firstBlockOfEpoch blk details = do - res <- runExceptT $ - case byronBlockRaw blk of + res <- runExceptT + $ case byronBlockRaw blk of Byron.ABOBBlock ablk -> insertABlock syncEnv firstBlockOfEpoch ablk details Byron.ABOBBoundary abblk -> insertABOBBoundary syncEnv abblk details -- Serializing things during syncing can drastically slow down full sync @@ -83,15 +83,17 @@ insertABOBBoundary syncEnv blk details = do pbid <- queryPrevBlockWithCache "insertABOBBoundary" cache (Byron.ebbPrevHash blk) let epochNo = unEpochNo $ sdEpochNo details slid <- - lift . DB.insertSlotLeader $ - DB.SlotLeader + lift + . DB.insertSlotLeader + $ DB.SlotLeader { DB.slotLeaderHash = BS.replicate 28 '\0' , DB.slotLeaderPoolHashId = Nothing , DB.slotLeaderDescription = "Epoch boundary slot leader" } blkId <- - lift . insertBlockAndCache cache $ - DB.Block + lift + . insertBlockAndCache cache + $ DB.Block { DB.blockHash = Byron.unHeaderHash $ Byron.boundaryHashAnnotated blk , DB.blockEpochNo = Just epochNo , -- No slotNo for a boundary block @@ -128,8 +130,9 @@ insertABOBBoundary syncEnv blk details = do , ebdTime = sdSlotTime details } - liftIO . logInfo tracer $ - Text.concat + liftIO + . logInfo tracer + $ Text.concat [ "insertABOBBoundary: epoch " , textShow (Byron.boundaryEpoch $ Byron.boundaryHeader blk) , ", hash " @@ -148,8 +151,9 @@ insertABlock syncEnv firstBlockOfEpoch blk details = do slid <- lift . DB.insertSlotLeader $ Byron.mkSlotLeader blk let txs = Byron.blockPayload blk blkId <- - lift . insertBlockAndCache cache $ - DB.Block + lift + . insertBlockAndCache cache + $ DB.Block { DB.blockHash = Byron.blockHash blk , DB.blockEpochNo = Just $ unEpochNo (sdEpochNo details) , DB.blockSlotNo = Just $ Byron.slotNumber blk @@ -194,8 +198,8 @@ insertABlock syncEnv firstBlockOfEpoch blk details = do followingClosely = getSyncStatus details == SyncFollowing when (followingClosely && slotWithinEpoch /= 0 && Byron.blockNumber blk `mod` 20 == 0) $ do - logInfo tracer $ - mconcat + logInfo tracer + $ mconcat [ "Insert Byron Block: continuing epoch " , textShow epoch , " (slot " @@ -204,8 +208,8 @@ insertABlock syncEnv firstBlockOfEpoch blk details = do , textShow (unEpochSize $ sdEpochSize details) , ")" ] - logger followingClosely tracer $ - mconcat + logger followingClosely tracer + $ mconcat [ "Insert Byron Block: epoch " , textShow (unEpochNo $ sdEpochNo details) , ", slot " @@ -241,8 +245,9 @@ insertByronTx syncEnv blkId tx blockIndex = do if disInOut then do txId <- - lift . DB.insertTx $ - DB.Tx + lift + . DB.insertTx + $ DB.Tx { DB.txHash = Byron.unTxHash $ Crypto.serializeCborHash (Byron.taTx tx) , DB.txBlockId = blkId , DB.txBlockIndex = blockIndex @@ -284,8 +289,9 @@ insertByronTx' syncEnv blkId tx blockIndex = do resolvedInputs <- mapM (resolveTxInputs txOutTableType) (toList $ Byron.txInputs (Byron.taTx tx)) valFee <- firstExceptT annotateTx $ ExceptT $ pure (calculateTxFee (Byron.taTx tx) resolvedInputs) txId <- - lift . DB.insertTx $ - DB.Tx + lift + . DB.insertTx + $ DB.Tx { DB.txHash = Byron.unTxHash $ Crypto.serializeCborHash (Byron.taTx tx) , DB.txBlockId = blkId , DB.txBlockIndex = blockIndex @@ -315,11 +321,11 @@ insertByronTx' syncEnv blkId tx blockIndex = do -- references the output (not sure this can even happen). disInOut <- liftIO $ getDisableInOutState syncEnv lift $ zipWithM_ (insertTxOutByron syncEnv (getHasConsumedOrPruneTxOut syncEnv) disInOut txId) [0 ..] (toList . Byron.txOutputs $ Byron.taTx tx) - unless (getSkipTxIn syncEnv) $ - mapM_ (insertTxIn tracer txId) resolvedInputs - whenConsumeOrPruneTxOut syncEnv $ - lift $ - DB.updateListTxOutConsumedByTxId (prepUpdate txId <$> resolvedInputs) + unless (getSkipTxIn syncEnv) + $ mapM_ (insertTxIn tracer txId) resolvedInputs + whenConsumeOrPruneTxOut syncEnv + $ lift + $ DB.updateListTxOutConsumedByTxId (prepUpdate txId <$> resolvedInputs) -- fees are being returned so we can sum them and put them in cache to use when updating epochs pure $ unDbLovelace $ vfFee valFee where @@ -347,24 +353,25 @@ insertTxOutByron :: Byron.TxOut -> ReaderT SqlBackend m () insertTxOutByron syncEnv _hasConsumed bootStrap txId index txout = - unless bootStrap $ - case ioTxOutTableType . soptInsertOptions $ envOptions syncEnv of + unless bootStrap + $ case ioTxOutTableType . soptInsertOptions $ envOptions syncEnv of DB.TxOutCore -> do - void . DB.insertTxOut $ - DB.CTxOutW $ - C.TxOut - { C.txOutAddress = Text.decodeUtf8 $ Byron.addrToBase58 (Byron.txOutAddress txout) - , C.txOutAddressHasScript = False - , C.txOutDataHash = Nothing - , C.txOutConsumedByTxId = Nothing - , C.txOutIndex = fromIntegral index - , C.txOutInlineDatumId = Nothing - , C.txOutPaymentCred = Nothing -- Byron does not have a payment credential. - , C.txOutReferenceScriptId = Nothing - , C.txOutStakeAddressId = Nothing -- Byron does not have a stake address. - , C.txOutTxId = txId - , C.txOutValue = DbLovelace (Byron.unsafeGetLovelace $ Byron.txOutValue txout) - } + void + . DB.insertTxOut + $ DB.CTxOutW + $ C.TxOut + { C.txOutAddress = Text.decodeUtf8 $ Byron.addrToBase58 (Byron.txOutAddress txout) + , C.txOutAddressHasScript = False + , C.txOutDataHash = Nothing + , C.txOutConsumedByTxId = Nothing + , C.txOutIndex = fromIntegral index + , C.txOutInlineDatumId = Nothing + , C.txOutPaymentCred = Nothing -- Byron does not have a payment credential. + , C.txOutReferenceScriptId = Nothing + , C.txOutStakeAddressId = Nothing -- Byron does not have a stake address. + , C.txOutTxId = txId + , C.txOutValue = DbLovelace (Byron.unsafeGetLovelace $ Byron.txOutValue txout) + } DB.TxOutVariantAddress -> do addrDetailId <- insertAddress void . DB.insertTxOut $ DB.VTxOutW (vTxOut addrDetailId) Nothing @@ -413,8 +420,9 @@ insertTxIn :: (Byron.TxIn, DB.TxId, DB.TxOutIdW, DbLovelace) -> ExceptT SyncNodeError (ReaderT SqlBackend m) DB.TxInId insertTxIn _tracer txInTxId (Byron.TxInUtxo _txHash inIndex, txOutTxId, _, _) = do - lift . DB.insertTxIn $ - DB.TxIn + lift + . DB.insertTxIn + $ DB.TxIn { DB.txInTxInId = txInTxId , DB.txInTxOutId = txOutTxId , DB.txInTxOutIndex = fromIntegral inIndex @@ -434,9 +442,9 @@ resolveTxInputs txOutTableType txIn@(Byron.TxInUtxo txHash index) = do calculateTxFee :: Byron.Tx -> [(Byron.TxIn, DB.TxId, DB.TxOutIdW, DbLovelace)] -> Either SyncNodeError ValueFee calculateTxFee tx resolvedInputs = do outval <- first (\e -> SNErrDefault $ "calculateTxFee: " <> textShow e) output - when (null resolvedInputs) $ - Left $ - SNErrDefault "calculateTxFee: List of transaction inputs is zero." + when (null resolvedInputs) + $ Left + $ SNErrDefault "calculateTxFee: List of transaction inputs is zero." let inval = sum $ map (unDbLovelace . forth4) resolvedInputs if inval < outval then Left $ SNErrInvariant "calculateTxFee" $ EInvInOut inval outval diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Cardano/Insert.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Cardano/Insert.hs index 9fb9da939..9759059fc 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Cardano/Insert.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Cardano/Insert.hs @@ -35,8 +35,9 @@ insertEpochSyncTime :: insertEpochSyncTime epochNo syncState estvar = do now <- liftIO Time.getCurrentTime mlast <- liftIO . atomically $ swapTVar estvar now - void . Db.insertEpochSyncTime $ - Db.EpochSyncTime + void + . Db.insertEpochSyncTime + $ Db.EpochSyncTime { Db.epochSyncTimeNo = unEpochNo epochNo - 1 , Db.epochSyncTimeSeconds = ceiling (realToFrac (Time.diffUTCTime now mlast) :: Double) , Db.epochSyncTimeState = syncState diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Script.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Script.hs index 7337d5c58..e335d2eaa 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Script.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Script.hs @@ -214,7 +214,7 @@ parseScriptAny = Aeson.withObject "any" $ \obj -> do _ -> fail "\"any\" script value not found" parseScriptMOf :: - (FromJSON script) => + FromJSON script => Aeson.Value -> Parser (Int, [script]) parseScriptMOf = Aeson.withObject "atLeast" $ \obj -> do @@ -223,19 +223,19 @@ parseScriptMOf = Aeson.withObject "atLeast" $ \obj -> do "atLeast" -> do scripts <- obj .: "scripts" req <- obj .: "required" - when (req > length scripts) $ - reqMismatchedFailure req scripts + when (req > length scripts) + $ reqMismatchedFailure req scripts pure (req, scripts) _ -> fail "\"atLeast\" script value not found" where reqMismatchedFailure req scripts = - fail $ - "Required number of script signature exceeds the number of scripts." - <> " Required: " - <> show req - <> " Scripts: " - <> show (length scripts) + fail + $ "Required number of script signature exceeds the number of scripts." + <> " Required: " + <> show req + <> " Scripts: " + <> show (length scripts) parseTimelockExpire :: (Allegra.AllegraEraScript era, Core.NativeScript era ~ Allegra.Timelock era) => Aeson.Value -> Parser (Allegra.Timelock era) parseTimelockExpire = Aeson.withObject "before" $ \obj -> do diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/StakeDist.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/StakeDist.hs index d6964a7cd..43541b24c 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/StakeDist.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/StakeDist.hs @@ -116,8 +116,10 @@ genericStakeSlice pInfo epochBlockNo lstate isMigration -- epoch plus one. stakeSnapshot :: Ledger.SnapShot c stakeSnapshot = - Ledger.ssStakeMark . Shelley.esSnapshots . Shelley.nesEs $ - Consensus.shelleyLedgerState lstate + Ledger.ssStakeMark + . Shelley.esSnapshots + . Shelley.nesEs + $ Consensus.shelleyLedgerState lstate delegations :: VMap.KVVector VB VB (Credential 'Staking c, KeyHash 'StakePool c) delegations = VMap.unVMap $ Ledger.ssDelegations stakeSnapshot @@ -172,9 +174,9 @@ genericStakeSlice pInfo epochBlockNo lstate isMigration distribution :: Map StakeCred (Coin, PoolKeyHash) distribution = - VMap.toMap $ - VMap.mapMaybe id $ - VMap.mapWithKey (\a p -> (,p) <$> lookupStake a) delegationsSliced + VMap.toMap + $ VMap.mapMaybe id + $ VMap.mapWithKey (\a p -> (,p) <$> lookupStake a) delegationsSliced getPoolDistr :: ExtLedgerState CardanoBlock -> @@ -191,7 +193,7 @@ getPoolDistr els = genericPoolDistr :: forall era p. - (EraCrypto era ~ StandardCrypto) => + EraCrypto era ~ StandardCrypto => LedgerState (ShelleyBlock p era) -> (Map PoolKeyHash (Coin, Word64), Map PoolKeyHash Natural) genericPoolDistr lstate = diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx/Allegra.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx/Allegra.hs index 4ed3ef002..ee9f898d0 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx/Allegra.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx/Allegra.hs @@ -124,8 +124,10 @@ mkTxScript (hsh, script) = , txScriptType = Timelock , txScriptPlutusSize = Nothing , txScriptJson = - Just . LBS.toStrict . Aeson.encode $ - fromTimelock script + Just + . LBS.toStrict + . Aeson.encode + $ fromTimelock script , txScriptCBOR = Nothing } diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx/Alonzo.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx/Alonzo.hs index 4b551fda4..ea4db1654 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx/Alonzo.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Generic/Tx/Alonzo.hs @@ -172,9 +172,9 @@ getScripts tx = case strictMaybeToMaybe maux of Nothing -> [] Just auxData -> - map (\scr -> (Core.hashScript @era scr, scr)) $ - toList $ - getAlonzoTxAuxDataScripts auxData + map (\scr -> (Core.hashScript @era scr, scr)) + $ toList + $ getAlonzoTxAuxDataScripts auxData resolveRedeemers :: forall era. @@ -192,24 +192,26 @@ resolveRedeemers ioExtraPlutus mprices tx toCert = if not ioExtraPlutus then (initRedeemersMaps, []) else - mkRdmrAndUpdateRec (initRedeemersMaps, []) $ - zip [0 ..] $ - Map.toList (Alonzo.unRedeemers (tx ^. (Core.witsTxL . Alonzo.rdmrsTxWitsL))) + mkRdmrAndUpdateRec (initRedeemersMaps, []) + $ zip [0 ..] + $ Map.toList (Alonzo.unRedeemers (tx ^. (Core.witsTxL . Alonzo.rdmrsTxWitsL))) where txBody :: Core.TxBody era txBody = tx ^. Core.bodyTxL withdrawalsNoRedeemers :: Map (Shelley.RewardAccount StandardCrypto) TxWithdrawal withdrawalsNoRedeemers = - Map.mapWithKey (curry mkTxWithdrawal) $ - Shelley.unWithdrawals $ - txBody ^. Core.withdrawalsTxBodyL + Map.mapWithKey (curry mkTxWithdrawal) + $ Shelley.unWithdrawals + $ txBody + ^. Core.withdrawalsTxBodyL txCertsNoRedeemers :: [(Cert, TxCertificate)] txCertsNoRedeemers = - zipWith (\n dcert -> (dcert, toTxCert n dcert)) [0 ..] $ - toList $ - toCert <$> (txBody ^. Core.certsTxBodyL) + zipWith (\n dcert -> (dcert, toTxCert n dcert)) [0 ..] + $ toList + $ toCert + <$> (txBody ^. Core.certsTxBodyL) txInsMissingRedeemer :: Map (Ledger.TxIn StandardCrypto) TxIn txInsMissingRedeemer = Map.fromList $ fmap (\inp -> (inp, fromTxIn inp)) $ toList $ txBody ^. Core.inputsTxBodyL @@ -336,9 +338,10 @@ getPlutusSizes :: Core.Tx era -> [Word64] getPlutusSizes tx = - mapMaybe getPlutusScriptSize $ - Map.elems $ - tx ^. (Core.witsTxL . Alonzo.scriptAlonzoTxWitsL) + mapMaybe getPlutusScriptSize + $ Map.elems + $ tx + ^. (Core.witsTxL . Alonzo.scriptAlonzoTxWitsL) -- | Returns Nothing for non-plutus scripts. getPlutusScriptSize :: Alonzo.AlonzoEraScript era => Alonzo.AlonzoScript era -> Maybe Word64 @@ -369,9 +372,10 @@ extraKeyWits :: Core.TxBody era -> [ByteString] extraKeyWits txBody = - Set.toList $ - Set.map (\(Ledger.KeyHash h) -> Crypto.hashToBytes h) $ - txBody ^. Alonzo.reqSignerHashesTxBodyL + Set.toList + $ Set.map (\(Ledger.KeyHash h) -> Crypto.hashToBytes h) + $ txBody + ^. Alonzo.reqSignerHashesTxBodyL scriptHashAcnt :: Shelley.RewardAccount StandardCrypto -> Maybe ByteString scriptHashAcnt rewardAddr = getCredentialScriptHash $ Ledger.raCredential rewardAddr diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Genesis.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Genesis.hs index 0dcde23af..c3ac15f4b 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Genesis.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Genesis.hs @@ -99,16 +99,18 @@ insertValidateGenesisDist syncEnv networkName cfg shelleyInitiation = do Right _ -> pure () -- Metadata from Shelley era already exists. TODO Validate metadata. Left _ -> do count <- lift DB.queryBlockCount - when (count > 0) $ - dbSyncNodeError $ - "Shelley.insertValidateGenesisDist: Genesis data mismatch. count " <> textShow count - void . lift $ - DB.insertMeta $ - DB.Meta - { DB.metaStartTime = configStartTime cfg - , DB.metaNetworkName = networkName - , DB.metaVersion = textShow version - } + when (count > 0) + $ dbSyncNodeError + $ "Shelley.insertValidateGenesisDist: Genesis data mismatch. count " + <> textShow count + void + . lift + $ DB.insertMeta + $ DB.Meta + { DB.metaStartTime = configStartTime cfg + , DB.metaNetworkName = networkName + , DB.metaVersion = textShow version + } -- No reason to insert the artificial block if there are no funds or stakes definitions. when (hasInitialFunds || hasStakes) $ do -- Insert an 'artificial' Genesis block (with a genesis specific slot leader). We @@ -117,8 +119,9 @@ insertValidateGenesisDist syncEnv networkName cfg shelleyInitiation = do -- require plumbing the Genesis.Config into 'insertByronBlockOrEBB' -- which would be a pain in the neck. slid <- - lift . DB.insertSlotLeader $ - DB.SlotLeader + lift + . DB.insertSlotLeader + $ DB.SlotLeader { DB.slotLeaderHash = genesisHashSlotLeader cfg , DB.slotLeaderPoolHashId = Nothing , DB.slotLeaderDescription = "Shelley Genesis slot leader" @@ -131,8 +134,9 @@ insertValidateGenesisDist syncEnv networkName cfg shelleyInitiation = do pid <- lift DB.queryLatestBlockId liftIO $ logInfo tracer $ textShow pid bid <- - lift . DB.insertBlock $ - DB.Block + lift + . DB.insertBlock + $ DB.Block { DB.blockHash = configGenesisHash cfg , DB.blockEpochNo = Nothing , DB.blockSlotNo = Nothing @@ -154,11 +158,12 @@ insertValidateGenesisDist syncEnv networkName cfg shelleyInitiation = do disInOut <- liftIO $ getDisableInOutState syncEnv unless disInOut $ do lift $ mapM_ (insertTxOuts syncEnv tracer bid) $ genesisUtxOs cfg - liftIO . logInfo tracer $ - "Initial genesis distribution populated. Hash " - <> renderByteArray (configGenesisHash cfg) - when hasStakes $ - insertStaking tracer useNoCache bid cfg + liftIO + . logInfo tracer + $ "Initial genesis distribution populated. Hash " + <> renderByteArray (configGenesisHash cfg) + when hasStakes + $ insertStaking tracer useNoCache bid cfg -- | Validate that the initial Genesis distribution in the DB matches the Genesis data. validateGenesisDistribution :: @@ -177,43 +182,43 @@ validateGenesisDistribution syncEnv prunes networkName cfg bid expectedTxCount = liftIO $ logInfo tracer "Validating Genesis distribution" meta <- liftLookupFail "Shelley.validateGenesisDistribution" DB.queryMeta - when (DB.metaStartTime meta /= configStartTime cfg) $ - dbSyncNodeError $ - Text.concat - [ "Shelley: Mismatch chain start time. Config value " - , textShow (configStartTime cfg) - , " does not match DB value of " - , textShow (DB.metaStartTime meta) - ] + when (DB.metaStartTime meta /= configStartTime cfg) + $ dbSyncNodeError + $ Text.concat + [ "Shelley: Mismatch chain start time. Config value " + , textShow (configStartTime cfg) + , " does not match DB value of " + , textShow (DB.metaStartTime meta) + ] - when (DB.metaNetworkName meta /= networkName) $ - dbSyncNodeError $ - Text.concat - [ "Shelley.validateGenesisDistribution: Provided network name " - , networkName - , " does not match DB value " - , DB.metaNetworkName meta - ] + when (DB.metaNetworkName meta /= networkName) + $ dbSyncNodeError + $ Text.concat + [ "Shelley.validateGenesisDistribution: Provided network name " + , networkName + , " does not match DB value " + , DB.metaNetworkName meta + ] txCount <- lift $ DB.queryBlockTxCount bid - when (txCount /= expectedTxCount) $ - dbSyncNodeError $ - Text.concat - [ "Shelley.validateGenesisDistribution: Expected initial block to have " - , textShow expectedTxCount - , " but got " - , textShow txCount - ] + when (txCount /= expectedTxCount) + $ dbSyncNodeError + $ Text.concat + [ "Shelley.validateGenesisDistribution: Expected initial block to have " + , textShow expectedTxCount + , " but got " + , textShow txCount + ] totalSupply <- lift $ DB.queryShelleyGenesisSupply txOutTableType let expectedSupply = configGenesisSupply cfg - when (expectedSupply /= totalSupply && not prunes) $ - dbSyncNodeError $ - Text.concat - [ "Shelley.validateGenesisDistribution: Expected total supply to be " - , textShow expectedSupply - , " but got " - , textShow totalSupply - ] + when (expectedSupply /= totalSupply && not prunes) + $ dbSyncNodeError + $ Text.concat + [ "Shelley.validateGenesisDistribution: Expected total supply to be " + , textShow expectedSupply + , " but got " + , textShow totalSupply + ] liftIO $ do logInfo tracer "Initial genesis distribution present and correct" logInfo tracer ("Total genesis supply of Ada: " <> DB.renderAda totalSupply) @@ -231,8 +236,8 @@ insertTxOuts syncEnv trce blkId (TxIn txInId _, txOut) = do -- Each address/value pair of the initial coin distribution comes from an artifical transaction -- with a hash generated by hashing the address. txId <- - DB.insertTx $ - DB.Tx + DB.insertTx + $ DB.Tx { DB.txHash = Generic.unTxHash txInId , DB.txBlockId = blkId , DB.txBlockIndex = 0 @@ -251,8 +256,9 @@ insertTxOuts syncEnv trce blkId (TxIn txInId _, txOut) = do _ <- insertStakeAddressRefIfMissing trce useNoCache (txOut ^. Core.addrTxOutL) case ioTxOutTableType . soptInsertOptions $ envOptions syncEnv of DB.TxOutCore -> - void . DB.insertTxOut $ - DB.CTxOutW + void + . DB.insertTxOut + $ DB.CTxOutW C.TxOut { C.txOutAddress = Generic.renderAddress addr , C.txOutAddressHasScript = hasScript @@ -320,22 +326,22 @@ insertStaking tracer cache blkId genesis = do -- All Genesis staking comes from an artifical transaction -- with a hash generated by hashing the address. txId <- - lift $ - DB.insertTx $ - DB.Tx - { DB.txHash = configGenesisStakingHash - , DB.txBlockId = blkId - , DB.txBlockIndex = 0 - , DB.txOutSum = DB.DbLovelace 0 - , DB.txFee = DB.DbLovelace 0 - , DB.txDeposit = Just 0 - , DB.txSize = 0 - , DB.txInvalidHereafter = Nothing - , DB.txInvalidBefore = Nothing - , DB.txValidContract = True - , DB.txScriptSize = 0 - , DB.txTreasuryDonation = DB.DbLovelace 0 - } + lift + $ DB.insertTx + $ DB.Tx + { DB.txHash = configGenesisStakingHash + , DB.txBlockId = blkId + , DB.txBlockIndex = 0 + , DB.txOutSum = DB.DbLovelace 0 + , DB.txFee = DB.DbLovelace 0 + , DB.txDeposit = Just 0 + , DB.txSize = 0 + , DB.txInvalidHereafter = Nothing + , DB.txInvalidBefore = Nothing + , DB.txValidContract = True + , DB.txScriptSize = 0 + , DB.txTreasuryDonation = DB.DbLovelace 0 + } let params = zip [0 ..] $ ListMap.elems $ sgsPools $ sgStaking genesis let network = sgNetworkId genesis -- TODO: add initial deposits for genesis pools. diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/ValidateWithdrawal.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/ValidateWithdrawal.hs index 3bb8b82da..18f3da879 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/ValidateWithdrawal.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Shelley/ValidateWithdrawal.hs @@ -136,12 +136,12 @@ queryBadWithdrawals :: MonadIO m => ReaderT SqlBackend m [AddressInfo] queryBadWithdrawals = do res <- select $ do (rwd :& sa :& wdrl) <- - from - $ table @Db.Reward + from $ + table @Db.Reward `innerJoin` table @Db.StakeAddress - `on` (\(rwd :& sa) -> rwd ^. Db.RewardAddrId ==. sa ^. Db.StakeAddressId) + `on` (\(rwd :& sa) -> rwd ^. Db.RewardAddrId ==. sa ^. Db.StakeAddressId) `innerJoin` table @Db.Withdrawal - `on` (\(rwd :& _sa :& wdrl) -> rwd ^. Db.RewardAddrId ==. wdrl ^. Db.WithdrawalAddrId) + `on` (\(rwd :& _sa :& wdrl) -> rwd ^. Db.RewardAddrId ==. wdrl ^. Db.WithdrawalAddrId) groupBy (sa ^. Db.StakeAddressId) let sumReward = sum_ (rwd ^. Db.RewardAmount) sumWithdraw = sum_ (wdrl ^. Db.WithdrawalAmount) diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Adjust.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Adjust.hs index 3c2dae95d..916dd273c 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Adjust.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Adjust.hs @@ -57,8 +57,9 @@ adjustEpochRewards :: ReaderT SqlBackend m () adjustEpochRewards trce nw cache epochNo rwds creds = do let eraIgnored = Map.toList $ Generic.unRewards rwds - liftIO . logInfo trce $ - mconcat + liftIO + . logInfo trce + $ mconcat [ "Removing " , if null eraIgnored then "" else textShow (length eraIgnored) <> " rewards and " , show (length creds) diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Block.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Block.hs index 0a30009e8..333c8bfd6 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Block.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Block.hs @@ -76,8 +76,9 @@ insertBlockUniversal syncEnv shouldLog withinTwoMins withinHalfHour blk details slid <- lift . DB.insertSlotLeader $ Generic.mkSlotLeader (ioShelley iopts) (Generic.unKeyHashRaw $ Generic.blkSlotLeader blk) (eitherToMaybe mPhid) blkId <- - lift . insertBlockAndCache cache $ - DB.Block + lift + . insertBlockAndCache cache + $ DB.Block { DB.blockHash = Generic.blkHash blk , DB.blockEpochNo = Just $ unEpochNo epochNo , DB.blockSlotNo = Just $ unSlotNo (Generic.blkSlotNo blk) @@ -117,16 +118,16 @@ insertBlockUniversal syncEnv shouldLog withinTwoMins withinHalfHour blk details , ebdTxCount = fromIntegral $ length (Generic.blkTxs blk) } - when withinHalfHour $ - insertReverseIndex blkId minIds + when withinHalfHour + $ insertReverseIndex blkId minIds liftIO $ do let epoch = unEpochNo epochNo slotWithinEpoch = unEpochSlot (sdEpochSlot details) when (withinTwoMins && slotWithinEpoch /= 0 && unBlockNo (Generic.blkBlockNo blk) `mod` 20 == 0) $ do - logInfo tracer $ - mconcat + logInfo tracer + $ mconcat [ renderInsertName (Generic.blkEra blk) , ": continuing epoch " , textShow epoch @@ -136,8 +137,8 @@ insertBlockUniversal syncEnv shouldLog withinTwoMins withinHalfHour blk details , textShow (unEpochSize $ sdEpochSize details) , ")" ] - logger tracer $ - mconcat + logger tracer + $ mconcat [ renderInsertName (Generic.blkEra blk) , ": epoch " , textShow (unEpochNo epochNo) diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Epoch.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Epoch.hs index cc1f86205..b5f081b0f 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Epoch.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Epoch.hs @@ -237,8 +237,8 @@ insertEpochStake syncEnv nw epochNo stakeChunk = do mkStake cache (saddr, (coin, pool)) = do saId <- lift $ queryOrInsertStakeAddress trce cache UpdateCacheStrong nw saddr poolId <- lift $ queryPoolKeyOrInsert "insertEpochStake" trce cache UpdateCache (ioShelley iopts) pool - pure $ - DB.EpochStake + pure + $ DB.EpochStake { DB.epochStakeAddrId = saId , DB.epochStakePoolId = poolId , DB.epochStakeAmount = Generic.coinToDbLovelace coin @@ -279,8 +279,8 @@ insertRewards syncEnv nw earnedEpoch spendableEpoch cache rewardsChunk = do ExceptT SyncNodeError (ReaderT SqlBackend m) DB.Reward prepareReward saId rwd = do poolId <- queryPool (Generic.rewardPool rwd) - pure $ - DB.Reward + pure + $ DB.Reward { DB.rewardAddrId = saId , DB.rewardType = Generic.rewardSource rwd , DB.rewardAmount = Generic.coinToDbLovelace (Generic.rewardAmount rwd) @@ -354,8 +354,8 @@ insertProposalRefunds trce nw earnedEpoch spendableEpoch cache refunds = do ExceptT SyncNodeError (ReaderT SqlBackend m) DB.RewardRest mkReward refund = do saId <- lift $ queryOrInsertStakeAddress trce cache UpdateCacheStrong nw (raCredential $ garReturnAddr refund) - pure $ - DB.RewardRest + pure + $ DB.RewardRest { DB.rewardRestAddrId = saId , DB.rewardRestType = DB.RwdProposalRefund , DB.rewardRestAmount = Generic.coinToDbLovelace (garDeposit refund) diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Certificate.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Certificate.hs index 46aac293a..4670acc56 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Certificate.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Certificate.hs @@ -78,9 +78,9 @@ insertCertificate syncEnv isMember mDeposits blkId txId epochNo slotNo redeemers Left (ShelleyTxCertMir mir) -> when (ioShelley iopts) $ insertMirCert tracer cache network txId idx mir Left (ShelleyTxCertGenesisDeleg _gen) -> - when (ioShelley iopts) $ - liftIO $ - logWarning tracer "insertCertificate: Unhandled DCertGenesis certificate" + when (ioShelley iopts) + $ liftIO + $ logWarning tracer "insertCertificate: Unhandled DCertGenesis certificate" Right (ConwayTxCertDeleg deleg) -> insertConwayDelegCert syncEnv mDeposits txId idx mRedeemerId epochNo slotNo deleg Right (ConwayTxCertPool pool) -> @@ -137,31 +137,31 @@ insertConwayDelegCert :: insertConwayDelegCert syncEnv mDeposits txId idx mRedeemerId epochNo slotNo dCert = case dCert of ConwayRegCert cred _dep -> - when (ioShelley iopts) $ - insertStakeRegistration trce cache epochNo mDeposits txId idx $ - Generic.annotateStakingCred network cred + when (ioShelley iopts) + $ insertStakeRegistration trce cache epochNo mDeposits txId idx + $ Generic.annotateStakingCred network cred ConwayUnRegCert cred _dep -> - when (ioShelley iopts) $ - insertStakeDeregistration trce cache network epochNo txId idx mRedeemerId cred + when (ioShelley iopts) + $ insertStakeDeregistration trce cache network epochNo txId idx mRedeemerId cred ConwayDelegCert cred delegatee -> insertDeleg cred delegatee ConwayRegDelegCert cred delegatee _dep -> do - when (ioShelley iopts) $ - insertStakeRegistration trce cache epochNo mDeposits txId idx $ - Generic.annotateStakingCred network cred + when (ioShelley iopts) + $ insertStakeRegistration trce cache epochNo mDeposits txId idx + $ Generic.annotateStakingCred network cred insertDeleg cred delegatee where insertDeleg cred = \case DelegStake poolkh -> - when (ioShelley iopts) $ - insertDelegation trce cache network epochNo slotNo txId idx mRedeemerId cred poolkh + when (ioShelley iopts) + $ insertDelegation trce cache network epochNo slotNo txId idx mRedeemerId cred poolkh DelegVote drep -> - when (ioGov iopts) $ - insertDelegationVote trce cache network txId idx cred drep + when (ioGov iopts) + $ insertDelegationVote trce cache network txId idx cred drep DelegStakeVote poolkh drep -> do - when (ioShelley iopts) $ - insertDelegation trce cache network epochNo slotNo txId idx mRedeemerId cred poolkh - when (ioGov iopts) $ - insertDelegationVote trce cache network txId idx cred drep + when (ioShelley iopts) + $ insertDelegation trce cache network epochNo slotNo txId idx mRedeemerId cred poolkh + when (ioGov iopts) + $ insertDelegationVote trce cache network txId idx cred drep trce = getTrace syncEnv cache = envCache syncEnv @@ -194,8 +194,10 @@ insertMirCert tracer cache network txId idx mcert = do ExceptT SyncNodeError (ReaderT SqlBackend m) () insertMirReserves (cred, dcoin) = do addrId <- lift $ queryOrInsertStakeAddress tracer cache UpdateCacheStrong network cred - void . lift . DB.insertReserve $ - DB.Reserve + void + . lift + . DB.insertReserve + $ DB.Reserve { DB.reserveAddrId = addrId , DB.reserveCertIndex = idx , DB.reserveTxId = txId @@ -208,8 +210,10 @@ insertMirCert tracer cache network txId idx mcert = do ExceptT SyncNodeError (ReaderT SqlBackend m) () insertMirTreasury (cred, dcoin) = do addrId <- lift $ queryOrInsertStakeAddress tracer cache UpdateCacheStrong network cred - void . lift . DB.insertTreasury $ - DB.Treasury + void + . lift + . DB.insertTreasury + $ DB.Treasury { DB.treasuryAddrId = addrId , DB.treasuryCertIndex = idx , DB.treasuryTxId = txId @@ -327,8 +331,10 @@ insertStakeDeregistration :: ExceptT SyncNodeError (ReaderT SqlBackend m) () insertStakeDeregistration trce cache network epochNo txId idx mRedeemerId cred = do scId <- lift $ queryOrInsertStakeAddress trce cache EvictAndUpdateCache network cred - void . lift . DB.insertStakeDeregistration $ - DB.StakeDeregistration + void + . lift + . DB.insertStakeDeregistration + $ DB.StakeDeregistration { DB.stakeDeregistrationAddrId = scId , DB.stakeDeregistrationCertIndex = idx , DB.stakeDeregistrationEpochNo = unEpochNo epochNo @@ -348,8 +354,10 @@ insertStakeRegistration :: ExceptT SyncNodeError (ReaderT SqlBackend m) () insertStakeRegistration tracer cache epochNo mDeposits txId idx rewardAccount = do saId <- lift $ queryOrInsertRewardAccount tracer cache UpdateCache rewardAccount - void . lift . DB.insertStakeRegistration $ - DB.StakeRegistration + void + . lift + . DB.insertStakeRegistration + $ DB.StakeRegistration { DB.stakeRegistrationAddrId = saId , DB.stakeRegistrationCertIndex = idx , DB.stakeRegistrationEpochNo = unEpochNo epochNo @@ -415,8 +423,10 @@ insertDelegation :: insertDelegation trce cache network (EpochNo epoch) slotNo txId idx mRedeemerId cred poolkh = do addrId <- lift $ queryOrInsertStakeAddress trce cache UpdateCacheStrong network cred poolHashId <- lift $ queryPoolKeyOrInsert "insertDelegation" trce cache UpdateCache True poolkh - void . lift . DB.insertDelegation $ - DB.Delegation + void + . lift + . DB.insertDelegation + $ DB.Delegation { DB.delegationAddrId = addrId , DB.delegationCertIndex = idx , DB.delegationPoolHashId = poolHashId diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/GovAction.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/GovAction.hs index 6de4a5362..71ac624a2 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/GovAction.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/GovAction.hs @@ -81,8 +81,8 @@ insertGovActionProposal trce cache blkId txId govExpiresAt mcgs (index, (govId, addrId <- lift $ queryOrInsertRewardAccount trce cache UpdateCache $ pProcReturnAddr pp votingAnchorId <- lift $ insertVotingAnchor blkId DB.GovActionAnchor $ pProcAnchor pp - mParamProposalId <- lift $ - case pProcGovAction pp of + mParamProposalId <- lift + $ case pProcGovAction pp of ParameterChange _ pparams _ -> Just <$> insertParamProposal blkId txId (convertConwayParamProposal pparams) _ -> pure Nothing @@ -90,24 +90,24 @@ insertGovActionProposal trce cache blkId txId govExpiresAt mcgs (index, (govId, Nothing -> pure Nothing Just prevGovActionId -> Just <$> resolveGovActionProposal cache prevGovActionId govActionProposalId <- - lift $ - DB.insertGovActionProposal $ - DB.GovActionProposal - { DB.govActionProposalTxId = txId - , DB.govActionProposalIndex = index - , DB.govActionProposalPrevGovActionProposal = prevGovActionDBId - , DB.govActionProposalDeposit = Generic.coinToDbLovelace $ pProcDeposit pp - , DB.govActionProposalReturnAddress = addrId - , DB.govActionProposalExpiration = (\epochNum -> unEpochNo epochNum + 1) <$> govExpiresAt - , DB.govActionProposalVotingAnchorId = Just votingAnchorId - , DB.govActionProposalType = Generic.toGovAction $ pProcGovAction pp - , DB.govActionProposalDescription = Text.decodeUtf8 $ LBS.toStrict $ Aeson.encode (pProcGovAction pp) - , DB.govActionProposalParamProposal = mParamProposalId - , DB.govActionProposalRatifiedEpoch = Nothing - , DB.govActionProposalEnactedEpoch = Nothing - , DB.govActionProposalDroppedEpoch = Nothing - , DB.govActionProposalExpiredEpoch = Nothing - } + lift + $ DB.insertGovActionProposal + $ DB.GovActionProposal + { DB.govActionProposalTxId = txId + , DB.govActionProposalIndex = index + , DB.govActionProposalPrevGovActionProposal = prevGovActionDBId + , DB.govActionProposalDeposit = Generic.coinToDbLovelace $ pProcDeposit pp + , DB.govActionProposalReturnAddress = addrId + , DB.govActionProposalExpiration = (\epochNum -> unEpochNo epochNum + 1) <$> govExpiresAt + , DB.govActionProposalVotingAnchorId = Just votingAnchorId + , DB.govActionProposalType = Generic.toGovAction $ pProcGovAction pp + , DB.govActionProposalDescription = Text.decodeUtf8 $ LBS.toStrict $ Aeson.encode (pProcGovAction pp) + , DB.govActionProposalParamProposal = mParamProposalId + , DB.govActionProposalRatifiedEpoch = Nothing + , DB.govActionProposalEnactedEpoch = Nothing + , DB.govActionProposalDroppedEpoch = Nothing + , DB.govActionProposalExpiredEpoch = Nothing + } case pProcGovAction pp of TreasuryWithdrawals mp _ -> lift $ mapM_ (insertTreasuryWithdrawal govActionProposalId) (Map.toList mp) UpdateCommittee {} -> lift $ insertNewCommittee govActionProposalId @@ -125,8 +125,8 @@ insertGovActionProposal trce cache blkId txId govExpiresAt mcgs (index, (govId, insertTreasuryWithdrawal gaId (rwdAcc, coin) = do addrId <- queryOrInsertRewardAccount trce cache UpdateCache rwdAcc - DB.insertTreasuryWithdrawal $ - DB.TreasuryWithdrawal + DB.insertTreasuryWithdrawal + $ DB.TreasuryWithdrawal { DB.treasuryWithdrawalGovActionProposalId = gaId , DB.treasuryWithdrawalStakeAddressId = addrId , DB.treasuryWithdrawalAmount = Generic.coinToDbLovelace coin @@ -151,16 +151,17 @@ insertCommittee mgapId committee = do r = unboundRational $ committeeThreshold committee -- TODO work directly with Ratio Word64. This is not currently supported in ledger insertNewMember committeeId (cred, e) = do chId <- insertCommitteeHash cred - void . DB.insertCommitteeMember $ - DB.CommitteeMember + void + . DB.insertCommitteeMember + $ DB.CommitteeMember { DB.committeeMemberCommitteeId = committeeId , DB.committeeMemberCommitteeHashId = chId , DB.committeeMemberExpirationEpoch = unEpochNo e } insertCommitteeDB = - DB.insertCommittee $ - DB.Committee + DB.insertCommittee + $ DB.Committee { DB.committeeGovActionProposalId = mgapId , DB.committeeQuorumNumerator = fromIntegral $ numerator r , DB.committeeQuorumDenominator = fromIntegral $ denominator r @@ -178,8 +179,8 @@ resolveGovActionProposal cache gaId = do let txId = gaidTxId gaId gaTxId <- liftLookupFail "resolveGovActionProposal.queryTxId" $ queryTxIdWithCache cache txId let (GovActionIx index) = gaidGovActionIx gaId - liftLookupFail "resolveGovActionProposal.queryGovActionProposalId" $ - DB.queryGovActionProposalId gaTxId (fromIntegral index) -- TODO: Use Word32? + liftLookupFail "resolveGovActionProposal.queryGovActionProposalId" + $ DB.queryGovActionProposalId gaTxId (fromIntegral index) -- TODO: Use Word32? insertParamProposal :: (MonadBaseControl IO m, MonadIO m) => @@ -189,8 +190,8 @@ insertParamProposal :: ReaderT SqlBackend m DB.ParamProposalId insertParamProposal blkId txId pp = do cmId <- maybe (pure Nothing) (fmap Just . insertCostModel blkId) (pppCostmdls pp) - DB.insertParamProposal $ - DB.ParamProposal + DB.insertParamProposal + $ DB.ParamProposal { DB.paramProposalRegisteredTxId = txId , DB.paramProposalEpochNo = unEpochNo <$> pppEpochNo pp , DB.paramProposalKey = pppKey pp @@ -252,8 +253,8 @@ insertParamProposal blkId txId pp = do insertConstitution :: (MonadIO m, MonadBaseControl IO m) => DB.BlockId -> Maybe DB.GovActionProposalId -> Constitution StandardConway -> ReaderT SqlBackend m DB.ConstitutionId insertConstitution blockId mgapId constitution = do votingAnchorId <- insertVotingAnchor blockId DB.ConstitutionAnchor $ constitutionAnchor constitution - DB.insertConstitution $ - DB.Constitution + DB.insertConstitution + $ DB.Constitution { DB.constitutionGovActionProposalId = mgapId , DB.constitutionVotingAnchorId = votingAnchorId , DB.constitutionScriptHash = Generic.unScriptHash <$> strictMaybeToMaybe (constitutionScript constitution) @@ -313,8 +314,8 @@ insertVotingProcedure trce cache blkId txId voter (index, (gaId, vp)) = do insertVotingAnchor :: (MonadIO m, MonadBaseControl IO m) => DB.BlockId -> DB.AnchorType -> Anchor StandardCrypto -> ReaderT SqlBackend m DB.VotingAnchorId insertVotingAnchor blockId anchorType anchor = - DB.insertAnchor $ - DB.VotingAnchor + DB.insertAnchor + $ DB.VotingAnchor { DB.votingAnchorBlockId = blockId , DB.votingAnchorUrl = DB.VoteUrl $ Ledger.urlToText $ anchorUrl anchor -- TODO: Conway check unicode and size of URL , DB.votingAnchorDataHash = Generic.safeHashToByteString $ anchorDataHash anchor @@ -357,8 +358,8 @@ insertDrepDistr e pSnapshot = do mkEntry :: (DRep StandardCrypto, Ledger.CompactForm Coin) -> ReaderT SqlBackend m DB.DrepDistr mkEntry (drep, coin) = do drepId <- insertDrep drep - pure $ - DB.DrepDistr + pure + $ DB.DrepDistr { DB.drepDistrHashId = drepId , DB.drepDistrAmount = fromIntegral $ unCoin $ fromCompact coin , DB.drepDistrEpochNo = unEpochNo e @@ -377,8 +378,8 @@ insertCostModel :: Map Language Ledger.CostModel -> ReaderT SqlBackend m DB.CostModelId insertCostModel _blkId cms = - DB.insertCostModel $ - DB.CostModel + DB.insertCostModel + $ DB.CostModel { DB.costModelHash = Crypto.abstractHashToBytes $ Crypto.serializeCborHash $ Ledger.mkCostModels cms , DB.costModelCosts = Text.decodeUtf8 $ LBS.toStrict $ Aeson.encode cms } @@ -431,15 +432,15 @@ insertUpdateEnacted :: insertUpdateEnacted trce cache blkId epochNo enactedState = do (mcommitteeId, mnoConfidenceGaId) <- handleCommittee constitutionId <- handleConstitution - void $ - lift $ - DB.insertEpochState - DB.EpochState - { DB.epochStateCommitteeId = mcommitteeId - , DB.epochStateNoConfidenceId = mnoConfidenceGaId - , DB.epochStateConstitutionId = Just constitutionId - , DB.epochStateEpochNo = unEpochNo epochNo - } + void + $ lift + $ DB.insertEpochState + DB.EpochState + { DB.epochStateCommitteeId = mcommitteeId + , DB.epochStateNoConfidenceId = mnoConfidenceGaId + , DB.epochStateConstitutionId = Just constitutionId + , DB.epochStateEpochNo = unEpochNo epochNo + } where govIds = govStatePrevGovActionIds enactedState @@ -469,14 +470,14 @@ insertUpdateEnacted trce cache blkId epochNo enactedState = do [] -> do -- This should never happen. Having a committee and an enacted action, means -- the committee came from a proposal which should be returned from the query. - liftIO $ - logWarning trce $ - mconcat - [ "The impossible happened! Couldn't find the committee " - , textShow committee - , " which was enacted by a proposal " - , textShow committeeGaId - ] + liftIO + $ logWarning trce + $ mconcat + [ "The impossible happened! Couldn't find the committee " + , textShow committee + , " which was enacted by a proposal " + , textShow committeeGaId + ] pure (Nothing, Nothing) (committeeId : _rest) -> pure (Just committeeId, Nothing) @@ -493,13 +494,13 @@ insertUpdateEnacted trce cache blkId epochNo enactedState = do -- On next epochs there will be at least one constitution, so the query will return something. [] -> lift $ insertConstitution blkId Nothing (cgsConstitution enactedState) constitutionId : rest -> do - unless (null rest) $ - liftIO $ - logWarning trce $ - mconcat - [ "Found multiple constitutions for proposal " - , textShow mConstitutionGaId - , ": " - , textShow constitutionIds - ] + unless (null rest) + $ liftIO + $ logWarning trce + $ mconcat + [ "Found multiple constitutions for proposal " + , textShow mConstitutionGaId + , ": " + , textShow constitutionIds + ] pure constitutionId diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Grouped.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Grouped.hs index dc6b61234..514dc0d52 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Grouped.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Grouped.hs @@ -114,15 +114,15 @@ insertBlockGroupedData syncEnv grouped = do makeMinId txInIds txOutIds maTxOutIds = case txOutTableType of DB.TxOutCore -> do - DB.CMinIdsWrapper $ - DB.MinIds + DB.CMinIdsWrapper + $ DB.MinIds { minTxInId = listToMaybe txInIds , minTxOutId = listToMaybe $ DB.convertTxOutIdCore txOutIds , minMaTxOutId = listToMaybe $ DB.convertMaTxOutIdCore maTxOutIds } DB.TxOutVariantAddress -> - DB.VMinIdsWrapper $ - DB.MinIds + DB.VMinIdsWrapper + $ DB.MinIds { minTxInId = listToMaybe txInIds , minTxOutId = listToMaybe $ DB.convertTxOutIdVariant txOutIds , minMaTxOutId = listToMaybe $ DB.convertMaTxOutIdVariant maTxOutIds @@ -135,8 +135,8 @@ mkmaTxOuts _txOutTableType (txOutId, mmtos) = mkmaTxOut <$> mmtos mkmaTxOut missingMaTx = case txOutId of DB.CTxOutIdW txOutId' -> - DB.CMaTxOutW $ - C.MaTxOut + DB.CMaTxOutW + $ C.MaTxOut { C.maTxOutIdent = mmtoIdent missingMaTx , C.maTxOutQuantity = mmtoQuantity missingMaTx , C.maTxOutTxOutId = txOutId' @@ -168,14 +168,18 @@ insertReverseIndex :: insertReverseIndex blockId minIdsWrapper = case minIdsWrapper of DB.CMinIdsWrapper minIds -> - void . lift . DB.insertReverseIndex $ - DB.ReverseIndex + void + . lift + . DB.insertReverseIndex + $ DB.ReverseIndex { DB.reverseIndexBlockId = blockId , DB.reverseIndexMinIds = minIdsCoreToText minIds } DB.VMinIdsWrapper minIds -> - void . lift . DB.insertReverseIndex $ - DB.ReverseIndex + void + . lift + . DB.insertReverseIndex + $ DB.ReverseIndex { DB.reverseIndexBlockId = blockId , DB.reverseIndexMinIds = minIdsVariantToText minIds } @@ -267,8 +271,10 @@ resolveInMemory txIn = matches :: Generic.TxIn -> ExtendedTxOut -> Bool matches txIn eutxo = - Generic.toTxHash txIn == etoTxHash eutxo - && Generic.txInIndex txIn == getTxOutIndex (etoTxOut eutxo) + Generic.toTxHash txIn + == etoTxHash eutxo + && Generic.txInIndex txIn + == getTxOutIndex (etoTxOut eutxo) where getTxOutIndex :: DB.TxOutW -> Word64 getTxOutIndex txOutWrapper = case txOutWrapper of diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/LedgerEvent.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/LedgerEvent.hs index c4938e8f6..346961610 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/LedgerEvent.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/LedgerEvent.hs @@ -68,8 +68,8 @@ insertNewEpochLedgerEvents syncEnv currentEpochNo@(EpochNo curEpoch) = handler ev = case ev of LedgerNewEpoch en ss -> do - lift $ - insertEpochSyncTime en (toSyncState ss) (envEpochSyncTime syncEnv) + lift + $ insertEpochSyncTime en (toSyncState ss) (envEpochSyncTime syncEnv) sqlBackend <- lift ask persistantCacheSize <- liftIO $ statementCacheSize $ connStmtMap sqlBackend liftIO . logInfo tracer $ "Persistant SQL Statement Cache size is " <> textShow persistantCacheSize @@ -95,10 +95,12 @@ insertNewEpochLedgerEvents syncEnv currentEpochNo@(EpochNo curEpoch) = LedgerAdaPots _ -> pure () -- These are handled separately by insertBlock LedgerGovInfo enacted dropped expired uncl -> do - unless (Set.null uncl) $ - liftIO $ - logInfo tracer $ - "Found " <> textShow (Set.size uncl) <> " unclaimed proposal refunds" + unless (Set.null uncl) + $ liftIO + $ logInfo tracer + $ "Found " + <> textShow (Set.size uncl) + <> " unclaimed proposal refunds" updateDropped cache (EpochNo curEpoch) (garGovActionId <$> (dropped <> expired)) let refunded = filter (\e -> Set.notMember (garGovActionId e) uncl) (enacted <> dropped <> expired) insertProposalRefunds tracer ntw (subFromCurrentEpoch 1) currentEpochNo cache refunded -- TODO: check if they are disjoint to avoid double entries. diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Other.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Other.hs index 4099e8427..910e014e9 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Other.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Other.hs @@ -116,14 +116,14 @@ insertDatum tracer cache txId txd = do Just datumId -> pure datumId Nothing -> do value <- safeDecodeToJson tracer "insertRedeemerData: Column 'value' in table 'redeemer' " $ Generic.txDataValue txd - lift $ - insertDatumAndCache cache (Generic.txDataHash txd) $ - DB.Datum - { DB.datumHash = Generic.dataHashToBytes $ Generic.txDataHash txd - , DB.datumTxId = txId - , DB.datumValue = value - , DB.datumBytes = Generic.txDataBytes txd - } + lift + $ insertDatumAndCache cache (Generic.txDataHash txd) + $ DB.Datum + { DB.datumHash = Generic.dataHashToBytes $ Generic.txDataHash txd + , DB.datumTxId = txId + , DB.datumValue = value + , DB.datumBytes = Generic.txDataBytes txd + } insertWithdrawals :: (MonadBaseControl IO m, MonadIO m) => @@ -136,8 +136,10 @@ insertWithdrawals :: insertWithdrawals tracer cache txId redeemers txWdrl = do addrId <- lift $ queryOrInsertRewardAccount tracer cache UpdateCache $ Generic.txwRewardAccount txWdrl - void . lift . DB.insertWithdrawal $ - DB.Withdrawal + void + . lift + . DB.insertWithdrawal + $ DB.Withdrawal { DB.withdrawalAddrId = addrId , DB.withdrawalTxId = txId , DB.withdrawalAmount = Generic.coinToDbLovelace $ Generic.txwAmount txWdrl @@ -174,8 +176,8 @@ insertMultiAsset cache policy aName = do case mId of Right maId -> pure maId Left (policyBs, assetNameBs) -> - DB.insertMultiAssetUnchecked $ - DB.MultiAsset + DB.insertMultiAssetUnchecked + $ DB.MultiAsset { DB.multiAssetPolicy = policyBs , DB.multiAssetName = assetNameBs , DB.multiAssetFingerprint = DB.unAssetFingerprint (DB.mkAssetFingerprint policyBs assetNameBs) @@ -193,8 +195,8 @@ insertScript tracer txId script = do Just scriptId -> pure scriptId Nothing -> do json <- scriptConvert script - DB.insertScript $ - DB.Script + DB.insertScript + $ DB.Script { DB.scriptTxId = txId , DB.scriptHash = Generic.txScriptHash script , DB.scriptType = Generic.txScriptType script diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Pool.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Pool.hs index 2631c8a6c..82235bac2 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Pool.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Pool.hs @@ -117,8 +117,10 @@ insertPoolRetire :: ExceptT SyncNodeError (ReaderT SqlBackend m) () insertPoolRetire trce txId cache epochNum idx keyHash = do poolId <- lift $ queryPoolKeyOrInsert "insertPoolRetire" trce cache UpdateCache True keyHash - void . lift . DB.insertPoolRetire $ - DB.PoolRetire + void + . lift + . DB.insertPoolRetire + $ DB.PoolRetire { DB.poolRetireHashId = poolId , DB.poolRetireCertIndex = idx , DB.poolRetireAnnouncedTxId = txId @@ -151,8 +153,10 @@ insertPoolOwner :: ExceptT SyncNodeError (ReaderT SqlBackend m) () insertPoolOwner trce cache network poolUpdateId skh = do saId <- lift $ queryOrInsertStakeAddress trce cache UpdateCacheStrong network (Ledger.KeyHashObj skh) - void . lift . DB.insertPoolOwner $ - DB.PoolOwner + void + . lift + . DB.insertPoolOwner + $ DB.PoolOwner { DB.poolOwnerAddrId = saId , DB.poolOwnerPoolUpdateId = poolUpdateId } diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Tx.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Tx.hs index 8674e1f02..eb66354db 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Tx.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Insert/Tx.hs @@ -162,8 +162,8 @@ insertTx syncEnv isMember blkId epochNo slotNo applyResult blockIndex tx grouped mapM_ (insertCollateralTxOut tracer cache iopts (txId, txHash)) (Generic.txCollateralOutputs tx) txMetadata <- - whenFalseMempty (ioMetadata iopts) $ - insertTxMetadata + whenFalseMempty (ioMetadata iopts) + $ insertTxMetadata tracer txId iopts @@ -171,25 +171,25 @@ insertTx syncEnv isMember blkId epochNo slotNo applyResult blockIndex tx grouped mapM_ (insertCertificate syncEnv isMember mDeposits blkId txId epochNo slotNo redeemers) $ Generic.txCertificates tx - when (ioShelley iopts) $ - mapM_ (insertWithdrawals tracer cache txId redeemers) $ - Generic.txWithdrawals tx - when (ioShelley iopts) $ - mapM_ (lift . insertParamProposal blkId txId) $ - Generic.txParamProposal tx + when (ioShelley iopts) + $ mapM_ (insertWithdrawals tracer cache txId redeemers) + $ Generic.txWithdrawals tx + when (ioShelley iopts) + $ mapM_ (lift . insertParamProposal blkId txId) + $ Generic.txParamProposal tx maTxMint <- - whenFalseMempty (ioMultiAssets iopts) $ - insertMaTxMint tracer cache txId $ - Generic.txMint tx + whenFalseMempty (ioMultiAssets iopts) + $ insertMaTxMint tracer cache txId + $ Generic.txMint tx - when (ioPlutusExtra iopts) $ - mapM_ (lift . insertScript tracer txId) $ - Generic.txScripts tx + when (ioPlutusExtra iopts) + $ mapM_ (lift . insertScript tracer txId) + $ Generic.txScripts tx - when (ioPlutusExtra iopts) $ - mapM_ (insertExtraKeyWitness tracer txId) $ - Generic.txExtraKeyWitnesses tx + when (ioPlutusExtra iopts) + $ mapM_ (insertExtraKeyWitness tracer txId) + $ Generic.txExtraKeyWitnesses tx when (ioGov iopts) $ do mapM_ (insertGovActionProposal tracer cache blkId txId (getGovExpiresAt applyResult epochNo) (apGovActionState applyResult)) $ zip [0 ..] (Generic.txProposalProcedure tx) @@ -217,31 +217,32 @@ insertTxOut :: insertTxOut tracer cache iopts (txId, txHash) (Generic.TxOut index addr value maMap mScript dt) = do mSaId <- lift $ insertStakeAddressRefIfMissing tracer cache addr mDatumId <- - whenFalseEmpty (ioPlutusExtra iopts) Nothing $ - Generic.whenInlineDatum dt $ - insertDatum tracer cache txId + whenFalseEmpty (ioPlutusExtra iopts) Nothing + $ Generic.whenInlineDatum dt + $ insertDatum tracer cache txId mScriptId <- - whenFalseEmpty (ioPlutusExtra iopts) Nothing $ - whenMaybe mScript $ - lift . insertScript tracer txId + whenFalseEmpty (ioPlutusExtra iopts) Nothing + $ whenMaybe mScript + $ lift + . insertScript tracer txId !txOut <- case ioTxOutTableType iopts of DB.TxOutCore -> - pure $ - DB.CTxOutW $ - C.TxOut - { C.txOutAddress = addrText - , C.txOutAddressHasScript = hasScript - , C.txOutConsumedByTxId = Nothing - , C.txOutDataHash = Generic.dataHashToBytes <$> Generic.getTxOutDatumHash dt - , C.txOutIndex = index - , C.txOutInlineDatumId = mDatumId - , C.txOutPaymentCred = Generic.maybePaymentCred addr - , C.txOutReferenceScriptId = mScriptId - , C.txOutStakeAddressId = mSaId - , C.txOutTxId = txId - , C.txOutValue = Generic.coinToDbLovelace value - } + pure + $ DB.CTxOutW + $ C.TxOut + { C.txOutAddress = addrText + , C.txOutAddressHasScript = hasScript + , C.txOutConsumedByTxId = Nothing + , C.txOutDataHash = Generic.dataHashToBytes <$> Generic.getTxOutDatumHash dt + , C.txOutIndex = index + , C.txOutInlineDatumId = mDatumId + , C.txOutPaymentCred = Generic.maybePaymentCred addr + , C.txOutReferenceScriptId = mScriptId + , C.txOutStakeAddressId = mSaId + , C.txOutTxId = txId + , C.txOutValue = Generic.coinToDbLovelace value + } DB.TxOutVariantAddress -> do let vAddress = V.Address @@ -252,8 +253,8 @@ insertTxOut tracer cache iopts (txId, txHash) (Generic.TxOut index addr value ma , V.addressStakeAddressId = mSaId } addrId <- lift $ insertAddress addr vAddress - pure $ - DB.VTxOutW + pure + $ DB.VTxOutW (mkTxOutVariant mSaId addrId mDatumId mScriptId) (Just vAddress) -- TODO: Unsure about what we should return here for eutxo @@ -331,14 +332,14 @@ insertTxMetadata tracer txId inOpts mmetadata = do let jsonbs = LBS.toStrict $ Aeson.encode (metadataValueToJsonNoSchema md) singleKeyCBORMetadata = serialiseTxMetadataToCbor $ Map.singleton key md mjson <- safeDecodeToJson tracer "prepareTxMetadata: Column 'json' in table 'metadata' " jsonbs - pure $ - Just $ - DB.TxMetadata - { DB.txMetadataKey = DbWord64 key - , DB.txMetadataJson = mjson - , DB.txMetadataBytes = singleKeyCBORMetadata - , DB.txMetadataTxId = txId - } + pure + $ Just + $ DB.TxMetadata + { DB.txMetadataKey = DbWord64 key + , DB.txMetadataJson = mjson + , DB.txMetadataBytes = singleKeyCBORMetadata + , DB.txMetadataTxId = txId + } -------------------------------------------------------------------------------------- -- INSERT MULTI ASSET @@ -367,8 +368,8 @@ insertMaTxMint _tracer cache txId (MultiAsset mintMap) = ReaderT SqlBackend m DB.MaTxMint prepareInner policy (aname, amount) = do maId <- insertMultiAsset cache policy aname - pure $ - DB.MaTxMint + pure + $ DB.MaTxMint { DB.maTxMintIdent = maId , DB.maTxMintQuantity = DB.integerToDbInt65 amount , DB.maTxMintTxId = txId @@ -397,8 +398,8 @@ insertMaTxOuts _tracer cache maMap = ReaderT SqlBackend m MissingMaTxOut prepareInner policy (aname, amount) = do maId <- insertMultiAsset cache policy aname - pure $ - MissingMaTxOut + pure + $ MissingMaTxOut { mmtoIdent = maId , mmtoQuantity = DbWord64 (fromIntegral amount) } @@ -417,13 +418,14 @@ insertCollateralTxOut :: insertCollateralTxOut tracer cache iopts (txId, _txHash) (Generic.TxOut index addr value maMap mScript dt) = do mSaId <- lift $ insertStakeAddressRefIfMissing tracer cache addr mDatumId <- - whenFalseEmpty (ioPlutusExtra iopts) Nothing $ - Generic.whenInlineDatum dt $ - insertDatum tracer cache txId + whenFalseEmpty (ioPlutusExtra iopts) Nothing + $ Generic.whenInlineDatum dt + $ insertDatum tracer cache txId mScriptId <- - whenFalseEmpty (ioPlutusExtra iopts) Nothing $ - whenMaybe mScript $ - lift . insertScript tracer txId + whenFalseEmpty (ioPlutusExtra iopts) Nothing + $ whenMaybe mScript + $ lift + . insertScript tracer txId _ <- case ioTxOutTableType iopts of DB.TxOutCore -> do diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Validate.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Validate.hs index d155df128..3d35ad40f 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Validate.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Universal/Validate.hs @@ -60,8 +60,9 @@ validateEpochRewards tracer network _earnedEpochNo spendableEpochNo rmap = do actualCount <- Db.queryNormalEpochRewardCount (unEpochNo spendableEpochNo) if actualCount /= expectedCount then do - liftIO . logWarning tracer $ - mconcat + liftIO + . logWarning tracer + $ mconcat [ "validateEpochRewards: rewards spendable in epoch " , textShow (unEpochNo spendableEpochNo) , " expected total of " @@ -71,8 +72,9 @@ validateEpochRewards tracer network _earnedEpochNo spendableEpochNo rmap = do ] logFullRewardMap tracer spendableEpochNo network (convertPoolRewards rmap) else do - liftIO . logInfo tracer $ - mconcat + liftIO + . logInfo tracer + $ mconcat [ "Validate Epoch Rewards: total rewards that become spendable in epoch " , textShow (unEpochNo spendableEpochNo) , " are " @@ -91,9 +93,9 @@ logFullRewardMap :: ReaderT SqlBackend m () logFullRewardMap tracer epochNo network ledgerMap = do dbMap <- queryRewardMap epochNo - when (Map.size dbMap > 0 && Map.size (Generic.unRewards ledgerMap) > 0) $ - liftIO $ - diffRewardMap tracer network dbMap (Map.mapKeys (Generic.stakingCredHash network) $ Map.map convert $ Generic.unRewards ledgerMap) + when (Map.size dbMap > 0 && Map.size (Generic.unRewards ledgerMap) > 0) + $ liftIO + $ diffRewardMap tracer network dbMap (Map.mapKeys (Generic.stakingCredHash network) $ Map.map convert $ Generic.unRewards ledgerMap) where convert :: Set Generic.Reward -> [(RewardSource, Coin)] convert = map (\rwd -> (Generic.rewardSource rwd, Generic.rewardAmount rwd)) . Set.toList @@ -107,10 +109,10 @@ queryRewardMap (EpochNo epochNo) = do (rwd :& saddr) <- from $ table @Db.Reward - `InnerJoin` table @Db.StakeAddress - `on` ( \(rwd :& saddr) -> - rwd ^. Db.RewardAddrId ==. saddr ^. Db.StakeAddressId - ) + `InnerJoin` table @Db.StakeAddress + `on` ( \(rwd :& saddr) -> + rwd ^. Db.RewardAddrId ==. saddr ^. Db.StakeAddressId + ) where_ (rwd ^. Db.RewardSpendableEpoch ==. val epochNo) where_ (not_ $ rwd ^. Db.RewardType ==. val Db.RwdDepositRefund) where_ (not_ $ rwd ^. Db.RewardType ==. val Db.RwdTreasury) diff --git a/cardano-db-sync/src/Cardano/DbSync/Era/Util.hs b/cardano-db-sync/src/Cardano/DbSync/Era/Util.hs index e9a4a5430..f8d1e0363 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Era/Util.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Era/Util.hs @@ -38,8 +38,9 @@ safeDecodeToJson tracer tracePrefix jsonBs = do ejson <- liftIO $ safeDecodeUtf8 jsonBs case ejson of Left err -> do - liftIO . logWarning tracer $ - mconcat + liftIO + . logWarning tracer + $ mconcat [tracePrefix, ": Could not decode to UTF8: ", textShow err] -- We have to insert pure Nothing diff --git a/cardano-db-sync/src/Cardano/DbSync/Error.hs b/cardano-db-sync/src/Cardano/DbSync/Error.hs index e01a3d3ba..0a817f061 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Error.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Error.hs @@ -151,10 +151,10 @@ annotateInvariantTx tx ei = EInvInOut inval outval -> EInvTxInOut tx inval outval _other -> ei -dbSyncNodeError :: (Monad m) => Text -> ExceptT SyncNodeError m a +dbSyncNodeError :: Monad m => Text -> ExceptT SyncNodeError m a dbSyncNodeError = left . SNErrDefault -dbSyncInvariant :: (Monad m) => Text -> SyncInvariant -> ExceptT SyncNodeError m a +dbSyncInvariant :: Monad m => Text -> SyncInvariant -> ExceptT SyncNodeError m a dbSyncInvariant loc = left . SNErrInvariant loc renderSyncInvariant :: SyncInvariant -> Text @@ -174,7 +174,7 @@ renderSyncInvariant ei = , textShow tx ] -fromEitherSTM :: (Exception e) => Either e a -> STM a +fromEitherSTM :: Exception e => Either e a -> STM a fromEitherSTM = either throwSTM return bsBase16Encode :: ByteString -> Text @@ -183,7 +183,7 @@ bsBase16Encode bs = Left _ -> Text.pack $ "UTF-8 decode failed for " ++ Show.show bs Right txt -> txt -runOrThrowIO :: forall e a m. (MonadIO m) => (Exception e) => m (Either e a) -> m a +runOrThrowIO :: forall e a m. MonadIO m => Exception e => m (Either e a) -> m a runOrThrowIO ioEither = do et <- ioEither case et of diff --git a/cardano-db-sync/src/Cardano/DbSync/Ledger/Event.hs b/cardano-db-sync/src/Cardano/DbSync/Ledger/Event.hs index 24c0e8617..387a7f72c 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Ledger/Event.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Ledger/Event.hs @@ -255,8 +255,8 @@ toLedgerEventConway evt hasRewards = (Conway.GovInfoEvent en droppedEnacted expired uncl) ) ) -> - Just $ - LedgerGovInfo + Just + $ LedgerGovInfo (toGovActionRefunded <$> toList en) (toGovActionRefunded <$> toList droppedEnacted) (toGovActionRefunded <$> toList expired) @@ -292,8 +292,8 @@ convertPoolDepositRefunds :: Map StakeCred (Map PoolKeyHash Coin) -> Generic.Rewards convertPoolDepositRefunds rwds = - Generic.Rewards $ - Map.map (Set.fromList . map convert . Map.toList) rwds + Generic.Rewards + $ Map.map (Set.fromList . map convert . Map.toList) rwds where convert :: (PoolKeyHash, Coin) -> Generic.Reward convert (kh, coin) = @@ -318,8 +318,8 @@ convertMirRewards resPay trePay = mkPayment :: RewardSource -> Coin -> Set Generic.RewardRest mkPayment src coin = - Set.singleton $ - Generic.RewardRest + Set.singleton + $ Generic.RewardRest { Generic.irSource = src , Generic.irAmount = coin } @@ -335,8 +335,8 @@ convertPoolRewards :: Map StakeCred (Set (Ledger.Reward StandardCrypto)) -> Generic.Rewards convertPoolRewards rmap = - Generic.Rewards $ - map (Set.map convertReward) rmap + Generic.Rewards + $ map (Set.map convertReward) rmap where convertReward :: Ledger.Reward StandardCrypto -> Generic.Reward convertReward sr = diff --git a/cardano-db-sync/src/Cardano/DbSync/Ledger/State.hs b/cardano-db-sync/src/Cardano/DbSync/Ledger/State.hs index c0875e511..3d7cc6b48 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Ledger/State.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Ledger/State.hs @@ -359,8 +359,8 @@ saveCurrentLedgerState env lState mEpochNo = do exists <- doesFileExist file if exists then - logInfo (leTrace env) $ - mconcat + logInfo (leTrace env) + $ mconcat ["File ", Text.pack file, " exists"] else atomically $ writeTBQueue (leStateWriteQueue env) (file, lState) @@ -385,18 +385,18 @@ ledgerStateWriteLoop tracer swQueue codecConfig = startTime <- getCurrentTime -- TODO: write the builder directly. -- BB.writeFile file $ toBuilder $ - LBS.writeFile file $ - Serialize.serialize $ - encodeCardanoLedgerState - ( Consensus.encodeExtLedgerState - (encodeDisk codecConfig) - (encodeDisk codecConfig) - (encodeDisk codecConfig) - ) - ledger + LBS.writeFile file + $ Serialize.serialize + $ encodeCardanoLedgerState + ( Consensus.encodeExtLedgerState + (encodeDisk codecConfig) + (encodeDisk codecConfig) + (encodeDisk codecConfig) + ) + ledger endTime <- getCurrentTime - logInfo tracer $ - mconcat + logInfo tracer + $ mconcat [ "Asynchronously wrote a ledger snapshot to " , Text.pack file , " in " @@ -406,15 +406,16 @@ ledgerStateWriteLoop tracer swQueue codecConfig = mkLedgerStateFilename :: LedgerStateDir -> ExtLedgerState CardanoBlock -> Maybe EpochNo -> WithOrigin FilePath mkLedgerStateFilename dir ledger mEpochNo = - lsfFilePath . dbPointToFileName dir mEpochNo + lsfFilePath + . dbPointToFileName dir mEpochNo <$> getPoint (ledgerTipPoint @CardanoBlock (ledgerState ledger)) saveCleanupState :: HasLedgerEnv -> CardanoLedgerState -> Maybe EpochNo -> IO () saveCleanupState env ledger mEpochNo = do let st = clsState ledger saveCurrentLedgerState env ledger mEpochNo - cleanupLedgerStateFiles env $ - fromWithOrigin (SlotNo 0) (ledgerTipSlot $ ledgerState st) + cleanupLedgerStateFiles env + $ fromWithOrigin (SlotNo 0) (ledgerTipSlot $ ledgerState st) hashToAnnotation :: ByteString -> ByteString hashToAnnotation = Base16.encode . BS.take 5 @@ -587,8 +588,8 @@ findStateFromPoint env point = do where deleteLedgerFile :: Text -> LedgerStateFile -> IO () deleteLedgerFile err lsf = do - logWarning (leTrace env) $ - mconcat + logWarning (leTrace env) + $ mconcat [ "Failed to parse ledger state file " , Text.pack (lsfFilePath lsf) , " with error '" @@ -599,8 +600,8 @@ findStateFromPoint env point = do logNewerFiles :: [LedgerStateFile] -> IO () logNewerFiles lsfs = - logWarning (leTrace env) $ - case lsfs of + logWarning (leTrace env) + $ case lsfs of [] -> "Rollback failed. No more ledger state files." (x : _) -> mconcat ["Needs to Rollback further to slot ", textShow (unSlotNo $ lsfSlotNo x)] @@ -655,8 +656,8 @@ loadLedgerStateFromFile tracer config delete point lsf = do Left err -> pure $ Left $ textShow err Right ls -> do endTime <- getCurrentTime - logInfo tracer $ - mconcat + logInfo tracer + $ mconcat [ "Found snapshot file for " , renderPoint point , ". It took " @@ -679,8 +680,8 @@ loadLedgerStateFromFile tracer config delete point lsf = do decodeState :: (forall s. Decoder s CardanoLedgerState) decodeState = - decodeCardanoLedgerState $ - Consensus.decodeExtLedgerState + decodeCardanoLedgerState + $ Consensus.decodeExtLedgerState (decodeDisk codecConfig) (decodeDisk codecConfig) (decodeDisk codecConfig) @@ -701,8 +702,8 @@ listMemorySnapshots env = do case mState of Strict.Nothing -> pure [] Strict.Just ledgerDB -> - pure $ - filter + pure + $ filter notGenesis (castPoint . getTip . clsState <$> getEdgePoints ledgerDB) where @@ -750,13 +751,13 @@ getRegisteredPoolShelley :: LedgerState (ShelleyBlock p era) -> Set.Set PoolKeyHash getRegisteredPoolShelley lState = - Map.keysSet $ - Shelley.psStakePoolParams $ - Shelley.certPState $ - Shelley.lsCertState $ - Shelley.esLState $ - Shelley.nesEs $ - Consensus.shelleyLedgerState lState + Map.keysSet + $ Shelley.psStakePoolParams + $ Shelley.certPState + $ Shelley.lsCertState + $ Shelley.esLState + $ Shelley.nesEs + $ Consensus.shelleyLedgerState lState ledgerEpochNo :: HasLedgerEnv -> ExtLedgerState CardanoBlock -> Either SyncNodeError (Maybe EpochNo) ledgerEpochNo env cls = @@ -781,19 +782,19 @@ tickThenReapplyCheckHash cfg block lsb = if blockPrevHash block == ledgerTipHash (ledgerState lsb) then Right $ tickThenReapplyLedgerResult cfg block lsb else - Left $ - SNErrLedgerState $ - mconcat - [ "Ledger state hash mismatch. Ledger head is slot " - , show (unSlotNo $ fromWithOrigin (SlotNo 0) (ledgerTipSlot $ ledgerState lsb)) - , " hash " - , Text.unpack $ renderByteArray (Cardano.unChainHash (ledgerTipHash $ ledgerState lsb)) - , " but block previous hash is " - , Text.unpack $ renderByteArray (Cardano.unChainHash $ blockPrevHash block) - , " and block current hash is " - , Text.unpack $ renderByteArray (SBS.fromShort . Consensus.getOneEraHash $ blockHash block) - , "." - ] + Left + $ SNErrLedgerState + $ mconcat + [ "Ledger state hash mismatch. Ledger head is slot " + , show (unSlotNo $ fromWithOrigin (SlotNo 0) (ledgerTipSlot $ ledgerState lsb)) + , " hash " + , Text.unpack $ renderByteArray (Cardano.unChainHash (ledgerTipHash $ ledgerState lsb)) + , " but block previous hash is " + , Text.unpack $ renderByteArray (Cardano.unChainHash $ blockPrevHash block) + , " and block current hash is " + , Text.unpack $ renderByteArray (SBS.fromShort . Consensus.getOneEraHash $ blockHash block) + , "." + ] getHeaderHash :: HeaderHash CardanoBlock -> ByteString getHeaderHash bh = SBS.fromShort (Consensus.getOneEraHash bh) @@ -829,28 +830,28 @@ getPrices st = case ledgerState $ clsState st of Strict.Just ( Shelley.nesEs (Consensus.shelleyLedgerState als) ^. Shelley.curPParamsEpochStateL - . Alonzo.ppPricesL + . Alonzo.ppPricesL ) LedgerStateBabbage bls -> Strict.Just ( Shelley.nesEs (Consensus.shelleyLedgerState bls) ^. Shelley.curPParamsEpochStateL - . Alonzo.ppPricesL + . Alonzo.ppPricesL ) LedgerStateConway bls -> Strict.Just ( Shelley.nesEs (Consensus.shelleyLedgerState bls) ^. Shelley.curPParamsEpochStateL - . Alonzo.ppPricesL + . Alonzo.ppPricesL ) _ -> Strict.Nothing getGovExpiration :: CardanoLedgerState -> Strict.Maybe Ledger.EpochInterval getGovExpiration st = case ledgerState $ clsState st of LedgerStateConway bls -> - Strict.Just $ - Shelley.nesEs (Consensus.shelleyLedgerState bls) - ^. (Shelley.curPParamsEpochStateL . Shelley.ppGovActionLifetimeL) + Strict.Just + $ Shelley.nesEs (Consensus.shelleyLedgerState bls) + ^. (Shelley.curPParamsEpochStateL . Shelley.ppGovActionLifetimeL) _ -> Strict.Nothing findAdaPots :: [LedgerEvent] -> Maybe AdaPots diff --git a/cardano-db-sync/src/Cardano/DbSync/Ledger/Types.hs b/cardano-db-sync/src/Cardano/DbSync/Ledger/Types.hs index 282c833ef..e5a36a81f 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Ledger/Types.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Ledger/Types.hs @@ -214,8 +214,14 @@ instance HasNewEpochState StandardShelley where _ -> Nothing applyNewEpochState st = - hApplyExtLedgerState $ - fn (applyNewEpochState' st) :* fn id :* fn id :* fn id :* fn id :* fn id :* Nil + hApplyExtLedgerState + $ fn (applyNewEpochState' st) + :* fn id + :* fn id + :* fn id + :* fn id + :* fn id + :* Nil instance HasNewEpochState StandardAllegra where getNewEpochState st = case ledgerState st of @@ -223,8 +229,14 @@ instance HasNewEpochState StandardAllegra where _ -> Nothing applyNewEpochState st = - hApplyExtLedgerState $ - fn id :* fn (applyNewEpochState' st) :* fn id :* fn id :* fn id :* fn id :* Nil + hApplyExtLedgerState + $ fn id + :* fn (applyNewEpochState' st) + :* fn id + :* fn id + :* fn id + :* fn id + :* Nil instance HasNewEpochState StandardMary where getNewEpochState st = case ledgerState st of @@ -232,8 +244,14 @@ instance HasNewEpochState StandardMary where _ -> Nothing applyNewEpochState st = - hApplyExtLedgerState $ - fn id :* fn id :* fn (applyNewEpochState' st) :* fn id :* fn id :* fn id :* Nil + hApplyExtLedgerState + $ fn id + :* fn id + :* fn (applyNewEpochState' st) + :* fn id + :* fn id + :* fn id + :* Nil instance HasNewEpochState StandardAlonzo where getNewEpochState st = case ledgerState st of @@ -241,8 +259,14 @@ instance HasNewEpochState StandardAlonzo where _ -> Nothing applyNewEpochState st = - hApplyExtLedgerState $ - fn id :* fn id :* fn id :* fn (applyNewEpochState' st) :* fn id :* fn id :* Nil + hApplyExtLedgerState + $ fn id + :* fn id + :* fn id + :* fn (applyNewEpochState' st) + :* fn id + :* fn id + :* Nil instance HasNewEpochState StandardBabbage where getNewEpochState st = case ledgerState st of @@ -250,8 +274,14 @@ instance HasNewEpochState StandardBabbage where _ -> Nothing applyNewEpochState st = - hApplyExtLedgerState $ - fn id :* fn id :* fn id :* fn id :* fn (applyNewEpochState' st) :* fn id :* Nil + hApplyExtLedgerState + $ fn id + :* fn id + :* fn id + :* fn id + :* fn (applyNewEpochState' st) + :* fn id + :* Nil instance HasNewEpochState StandardConway where getNewEpochState st = case ledgerState st of @@ -259,8 +289,14 @@ instance HasNewEpochState StandardConway where _ -> Nothing applyNewEpochState st = - hApplyExtLedgerState $ - fn id :* fn id :* fn id :* fn id :* fn id :* fn (applyNewEpochState' st) :* Nil + hApplyExtLedgerState + $ fn id + :* fn id + :* fn id + :* fn id + :* fn id + :* fn (applyNewEpochState' st) + :* Nil hApplyExtLedgerState :: NP (LedgerState -.-> LedgerState) (CardanoShelleyEras StandardCrypto) -> diff --git a/cardano-db-sync/src/Cardano/DbSync/Metrics.hs b/cardano-db-sync/src/Cardano/DbSync/Metrics.hs index 55815042e..d31fb13b5 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Metrics.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Metrics.hs @@ -41,8 +41,8 @@ data Metrics = Metrics withMetricSetters :: Int -> (MetricSetters -> IO a) -> IO a withMetricSetters prometheusPort action = withMetricsServer prometheusPort $ \metrics -> do - action $ - MetricSetters + action + $ MetricSetters { metricsSetNodeBlockHeight = \(BlockNo nodeHeight) -> Gauge.set (fromIntegral nodeHeight) $ mNodeBlockHeight metrics , metricsSetDbQueueLength = \queuePostWrite -> diff --git a/cardano-db-sync/src/Cardano/DbSync/OffChain.hs b/cardano-db-sync/src/Cardano/DbSync/OffChain.hs index b89201791..acfa944c2 100644 --- a/cardano-db-sync/src/Cardano/DbSync/OffChain.hs +++ b/cardano-db-sync/src/Cardano/DbSync/OffChain.hs @@ -111,8 +111,9 @@ insertOffChainPoolResults trce resultQueue = do unless (null res) $ do let resLength = length res resErrorsLength = length $ filter isFetchError res - liftIO . logInfo trce $ - logInsertOffChainResults "Pool" resLength resErrorsLength + liftIO + . logInfo trce + $ logInsertOffChainResults "Pool" resLength resErrorsLength mapM_ insert res where insert :: (MonadBaseControl IO m, MonadIO m) => OffChainPoolResult -> ReaderT SqlBackend m () @@ -135,8 +136,9 @@ insertOffChainVoteResults trce resultQueue = do unless (null res) $ do let resLength = length res resErrorsLength = length $ filter isFetchError res - liftIO . logInfo trce $ - logInsertOffChainResults "Voting Anchor" resLength resErrorsLength + liftIO + . logInfo trce + $ logInsertOffChainResults "Voting Anchor" resLength resErrorsLength mapM_ insert res where insert :: (MonadBaseControl IO m, MonadIO m) => OffChainVoteResult -> ReaderT SqlBackend m () @@ -182,17 +184,18 @@ runFetchOffChainPoolThread syncEnv = do -- if dissable gov is active then don't run voting anchor thread when (ioOffChainPoolData iopts) $ do logInfo trce "Running Offchain Pool fetch thread" - runIohkLogging trce $ - withPostgresqlConn (envConnectionString syncEnv) $ - \backendPool -> liftIO $ - forever $ do - tDelay - -- load the offChain vote work queue using the db - _ <- runReaderT (loadOffChainPoolWorkQueue trce (envOffChainPoolWorkQueue syncEnv)) backendPool - poolq <- atomically $ flushTBQueue (envOffChainPoolWorkQueue syncEnv) - manager <- Http.newManager tlsManagerSettings - now <- liftIO Time.getPOSIXTime - mapM_ (queuePoolInsert <=< fetchOffChainPoolData trce manager now) poolq + runIohkLogging trce + $ withPostgresqlConn (envConnectionString syncEnv) + $ \backendPool -> liftIO + $ forever + $ do + tDelay + -- load the offChain vote work queue using the db + _ <- runReaderT (loadOffChainPoolWorkQueue trce (envOffChainPoolWorkQueue syncEnv)) backendPool + poolq <- atomically $ flushTBQueue (envOffChainPoolWorkQueue syncEnv) + manager <- Http.newManager tlsManagerSettings + now <- liftIO Time.getPOSIXTime + mapM_ (queuePoolInsert <=< fetchOffChainPoolData trce manager now) poolq where trce = getTrace syncEnv iopts = getInsertOptions syncEnv @@ -205,16 +208,17 @@ runFetchOffChainVoteThread syncEnv = do -- if dissable gov is active then don't run voting anchor thread when (ioGov iopts) $ do logInfo trce "Running Offchain Vote Anchor fetch thread" - runIohkLogging trce $ - withPostgresqlConn (envConnectionString syncEnv) $ - \backendVote -> liftIO $ - forever $ do - tDelay - -- load the offChain vote work queue using the db - _ <- runReaderT (loadOffChainVoteWorkQueue trce (envOffChainVoteWorkQueue syncEnv)) backendVote - voteq <- atomically $ flushTBQueue (envOffChainVoteWorkQueue syncEnv) - now <- liftIO Time.getPOSIXTime - mapM_ (queueVoteInsert <=< fetchOffChainVoteData gateways now) voteq + runIohkLogging trce + $ withPostgresqlConn (envConnectionString syncEnv) + $ \backendVote -> liftIO + $ forever + $ do + tDelay + -- load the offChain vote work queue using the db + _ <- runReaderT (loadOffChainVoteWorkQueue trce (envOffChainVoteWorkQueue syncEnv)) backendVote + voteq <- atomically $ flushTBQueue (envOffChainVoteWorkQueue syncEnv) + now <- liftIO Time.getPOSIXTime + mapM_ (queueVoteInsert <=< fetchOffChainVoteData gateways now) voteq where trce = getTrace syncEnv iopts = getInsertOptions syncEnv @@ -242,8 +246,8 @@ fetchOffChainPoolData _tracer manager time oPoolWorkQ = convert eres = case eres of Right sPoolData -> - OffChainPoolResultMetadata $ - DB.OffChainPoolData + OffChainPoolResultMetadata + $ DB.OffChainPoolData { DB.offChainPoolDataPoolId = oPoolWqHashId oPoolWorkQ , DB.offChainPoolDataTickerName = spodTickerName sPoolData , DB.offChainPoolDataHash = spodHash sPoolData @@ -252,8 +256,8 @@ fetchOffChainPoolData _tracer manager time oPoolWorkQ = , DB.offChainPoolDataPmrId = oPoolWqReferenceId oPoolWorkQ } Left err -> - OffChainPoolResultError $ - DB.OffChainPoolFetchError + OffChainPoolResultError + $ DB.OffChainPoolFetchError { DB.offChainPoolFetchErrorPoolId = oPoolWqHashId oPoolWorkQ , DB.offChainPoolFetchErrorFetchTime = Time.posixSecondsToUTCTime time , DB.offChainPoolFetchErrorPmrId = oPoolWqReferenceId oPoolWorkQ @@ -294,8 +298,8 @@ fetchOffChainVoteData gateways time oVoteWorkQ = in OffChainVoteResultMetadata vdt (OffChainVoteAccessors gaF drepF authorsF referencesF externalUpdatesF) Left err -> - OffChainVoteResultError $ - DB.OffChainVoteFetchError + OffChainVoteResultError + $ DB.OffChainVoteFetchError { DB.offChainVoteFetchErrorVotingAnchorId = oVoteWqReferenceId oVoteWorkQ , DB.offChainVoteFetchErrorFetchError = show err , DB.offChainVoteFetchErrorFetchTime = Time.posixSecondsToUTCTime time @@ -303,8 +307,8 @@ fetchOffChainVoteData gateways time oVoteWorkQ = } mkGovAction ocvdId = \case Vote.OffChainVoteDataGa dt -> - Just $ - DB.OffChainVoteGovActionData + Just + $ DB.OffChainVoteGovActionData { DB.offChainVoteGovActionDataOffChainVoteDataId = ocvdId , DB.offChainVoteGovActionDataTitle = Vote.textValue $ Vote.title $ Vote.body dt , DB.offChainVoteGovActionDataAbstract = Vote.textValue $ Vote.abstract $ Vote.body dt @@ -315,8 +319,8 @@ fetchOffChainVoteData gateways time oVoteWorkQ = mkDrep ocvdId = \case Vote.OffChainVoteDataDr dt -> - Just $ - DB.OffChainVoteDrepData + Just + $ DB.OffChainVoteDrepData { DB.offChainVoteDrepDataOffChainVoteDataId = ocvdId , DB.offChainVoteDrepDataPaymentAddress = Vote.textValue <$> Vote.paymentAddress (Vote.body dt) , DB.offChainVoteDrepDataGivenName = Vote.textValue $ Vote.givenName $ Vote.body dt diff --git a/cardano-db-sync/src/Cardano/DbSync/OffChain/Http.hs b/cardano-db-sync/src/Cardano/DbSync/OffChain/Http.hs index 9ee91355d..b26c815bb 100644 --- a/cardano-db-sync/src/Cardano/DbSync/OffChain/Http.hs +++ b/cardano-db-sync/src/Cardano/DbSync/OffChain/Http.hs @@ -63,8 +63,8 @@ httpGetOffChainPoolData manager request purl expectedMetaHash = do case Aeson.eitherDecode' respLBS of Left err -> left $ OCFErrJsonDecodeFail (Just url) (Text.pack err) Right res -> pure res - pure $ - SimplifiedOffChainPoolData + pure + $ SimplifiedOffChainPoolData { spodTickerName = unPoolTicker $ pomTicker decodedMetadata , spodHash = metadataHash , spodBytes = respBS @@ -109,8 +109,8 @@ httpGetOffChainVoteDataSingle vurl metaHash anchorType = do httpRes <- handleExceptT (convertHttpException url) req (respBS, respLBS, mContentType) <- hoistEither httpRes (ocvd, decodedValue, metadataHash, mWarning) <- parseAndValidateVoteData respBS respLBS metaHash anchorType (Just $ OffChainVoteUrl vurl) - pure $ - SimplifiedOffChainVoteData + pure + $ SimplifiedOffChainVoteData { sovaHash = metadataHash , sovaBytes = respBS , sovaJson = Text.decodeUtf8 $ LBS.toStrict (Aeson.encode decodedValue) @@ -167,9 +167,9 @@ httpGetBytes manager request bytesToRead maxBytes url = if "text/html" `BS.isInfixOf` ct && isPossiblyJsonObject respBS then pure () else do - when ("text/html" `BS.isInfixOf` ct) $ - left $ - OCFErrBadContentTypeHtml url (Text.decodeLatin1 ct) + when ("text/html" `BS.isInfixOf` ct) + $ left + $ OCFErrBadContentTypeHtml url (Text.decodeLatin1 ct) unless ( "application/json" `BS.isInfixOf` ct diff --git a/cardano-db-sync/src/Cardano/DbSync/OffChain/Query.hs b/cardano-db-sync/src/Cardano/DbSync/OffChain/Query.hs index 823cb5212..1f451cbb4 100644 --- a/cardano-db-sync/src/Cardano/DbSync/OffChain/Query.hs +++ b/cardano-db-sync/src/Cardano/DbSync/OffChain/Query.hs @@ -81,14 +81,16 @@ queryNewVoteWorkQueue now maxCount = do res <- select $ do va <- from $ table @VotingAnchor where_ - ( notExists $ - from (table @OffChainVoteData) >>= \ocvd -> + ( notExists + $ from (table @OffChainVoteData) + >>= \ocvd -> where_ (ocvd ^. OffChainVoteDataVotingAnchorId ==. va ^. VotingAnchorId) ) where_ (va ^. VotingAnchorType !=. val ConstitutionAnchor) where_ - ( notExists $ - from (table @OffChainVoteFetchError) >>= \ocvfe -> + ( notExists + $ from (table @OffChainVoteFetchError) + >>= \ocvfe -> where_ (ocvfe ^. OffChainVoteFetchErrorVotingAnchorId ==. va ^. VotingAnchorId) ) limit $ fromIntegral maxCount @@ -116,8 +118,8 @@ queryOffChainVoteWorkQueue _now maxCount = do (va :& ocpfe) <- from $ table @VotingAnchor - `innerJoin` table @OffChainVoteFetchError - `on` (\(va :& ocpfe) -> ocpfe ^. OffChainVoteFetchErrorVotingAnchorId ==. va ^. VotingAnchorId) + `innerJoin` table @OffChainVoteFetchError + `on` (\(va :& ocpfe) -> ocpfe ^. OffChainVoteFetchErrorVotingAnchorId ==. va ^. VotingAnchorId) orderBy [asc (ocpfe ^. OffChainVoteFetchErrorId)] where_ (just (ocpfe ^. OffChainVoteFetchErrorId) `in_` latestRefs) where_ (va ^. VotingAnchorType !=. val ConstitutionAnchor) @@ -148,8 +150,9 @@ queryOffChainVoteWorkQueue _now maxCount = do ocvfe <- from (table @OffChainVoteFetchError) groupBy (ocvfe ^. OffChainVoteFetchErrorVotingAnchorId) where_ - ( notExists $ - from (table @OffChainVoteData) >>= \ocvd -> + ( notExists + $ from (table @OffChainVoteData) + >>= \ocvd -> where_ (ocvd ^. OffChainVoteDataVotingAnchorId ==. ocvfe ^. OffChainVoteFetchErrorVotingAnchorId) ) pure $ max_ (ocvfe ^. OffChainVoteFetchErrorId) @@ -175,17 +178,19 @@ queryNewPoolWorkQueue now maxCount = do (ph :& pmr) <- from $ table @PoolHash - `innerJoin` table @PoolMetadataRef - `on` (\(ph :& pmr) -> ph ^. PoolHashId ==. pmr ^. PoolMetadataRefPoolId) + `innerJoin` table @PoolMetadataRef + `on` (\(ph :& pmr) -> ph ^. PoolHashId ==. pmr ^. PoolMetadataRefPoolId) where_ (just (pmr ^. PoolMetadataRefId) `in_` latestRefs) where_ - ( notExists $ - from (table @OffChainPoolData) >>= \pod -> + ( notExists + $ from (table @OffChainPoolData) + >>= \pod -> where_ (pod ^. OffChainPoolDataPmrId ==. pmr ^. PoolMetadataRefId) ) where_ - ( notExists $ - from (table @OffChainPoolFetchError) >>= \pofe -> + ( notExists + $ from (table @OffChainPoolFetchError) + >>= \pofe -> where_ (pofe ^. OffChainPoolFetchErrorPmrId ==. pmr ^. PoolMetadataRefId) ) limit $ fromIntegral maxCount @@ -226,10 +231,10 @@ queryOffChainPoolWorkQueue _now maxCount = do (ph :& pmr :& pofe) <- from $ table @PoolHash - `innerJoin` table @PoolMetadataRef - `on` (\(ph :& pmr) -> ph ^. PoolHashId ==. pmr ^. PoolMetadataRefPoolId) - `innerJoin` table @OffChainPoolFetchError - `on` (\(_ph :& pmr :& pofe) -> pofe ^. OffChainPoolFetchErrorPmrId ==. pmr ^. PoolMetadataRefId) + `innerJoin` table @PoolMetadataRef + `on` (\(ph :& pmr) -> ph ^. PoolHashId ==. pmr ^. PoolMetadataRefPoolId) + `innerJoin` table @OffChainPoolFetchError + `on` (\(_ph :& pmr :& pofe) -> pofe ^. OffChainPoolFetchErrorPmrId ==. pmr ^. PoolMetadataRefId) where_ (just (pofe ^. OffChainPoolFetchErrorId) `in_` latestRefs) orderBy [asc (pofe ^. OffChainPoolFetchErrorId)] limit $ fromIntegral maxCount diff --git a/cardano-db-sync/src/Cardano/DbSync/OffChain/Types.hs b/cardano-db-sync/src/Cardano/DbSync/OffChain/Types.hs index 718408f59..56faf62bf 100644 --- a/cardano-db-sync/src/Cardano/DbSync/OffChain/Types.hs +++ b/cardano-db-sync/src/Cardano/DbSync/OffChain/Types.hs @@ -87,8 +87,8 @@ parseName obj = do if length name <= 50 then pure $ PoolName name else - fail $ - mconcat + fail + $ mconcat [ "\"name\" must have at most 50 characters, but it has " , show (length name) , " characters." @@ -105,8 +105,8 @@ parseDescription obj = do if length description <= 255 then pure $ PoolDescription description else - fail $ - mconcat + fail + $ mconcat [ "\"description\" must have at most 255 characters, but it has " , show (length description) , " characters." @@ -123,8 +123,8 @@ parseTicker obj = do if tickerLen >= 3 && tickerLen <= 5 then pure $ PoolTicker ticker else - fail $ - mconcat + fail + $ mconcat [ "\"ticker\" must have at least 3 and at most 5 " , "characters, but it has " , show (length ticker) diff --git a/cardano-db-sync/src/Cardano/DbSync/OffChain/Vote/Types.hs b/cardano-db-sync/src/Cardano/DbSync/OffChain/Vote/Types.hs index f98544bfa..5fbd453ec 100644 --- a/cardano-db-sync/src/Cardano/DbSync/OffChain/Vote/Types.hs +++ b/cardano-db-sync/src/Cardano/DbSync/OffChain/Vote/Types.hs @@ -110,7 +110,7 @@ newtype TextValue = TextValue {textValue :: Text} instance Show TextValue where show = show . textValue -deriving instance (Show (Body tp)) => Show (OffChainVoteDataTp tp) +deriving instance Show (Body tp) => Show (OffChainVoteDataTp tp) deriving instance Generic (OffChainVoteDataTp tp) data Author = Author diff --git a/cardano-db-sync/src/Cardano/DbSync/Rollback.hs b/cardano-db-sync/src/Cardano/DbSync/Rollback.hs index 9124bae6d..11db7592f 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Rollback.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Rollback.hs @@ -91,8 +91,8 @@ prepareRollback syncEnv point serverTip = At blk -> do nBlocks <- lift $ DB.queryCountSlotNosGreaterThan (unSlotNo $ blockPointSlot blk) mBlockNo <- - liftLookupFail "Rollback.prepareRollback" $ - DB.queryBlockHashBlockNo (SBS.fromShort . getOneEraHash $ blockPointHash blk) + liftLookupFail "Rollback.prepareRollback" + $ DB.queryBlockHashBlockNo (SBS.fromShort . getOneEraHash $ blockPointHash blk) liftIO . logInfo trce $ mconcat diff --git a/cardano-db-sync/src/Cardano/DbSync/StateQuery.hs b/cardano-db-sync/src/Cardano/DbSync/StateQuery.hs index 370764cf8..01064fa54 100644 --- a/cardano-db-sync/src/Cardano/DbSync/StateQuery.hs +++ b/cardano-db-sync/src/Cardano/DbSync/StateQuery.hs @@ -33,16 +33,17 @@ import Ouroboros.Consensus.HardFork.History.Qry ( -- https://github.com/IntersectMBO/cardano-db-sync/issues/276 querySlotDetails :: SystemStart -> SlotNo -> Qry SlotDetails querySlotDetails start absSlot = do - absTime <- qryFromExpr $ - ELet (EAbsToRelSlot (ELit absSlot)) $ \relSlot -> + absTime <- qryFromExpr + $ ELet (EAbsToRelSlot (ELit absSlot)) + $ \relSlot -> ELet (ERelSlotToTime (EVar relSlot)) $ \relTime -> ELet (ERelToAbsTime (EVar relTime)) $ \absTime -> EVar absTime (absEpoch, slotInEpoch) <- slotToEpoch' absSlot epochSize <- qryFromExpr $ EEpochSize (ELit absEpoch) let time = relToUTCTime start absTime - pure $ - SlotDetails + pure + $ SlotDetails { sdSlotTime = time , sdCurrentTime = time -- Corrected above in insertCurrentTime , sdEpochNo = absEpoch diff --git a/cardano-db-sync/src/Cardano/DbSync/Sync.hs b/cardano-db-sync/src/Cardano/DbSync/Sync.hs index 656f81b4e..3779f6eed 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Sync.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Sync.hs @@ -130,8 +130,8 @@ runSyncNodeClient :: IO () runSyncNodeClient metricsSetters syncEnv iomgr trce tc (SocketPath socketPath) = do logInfo trce $ "Connecting to node via " <> textShow socketPath - void $ - subscribe + void + $ subscribe (localSnocket iomgr) (envNetworkMagic syncEnv) (supportedNodeToClientVersions (Proxy @CardanoBlock)) @@ -192,10 +192,10 @@ dbSyncProtocols syncEnv metricsSetters tc codecConfig version bversion = , localTxSubmissionProtocol = dummylocalTxSubmit , localStateQueryProtocol = localStateQuery , localTxMonitorProtocol = - InitiatorProtocolOnly $ - mkMiniProtocolCbFromPeer $ - const - (Logging.nullTracer, cTxMonitorCodec codecs, localTxMonitorPeerNull) + InitiatorProtocolOnly + $ mkMiniProtocolCbFromPeer + $ const + (Logging.nullTracer, cTxMonitorCodec codecs, localTxMonitorPeerNull) } where codecs = clientCodecs codecConfig bversion version @@ -217,18 +217,18 @@ dbSyncProtocols syncEnv metricsSetters tc codecConfig version bversion = logInfo tracer "Found no wrong consumed_by_tx_id entries" oldActionFixes channel Just wrongEntriesSize -> do - logInfo tracer $ - mconcat ["Found ", textShow wrongEntriesSize, " consumed_by_tx_id wrong entries"] + logInfo tracer + $ mconcat ["Found ", textShow wrongEntriesSize, " consumed_by_tx_id wrong entries"] fixedEntries <- runPeer localChainSyncTracer (cChainSyncCodec codecs) channel - ( Client.chainSyncClientPeer $ - chainSyncClientFixConsumed backend syncEnv wrongEntriesSize + ( Client.chainSyncClientPeer + $ chainSyncClientFixConsumed backend syncEnv wrongEntriesSize ) - logInfo tracer $ - mconcat ["Fixed ", textShow fixedEntries, " consumed_by_tx_id wrong entries"] + logInfo tracer + $ mconcat ["Fixed ", textShow fixedEntries, " consumed_by_tx_id wrong entries"] pure False oldActionFixes channel = do @@ -238,15 +238,15 @@ dbSyncProtocols syncEnv metricsSetters tc codecConfig version bversion = if noneFixed fr && (onlyFix || not skipFix) then do fd <- runDbIohkLogging backend tracer $ getWrongPlutusData tracer - unless (nullData fd) $ - void $ - runPeer - localChainSyncTracer - (cChainSyncCodec codecs) - channel - ( Client.chainSyncClientPeer $ - chainSyncClientFixData backend tracer fd - ) + unless (nullData fd) + $ void + $ runPeer + localChainSyncTracer + (cChainSyncCodec codecs) + channel + ( Client.chainSyncClientPeer + $ chainSyncClientFixData backend tracer fd + ) if onlyFix then do setIsFixed syncEnv DataFixRan @@ -256,15 +256,15 @@ dbSyncProtocols syncEnv metricsSetters tc codecConfig version bversion = if isDataFixed fr && (onlyFix || not skipFix) then do ls <- runDbIohkLogging backend tracer $ getWrongPlutusScripts tracer - unless (nullPlutusScripts ls) $ - void $ - runPeer - localChainSyncTracer - (cChainSyncCodec codecs) - channel - ( Client.chainSyncClientPeer $ - chainSyncClientFixScripts backend tracer ls - ) + unless (nullPlutusScripts ls) + $ void + $ runPeer + localChainSyncTracer + (cChainSyncCodec codecs) + channel + ( Client.chainSyncClientPeer + $ chainSyncClientFixScripts backend tracer ls + ) when onlyFix $ panic "All Good! This error is only thrown to exit db-sync" setIsFixed syncEnv AllFixRan pure False @@ -273,8 +273,9 @@ dbSyncProtocols syncEnv metricsSetters tc codecConfig version bversion = pure True localChainSyncPtcl :: RunMiniProtocolWithMinimalCtx 'InitiatorMode LocalAddress BSL.ByteString IO () Void - localChainSyncPtcl = InitiatorProtocolOnly $ - MiniProtocolCb $ \_ctx channel -> + localChainSyncPtcl = InitiatorProtocolOnly + $ MiniProtocolCb + $ \_ctx channel -> liftIO . logException tracer "ChainSyncWithBlocksPtcl: " $ do isInitComplete <- runAndSetDone tc $ initAction channel when isInitComplete $ do @@ -283,20 +284,20 @@ dbSyncProtocols syncEnv metricsSetters tc codecConfig version bversion = (latestPoints, currentTip) <- waitRestartState tc let (inMemory, onDisk) = List.span snd latestPoints - logInfo tracer $ - mconcat + logInfo tracer + $ mconcat [ "Suggesting intersection points from memory: " , textShow (fst <$> inMemory) , " and from disk: " , textShow (fst <$> onDisk) ] - void $ - runPipelinedPeer + void + $ runPipelinedPeer localChainSyncTracer (cChainSyncCodec codecs) channel - ( chainSyncClientPeerPipelined $ - chainSyncClient metricsSetters tracer (fst <$> latestPoints) currentTip tc + ( chainSyncClientPeerPipelined + $ chainSyncClient metricsSetters tracer (fst <$> latestPoints) currentTip tc ) atomically $ writeDbActionQueue tc DbFinish -- We should return leftover bytes returned by 'runPipelinedPeer', but @@ -307,33 +308,33 @@ dbSyncProtocols syncEnv metricsSetters tc codecConfig version bversion = dummylocalTxSubmit :: RunMiniProtocolWithMinimalCtx 'InitiatorMode LocalAddress BSL.ByteString IO () Void dummylocalTxSubmit = - InitiatorProtocolOnly $ - mkMiniProtocolCbFromPeer $ - const - ( Logging.nullTracer - , cTxSubmissionCodec codecs - , localTxSubmissionPeerNull - ) + InitiatorProtocolOnly + $ mkMiniProtocolCbFromPeer + $ const + ( Logging.nullTracer + , cTxSubmissionCodec codecs + , localTxSubmissionPeerNull + ) localStateQuery :: RunMiniProtocolWithMinimalCtx 'InitiatorMode LocalAddress BSL.ByteString IO () Void localStateQuery = case envLedgerEnv syncEnv of HasLedger _ -> - InitiatorProtocolOnly $ - mkMiniProtocolCbFromPeer $ - const - ( Logging.nullTracer - , cStateQueryCodec codecs - , localStateQueryPeerNull - ) + InitiatorProtocolOnly + $ mkMiniProtocolCbFromPeer + $ const + ( Logging.nullTracer + , cStateQueryCodec codecs + , localStateQueryPeerNull + ) NoLedger nle -> - InitiatorProtocolOnly $ - mkMiniProtocolCbFromPeer $ - const - ( contramap (Text.pack . show) . toLogObject $ appendName "local-state-query" tracer - , cStateQueryCodec codecs - , localStateQueryClientPeer $ localStateQueryHandler nle - ) + InitiatorProtocolOnly + $ mkMiniProtocolCbFromPeer + $ const + ( contramap (Text.pack . show) . toLogObject $ appendName "local-state-query" tracer + , cStateQueryCodec codecs + , localStateQueryClientPeer $ localStateQueryHandler nle + ) -- | 'ChainSyncClient' which traces received blocks and ignores when it -- receives a request to rollbackwar. A real wallet client should: @@ -456,8 +457,8 @@ drainThePipe n0 client = go n0 case n of Zero -> client Succ n' -> - CollectResponse Nothing $ - ClientStNext + CollectResponse Nothing + $ ClientStNext { recvMsgRollForward = \_hdr _tip -> pure $ go n' , recvMsgRollBackward = \_pt _tip -> pure $ go n' } @@ -472,9 +473,9 @@ chainSyncClientFixConsumed backend syncEnv wrongTotalSize = Client.ChainSyncClie clientStIntersect = Client.ClientStIntersect { Client.recvMsgIntersectFound = \_blk _tip -> - Client.ChainSyncClient $ - pure $ - Client.SendMsgRequestNext (pure ()) (clientStNext (0, (0, []))) + Client.ChainSyncClient + $ pure + $ Client.SendMsgRequestNext (pure ()) (clientStNext (0, (0, []))) , Client.recvMsgIntersectNotFound = \_tip -> panic "Failed to find intersection with genesis." } @@ -496,9 +497,9 @@ chainSyncClientFixConsumed backend syncEnv wrongTotalSize = Client.ChainSyncClie logSize sizeFixedTotal sizeNewFixedTotal pure $ Client.SendMsgRequestNext (pure ()) (clientStNext (sizeNewFixedTotal, (sizeUnfixed, unfixedEntries))) , Client.recvMsgRollBackward = \_point _tip -> - Client.ChainSyncClient $ - pure $ - Client.SendMsgRequestNext (pure ()) (clientStNext (sizeFixedTotal, (sizeFixEntries, fixEntries))) + Client.ChainSyncClient + $ pure + $ Client.SendMsgRequestNext (pure ()) (clientStNext (sizeFixedTotal, (sizeFixEntries, fixEntries))) } fixAccumulatedEntries = fixEntriesConsumed backend tracer . concat . reverse @@ -510,9 +511,9 @@ chainSyncClientFixConsumed backend syncEnv wrongTotalSize = Client.ChainSyncClie logSize :: Integer -> Integer -> IO () logSize lastSize newSize = do - when (newSize `div` 200_000 > lastSize `div` 200_000) $ - logInfo tracer $ - mconcat ["Fixed ", textShow newSize, "/", textShow wrongTotalSize, " entries"] + when (newSize `div` 200_000 > lastSize `div` 200_000) + $ logInfo tracer + $ mconcat ["Fixed ", textShow newSize, "/", textShow wrongTotalSize, " entries"] chainSyncClientFixData :: SqlBackend -> Trace IO Text -> FixData -> ChainSyncClient CardanoBlock (Point CardanoBlock) (Tip CardanoBlock) IO () @@ -536,27 +537,27 @@ chainSyncClientFixData backend tracer fixData = Client.ChainSyncClient $ do liftIO $ logInfo tracer "Finished chainsync to fix Plutus Data." pure $ Client.SendMsgDone () Just (point, fdOnPoint, fdRest) -> do - when shouldLog $ - liftIO $ - logInfo tracer $ - mconcat ["Starting fixing Plutus Data ", textShow point] + when shouldLog + $ liftIO + $ logInfo tracer + $ mconcat ["Starting fixing Plutus Data ", textShow point] newLastSize <- liftIO $ updateSizeAndLog lastSize (sizeFixData fds) let clientStIntersect = Client.ClientStIntersect { Client.recvMsgIntersectFound = \_pnt _tip -> - Client.ChainSyncClient $ - pure $ - Client.SendMsgRequestNext (pure ()) (clientStNext newLastSize fdOnPoint fdRest) + Client.ChainSyncClient + $ pure + $ Client.SendMsgRequestNext (pure ()) (clientStNext newLastSize fdOnPoint fdRest) , Client.recvMsgIntersectNotFound = \tip -> Client.ChainSyncClient $ do - liftIO $ - logWarning tracer $ - mconcat - [ "Node can't find block " - , textShow point - , ". It's probably behind, at " - , textShow tip - , ". Sleeping for 3 mins and retrying.." - ] + liftIO + $ logWarning tracer + $ mconcat + [ "Node can't find block " + , textShow point + , ". It's probably behind, at " + , textShow tip + , ". Sleeping for 3 mins and retrying.." + ] liftIO $ threadDelay $ 180 * 1_000_000 pure $ Client.SendMsgFindIntersect [point] clientStIntersect } @@ -569,9 +570,9 @@ chainSyncClientFixData backend tracer fixData = Client.ChainSyncClient $ do runDbIohkLogging backend tracer $ fixPlutusData tracer blk fdOnPoint clientStIdle False lastSize fdRest , Client.recvMsgRollBackward = \_point _tip -> - Client.ChainSyncClient $ - pure $ - Client.SendMsgRequestNext (pure ()) (clientStNext lastSize fdOnPoint fdRest) + Client.ChainSyncClient + $ pure + $ Client.SendMsgRequestNext (pure ()) (clientStNext lastSize fdOnPoint fdRest) } chainSyncClientFixScripts :: @@ -596,27 +597,27 @@ chainSyncClientFixScripts backend tracer fps = Client.ChainSyncClient $ do liftIO $ logInfo tracer "Finished chainsync to fix Plutus Scripts." pure $ Client.SendMsgDone () Just (point, fpsOnPoint, fpsRest) -> do - when shouldLog $ - liftIO $ - logInfo tracer $ - mconcat ["Starting fixing Plutus Scripts ", textShow point] + when shouldLog + $ liftIO + $ logInfo tracer + $ mconcat ["Starting fixing Plutus Scripts ", textShow point] newLastSize <- liftIO $ updateSizeAndLog lastSize (sizeFixPlutusScripts fps') let clientStIntersect = Client.ClientStIntersect { Client.recvMsgIntersectFound = \_pnt _tip -> - Client.ChainSyncClient $ - pure $ - Client.SendMsgRequestNext (pure ()) (clientStNext newLastSize fpsOnPoint fpsRest) + Client.ChainSyncClient + $ pure + $ Client.SendMsgRequestNext (pure ()) (clientStNext newLastSize fpsOnPoint fpsRest) , Client.recvMsgIntersectNotFound = \tip -> Client.ChainSyncClient $ do - liftIO $ - logWarning tracer $ - mconcat - [ "Node can't find block " - , textShow point - , ". It's probably behind, at " - , textShow tip - , ". Sleeping for 3 mins and retrying.." - ] + liftIO + $ logWarning tracer + $ mconcat + [ "Node can't find block " + , textShow point + , ". It's probably behind, at " + , textShow tip + , ". Sleeping for 3 mins and retrying.." + ] liftIO $ threadDelay $ 180 * 1_000_000 pure $ Client.SendMsgFindIntersect [point] clientStIntersect } @@ -629,7 +630,7 @@ chainSyncClientFixScripts backend tracer fps = Client.ChainSyncClient $ do runDbIohkLogging backend tracer $ fixPlutusScripts tracer blk fpsOnPoint clientStIdle False lastSize fpsRest , Client.recvMsgRollBackward = \_point _tip -> - Client.ChainSyncClient $ - pure $ - Client.SendMsgRequestNext (pure ()) (clientStNext lastSize fpsOnPoint fpsRest) + Client.ChainSyncClient + $ pure + $ Client.SendMsgRequestNext (pure ()) (clientStNext lastSize fpsOnPoint fpsRest) } diff --git a/cardano-db-sync/src/Cardano/DbSync/Util/Bech32.hs b/cardano-db-sync/src/Cardano/DbSync/Util/Bech32.hs index 6b600b515..0dbfe0677 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Util/Bech32.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Util/Bech32.hs @@ -36,8 +36,8 @@ serialiseToBech32 :: Text -> ByteString -> Text serialiseToBech32 prefix bytes = encodeLenient humanReadablePart dataPart where humanReadablePart = - either (panic . show) id $ - humanReadablePartFromText prefix + either (panic . show) id + $ humanReadablePartFromText prefix dataPart = dataPartFromBytes bytes -- | Deserialise a bech32 address to a ByteString diff --git a/cardano-db-sync/src/Cardano/DbSync/Util/Cbor.hs b/cardano-db-sync/src/Cardano/DbSync/Util/Cbor.hs index a52e24bdd..d6858ab87 100644 --- a/cardano-db-sync/src/Cardano/DbSync/Util/Cbor.hs +++ b/cardano-db-sync/src/Cardano/DbSync/Util/Cbor.hs @@ -20,8 +20,8 @@ serialiseTxMetadataToCbor = serialize' shelleyProtVer . map toShelleyMetadatum toShelleyMetadatum (TxMetaText s) = S s toShelleyMetadatum (TxMetaList xs) = List $ map toShelleyMetadatum xs toShelleyMetadatum (TxMetaMap ms) = - Map $ - map (bimapBoth toShelleyMetadatum) ms + Map + $ map (bimapBoth toShelleyMetadatum) ms deserialiseTxMetadataFromCbor :: ByteString -> Either DecoderError (Map Word64 TxMetadataValue) deserialiseTxMetadataFromCbor = @@ -33,8 +33,8 @@ deserialiseTxMetadataFromCbor = fromShelleyMetadatum (S s) = TxMetaText s fromShelleyMetadatum (List xs) = TxMetaList $ map fromShelleyMetadatum xs fromShelleyMetadatum (Map ms) = - TxMetaMap $ - map (bimapBoth fromShelleyMetadatum) ms + TxMetaMap + $ map (bimapBoth fromShelleyMetadatum) ms bimapBoth :: Bifunctor f => (a -> b) -> f a a -> f b b bimapBoth f = bimap f f diff --git a/cardano-db-sync/test/Cardano/DbSync/ApiTest.hs b/cardano-db-sync/test/Cardano/DbSync/ApiTest.hs index 8d6e492b5..d22d1086b 100644 --- a/cardano-db-sync/test/Cardano/DbSync/ApiTest.hs +++ b/cardano-db-sync/test/Cardano/DbSync/ApiTest.hs @@ -11,8 +11,8 @@ import Hedgehog tests :: IO Bool tests = - checkParallel $ - Group + checkParallel + $ Group "Cardano.DbSync.Api" [ ("extractInsertOptions", prop_extractInsertOptions) , ("extractInsertOptions rewards", prop_extractInsertOptionsRewards) diff --git a/cardano-db-sync/test/Cardano/DbSync/Config/TypesTest.hs b/cardano-db-sync/test/Cardano/DbSync/Config/TypesTest.hs index 6bc15bea1..ae9d99e08 100644 --- a/cardano-db-sync/test/Cardano/DbSync/Config/TypesTest.hs +++ b/cardano-db-sync/test/Cardano/DbSync/Config/TypesTest.hs @@ -15,8 +15,8 @@ import Prelude () tests :: IO Bool tests = - checkParallel $ - Group + checkParallel + $ Group "Cardano.DbSync.Config.Types" [ ("SyncInsertConfig FromJSON", prop_syncInsertConfigFromJSON) , ("SyncInsertConfig roundtrip", prop_syncInsertConfigRoundtrip) diff --git a/cardano-db-sync/test/Cardano/DbSync/Era/Shelley/Generic/ScriptDataTest.hs b/cardano-db-sync/test/Cardano/DbSync/Era/Shelley/Generic/ScriptDataTest.hs index 0c154891c..60adda4e4 100644 --- a/cardano-db-sync/test/Cardano/DbSync/Era/Shelley/Generic/ScriptDataTest.hs +++ b/cardano-db-sync/test/Cardano/DbSync/Era/Shelley/Generic/ScriptDataTest.hs @@ -20,8 +20,8 @@ import Prelude (String ()) tests :: IO Bool tests = - checkParallel $ - Group + checkParallel + $ Group "Cardano.DbSync.Era.Shelley.Generic.ScriptData" [ ("scriptDataToJSON simple", prop_scriptDataToJSON) , ("scriptDataToJSON negative", prop_scriptDataToJSON_bad) diff --git a/cardano-db-sync/test/Cardano/DbSync/Era/Shelley/Generic/ScriptTest.hs b/cardano-db-sync/test/Cardano/DbSync/Era/Shelley/Generic/ScriptTest.hs index 7ebb58436..edad9807f 100644 --- a/cardano-db-sync/test/Cardano/DbSync/Era/Shelley/Generic/ScriptTest.hs +++ b/cardano-db-sync/test/Cardano/DbSync/Era/Shelley/Generic/ScriptTest.hs @@ -27,8 +27,8 @@ import Prelude (String ()) tests :: IO Bool tests = - checkParallel $ - Group + checkParallel + $ Group "Cardano.DbSync.Era.Shelley.Generic.Script" [ ("multisigToJSON simple", prop_multisigToJSON) , ("multisigToJSON negative", prop_multisigToJSON_bad) diff --git a/cardano-db-sync/test/Cardano/DbSync/Util/AddressTest.hs b/cardano-db-sync/test/Cardano/DbSync/Util/AddressTest.hs index 16448b4f7..f046fa3fe 100644 --- a/cardano-db-sync/test/Cardano/DbSync/Util/AddressTest.hs +++ b/cardano-db-sync/test/Cardano/DbSync/Util/AddressTest.hs @@ -19,8 +19,8 @@ import Prelude () tests :: IO Bool tests = - checkParallel $ - Group + checkParallel + $ Group "Cardano.DbSync.Util.Address" [ ("serialiseAddress byron simple", prop_serialiseAddress_byron) , ("serialiseAddress byron roundtrip", prop_serialiseAddress_byron_roundtrip) diff --git a/cardano-db-sync/test/Cardano/DbSync/Util/Bech32Test.hs b/cardano-db-sync/test/Cardano/DbSync/Util/Bech32Test.hs index 798a8df82..475333532 100644 --- a/cardano-db-sync/test/Cardano/DbSync/Util/Bech32Test.hs +++ b/cardano-db-sync/test/Cardano/DbSync/Util/Bech32Test.hs @@ -20,8 +20,8 @@ import Prelude () tests :: IO Bool tests = - checkParallel $ - Group + checkParallel + $ Group "Cardano.DbSync.Util.Bech32" [ ("serialiseVerKeyVrfToBech32 simple", prop_serialiseToBech32) , ("serialiseVerKeyVrfToBech32 roundtrip", prop_serialiseVerKeyVrfToBech32_roundtrip) diff --git a/cardano-db-sync/test/Cardano/DbSync/Util/CborTest.hs b/cardano-db-sync/test/Cardano/DbSync/Util/CborTest.hs index 29806b5c6..a73b9d5e8 100644 --- a/cardano-db-sync/test/Cardano/DbSync/Util/CborTest.hs +++ b/cardano-db-sync/test/Cardano/DbSync/Util/CborTest.hs @@ -17,8 +17,8 @@ import Prelude () tests :: IO Bool tests = - checkParallel $ - Group + checkParallel + $ Group "Cardano.DbSync.Util.CborTest" [ ("serialiseTxMetadataToCbor simple", prop_serialiseTxMetadataToCbor) , ("serialiseTxMetadataToCbor roundtrip", prop_serialiseTxMetadataToCbor_roundtrip) @@ -65,8 +65,10 @@ knownTxMetadata = , ( Map.singleton 1000 - ( TxMetaBytes . Base16.decodeLenient . encodeUtf8 $ - "01da32e76ec731be1a80444acae242f9122971a077f01aa691d1ec89c8da042223c75772ad8f7a48b3068833af202a6500ab22f763dd4ef83d" + ( TxMetaBytes + . Base16.decodeLenient + . encodeUtf8 + $ "01da32e76ec731be1a80444acae242f9122971a077f01aa691d1ec89c8da042223c75772ad8f7a48b3068833af202a6500ab22f763dd4ef83d" ) , "a11903e8583901da32e76ec731be1a80444acae242f9122971a077f01aa691d1ec89c8da042223c75772ad8f7a48b3068833af202a6500ab22f763dd4ef83d" ) @@ -131,8 +133,10 @@ genTxMetadataValue = Gen.sized $ \(Size size) -> do genTxMetaMap :: Gen [(TxMetadataValue, TxMetadataValue)] genTxMetaMap = Gen.sized $ \(Size size) -> - Gen.list (Range.linear 0 size) $ - (,) <$> genTxMetadataValue <*> genTxMetadataValue + Gen.list (Range.linear 0 size) + $ (,) + <$> genTxMetadataValue + <*> genTxMetadataValue isMetaNumber :: TxMetadataValue -> Bool isMetaNumber (TxMetaNumber _) = True diff --git a/cardano-db-sync/test/Cardano/DbSyncTest.hs b/cardano-db-sync/test/Cardano/DbSyncTest.hs index a9eb1b5d0..9abdb65b3 100644 --- a/cardano-db-sync/test/Cardano/DbSyncTest.hs +++ b/cardano-db-sync/test/Cardano/DbSyncTest.hs @@ -15,8 +15,8 @@ import qualified Hedgehog.Gen as Gen tests :: IO Bool tests = - checkParallel $ - Group + checkParallel + $ Group "Cardano.DbSync" [ ( "extractSyncOptions passes prune consume migration" diff --git a/cardano-db-tool/src/Cardano/DbTool/Report/Balance.hs b/cardano-db-tool/src/Cardano/DbTool/Report/Balance.hs index 7d76ac838..dddf08dde 100644 --- a/cardano-db-tool/src/Cardano/DbTool/Report/Balance.hs +++ b/cardano-db-tool/src/Cardano/DbTool/Report/Balance.hs @@ -104,10 +104,10 @@ queryStakeAddressBalance txOutTableType address = do TxOutVariantAddress -> do res <- select $ do (txo :& addr) <- - from - $ table @V.TxOut + from $ + table @V.TxOut `innerJoin` table @V.Address - `on` (\(txo :& addr) -> txo ^. V.TxOutAddressId ==. addr ^. V.AddressId) + `on` (\(txo :& addr) -> txo ^. V.TxOutAddressId ==. addr ^. V.AddressId) where_ (addr ^. V.AddressStakeAddressId ==. just (val saId)) pure (sum_ (txo ^. V.TxOutValue)) pure $ unValueSumAda (listToMaybe res) @@ -135,26 +135,26 @@ queryStakeAddressBalance txOutTableType address = do TxOutCore -> do res <- select $ do (txOut :& tx :& _txIn) <- - from - $ table @C.TxOut + from $ + table @C.TxOut `innerJoin` table @Tx - `on` (\(txOut :& tx) -> txOut ^. C.TxOutTxId ==. tx ^. TxId) + `on` (\(txOut :& tx) -> txOut ^. C.TxOutTxId ==. tx ^. TxId) `innerJoin` table @TxIn - `on` (\(txOut :& tx :& txIn) -> txIn ^. TxInTxOutId ==. tx ^. TxId &&. txIn ^. TxInTxOutIndex ==. txOut ^. C.TxOutIndex) + `on` (\(txOut :& tx :& txIn) -> txIn ^. TxInTxOutId ==. tx ^. TxId &&. txIn ^. TxInTxOutIndex ==. txOut ^. C.TxOutIndex) where_ (txOut ^. C.TxOutStakeAddressId ==. just (val saId)) pure (sum_ (txOut ^. C.TxOutValue), sum_ (tx ^. TxFee), sum_ (tx ^. TxDeposit)) pure $ maybe (0, 0, 0) convert (listToMaybe res) TxOutVariantAddress -> do res <- select $ do (txOut :& addr :& tx :& _txIn) <- - from - $ table @V.TxOut + from $ + table @V.TxOut `innerJoin` table @V.Address - `on` (\(txOut :& addr) -> txOut ^. V.TxOutAddressId ==. addr ^. V.AddressId) + `on` (\(txOut :& addr) -> txOut ^. V.TxOutAddressId ==. addr ^. V.AddressId) `innerJoin` table @Tx - `on` (\(txOut :& _addr :& tx) -> txOut ^. V.TxOutTxId ==. tx ^. TxId) + `on` (\(txOut :& _addr :& tx) -> txOut ^. V.TxOutTxId ==. tx ^. TxId) `innerJoin` table @TxIn - `on` (\(txOut :& _addr :& tx :& txIn) -> txIn ^. TxInTxOutId ==. tx ^. TxId &&. txIn ^. TxInTxOutIndex ==. txOut ^. V.TxOutIndex) + `on` (\(txOut :& _addr :& tx :& txIn) -> txIn ^. TxInTxOutId ==. tx ^. TxId &&. txIn ^. TxInTxOutIndex ==. txOut ^. V.TxOutIndex) where_ (addr ^. V.AddressStakeAddressId ==. just (val saId)) pure (sum_ (txOut ^. V.TxOutValue), sum_ (tx ^. TxFee), sum_ (tx ^. TxDeposit)) pure $ maybe (0, 0, 0) convert (listToMaybe res) diff --git a/cardano-db-tool/src/Cardano/DbTool/Report/StakeReward/History.hs b/cardano-db-tool/src/Cardano/DbTool/Report/StakeReward/History.hs index 2064ed8b4..855c37daa 100644 --- a/cardano-db-tool/src/Cardano/DbTool/Report/StakeReward/History.hs +++ b/cardano-db-tool/src/Cardano/DbTool/Report/StakeReward/History.hs @@ -85,12 +85,12 @@ queryHistoryStakeRewards address = do queryDelegation maxEpoch = do res <- select $ do (ep :& es :& saddr) <- - from - $ table @Epoch + from $ + table @Epoch `innerJoin` table @EpochStake - `on` (\(ep :& es) -> ep ^. EpochNo ==. es ^. EpochStakeEpochNo) + `on` (\(ep :& es) -> ep ^. EpochNo ==. es ^. EpochStakeEpochNo) `innerJoin` table @StakeAddress - `on` (\(_ep :& es :& saddr) -> saddr ^. StakeAddressId ==. es ^. EpochStakeAddrId) + `on` (\(_ep :& es :& saddr) -> saddr ^. StakeAddressId ==. es ^. EpochStakeAddrId) where_ (saddr ^. StakeAddressView ==. val address) where_ (es ^. EpochStakeEpochNo <=. val maxEpoch) pure @@ -109,12 +109,12 @@ queryHistoryStakeRewards address = do queryReward (saId, en, date, DbLovelace delegated, poolId) = do res <- select $ do (saddr :& rwd :& ep) <- - from - $ table @StakeAddress + from $ + table @StakeAddress `innerJoin` table @Reward - `on` (\(saddr :& rwd) -> saddr ^. StakeAddressId ==. rwd ^. RewardAddrId) + `on` (\(saddr :& rwd) -> saddr ^. StakeAddressId ==. rwd ^. RewardAddrId) `innerJoin` table @Epoch - `on` (\(_saddr :& rwd :& ep) -> ep ^. EpochNo ==. rwd ^. RewardEarnedEpoch) + `on` (\(_saddr :& rwd :& ep) -> ep ^. EpochNo ==. rwd ^. RewardEarnedEpoch) where_ (ep ^. EpochNo ==. val en) where_ (saddr ^. StakeAddressId ==. val saId) orderBy [asc (ep ^. EpochNo)] diff --git a/cardano-db-tool/src/Cardano/DbTool/Report/StakeReward/Latest.hs b/cardano-db-tool/src/Cardano/DbTool/Report/StakeReward/Latest.hs index 4af910b63..c5789e32a 100644 --- a/cardano-db-tool/src/Cardano/DbTool/Report/StakeReward/Latest.hs +++ b/cardano-db-tool/src/Cardano/DbTool/Report/StakeReward/Latest.hs @@ -100,12 +100,12 @@ queryDelegation :: queryDelegation address epochNum = do res <- select $ do (ep :& es :& saddr) <- - from - $ table @Epoch + from $ + table @Epoch `innerJoin` table @EpochStake - `on` (\(ep :& es) -> ep ^. EpochNo ==. es ^. EpochStakeEpochNo) + `on` (\(ep :& es) -> ep ^. EpochNo ==. es ^. EpochStakeEpochNo) `innerJoin` table @StakeAddress - `on` (\(_ep :& es :& saddr) -> saddr ^. StakeAddressId ==. es ^. EpochStakeAddrId) + `on` (\(_ep :& es :& saddr) -> saddr ^. StakeAddressId ==. es ^. EpochStakeAddrId) where_ (saddr ^. StakeAddressView ==. val address) where_ (es ^. EpochStakeEpochNo <=. val epochNum) @@ -128,12 +128,12 @@ queryReward :: queryReward en address (saId, date, DbLovelace delegated, poolId) = do res <- select $ do (ep :& reward :& saddr) <- - from - $ table @Epoch + from $ + table @Epoch `innerJoin` table @Reward - `on` (\(ep :& reward) -> ep ^. EpochNo ==. reward ^. RewardEarnedEpoch) + `on` (\(ep :& reward) -> ep ^. EpochNo ==. reward ^. RewardEarnedEpoch) `innerJoin` table @StakeAddress - `on` (\(_ep :& reward :& saddr) -> saddr ^. StakeAddressId ==. reward ^. RewardAddrId) + `on` (\(_ep :& reward :& saddr) -> saddr ^. StakeAddressId ==. reward ^. RewardAddrId) where_ (ep ^. EpochNo ==. val en) where_ (saddr ^. StakeAddressId ==. val saId) orderBy [asc (ep ^. EpochNo)] diff --git a/cardano-db-tool/src/Cardano/DbTool/Report/Transactions.hs b/cardano-db-tool/src/Cardano/DbTool/Report/Transactions.hs index 1deb1bdbe..fa9fc14cd 100644 --- a/cardano-db-tool/src/Cardano/DbTool/Report/Transactions.hs +++ b/cardano-db-tool/src/Cardano/DbTool/Report/Transactions.hs @@ -117,36 +117,36 @@ queryInputs txOutTableType saId = do -- get the StakeAddressId from the Core TxOut table TxOutCore -> select $ do (tx :& txOut :& blk) <- - from - $ table @Tx + from $ + table @Tx `innerJoin` table @C.TxOut - `on` (\(tx :& txOut) -> txOut ^. C.TxOutTxId ==. tx ^. TxId) + `on` (\(tx :& txOut) -> txOut ^. C.TxOutTxId ==. tx ^. TxId) `innerJoin` table @Block - `on` (\(tx :& _txOut :& blk) -> tx ^. TxBlockId ==. blk ^. BlockId) + `on` (\(tx :& _txOut :& blk) -> tx ^. TxBlockId ==. blk ^. BlockId) where_ (txOut ^. C.TxOutStakeAddressId ==. just (val saId)) pure (tx ^. TxHash, blk ^. BlockTime, txOut ^. C.TxOutValue) -- get the StakeAddressId from the Variant TxOut table TxOutVariantAddress -> select $ do (tx :& txOut :& addr :& blk) <- - from - $ table @Tx + from $ + table @Tx `innerJoin` table @V.TxOut - `on` (\(tx :& txOut) -> txOut ^. V.TxOutTxId ==. tx ^. TxId) + `on` (\(tx :& txOut) -> txOut ^. V.TxOutTxId ==. tx ^. TxId) `innerJoin` table @V.Address - `on` (\(_tx :& txOut :& addr) -> txOut ^. V.TxOutAddressId ==. addr ^. V.AddressId) + `on` (\(_tx :& txOut :& addr) -> txOut ^. V.TxOutAddressId ==. addr ^. V.AddressId) `innerJoin` table @Block - `on` (\(tx :& _txOut :& _addr :& blk) -> tx ^. TxBlockId ==. blk ^. BlockId) + `on` (\(tx :& _txOut :& _addr :& blk) -> tx ^. TxBlockId ==. blk ^. BlockId) where_ (addr ^. V.AddressStakeAddressId ==. just (val saId)) pure (tx ^. TxHash, blk ^. BlockTime, txOut ^. V.TxOutValue) -- Reward withdrawals. res2 <- select $ do (tx :& blk :& wdrl) <- - from - $ table @Tx + from $ + table @Tx `innerJoin` table @Block - `on` (\(tx :& blk) -> tx ^. TxBlockId ==. blk ^. BlockId) + `on` (\(tx :& blk) -> tx ^. TxBlockId ==. blk ^. BlockId) `innerJoin` table @Withdrawal - `on` (\(tx :& _blk :& wdrl) -> wdrl ^. WithdrawalTxId ==. tx ^. TxId) + `on` (\(tx :& _blk :& wdrl) -> wdrl ^. WithdrawalTxId ==. tx ^. TxId) where_ (wdrl ^. WithdrawalAddrId ==. val saId) pure (tx ^. TxHash, blk ^. BlockTime, wdrl ^. WithdrawalAmount) pure $ groupByTxHash (map (convertTx Incoming) res1 ++ map (convertTx Outgoing) res2) @@ -182,33 +182,33 @@ queryOutputs txOutTableType saId = do res <- case txOutTableType of TxOutCore -> select $ do (txOut :& _txInTx :& _txIn :& txOutTx :& blk) <- - from - $ table @C.TxOut + from $ + table @C.TxOut `innerJoin` table @Tx - `on` (\(txOut :& txInTx) -> txOut ^. C.TxOutTxId ==. txInTx ^. TxId) + `on` (\(txOut :& txInTx) -> txOut ^. C.TxOutTxId ==. txInTx ^. TxId) `innerJoin` table @TxIn - `on` (\(txOut :& txInTx :& txIn) -> txIn ^. TxInTxOutId ==. txInTx ^. TxId &&. txIn ^. TxInTxOutIndex ==. txOut ^. C.TxOutIndex) + `on` (\(txOut :& txInTx :& txIn) -> txIn ^. TxInTxOutId ==. txInTx ^. TxId &&. txIn ^. TxInTxOutIndex ==. txOut ^. C.TxOutIndex) `innerJoin` table @Tx - `on` (\(_txOut :& _txInTx :& txIn :& txOutTx) -> txOutTx ^. TxId ==. txIn ^. TxInTxInId) + `on` (\(_txOut :& _txInTx :& txIn :& txOutTx) -> txOutTx ^. TxId ==. txIn ^. TxInTxInId) `innerJoin` table @Block - `on` (\(_txOut :& _txInTx :& _txIn :& txOutTx :& blk) -> txOutTx ^. TxBlockId ==. blk ^. BlockId) + `on` (\(_txOut :& _txInTx :& _txIn :& txOutTx :& blk) -> txOutTx ^. TxBlockId ==. blk ^. BlockId) where_ (txOut ^. C.TxOutStakeAddressId ==. just (val saId)) pure (txOutTx ^. TxHash, blk ^. BlockTime, txOut ^. C.TxOutValue) TxOutVariantAddress -> select $ do (txOut :& addr :& _txInTx :& _txIn :& txOutTx :& blk) <- - from - $ table @V.TxOut + from $ + table @V.TxOut `innerJoin` table @V.Address - `on` (\(txOut :& addr) -> txOut ^. V.TxOutAddressId ==. addr ^. V.AddressId) + `on` (\(txOut :& addr) -> txOut ^. V.TxOutAddressId ==. addr ^. V.AddressId) `innerJoin` table @Tx - `on` (\(txOut :& _addr :& txInTx) -> txOut ^. V.TxOutTxId ==. txInTx ^. TxId) + `on` (\(txOut :& _addr :& txInTx) -> txOut ^. V.TxOutTxId ==. txInTx ^. TxId) `innerJoin` table @TxIn - `on` (\(txOut :& _addr :& txInTx :& txIn) -> txIn ^. TxInTxOutId ==. txInTx ^. TxId &&. txIn ^. TxInTxOutIndex ==. txOut ^. V.TxOutIndex) + `on` (\(txOut :& _addr :& txInTx :& txIn) -> txIn ^. TxInTxOutId ==. txInTx ^. TxId &&. txIn ^. TxInTxOutIndex ==. txOut ^. V.TxOutIndex) `innerJoin` table @Tx - `on` (\(_txOut :& _addr :& _txInTx :& txIn :& txOutTx) -> txOutTx ^. TxId ==. txIn ^. TxInTxInId) + `on` (\(_txOut :& _addr :& _txInTx :& txIn :& txOutTx) -> txOutTx ^. TxId ==. txIn ^. TxInTxInId) `innerJoin` table @Block - `on` (\(_txOut :& _addr :& _txInTx :& _txIn :& txOutTx :& blk) -> txOutTx ^. TxBlockId ==. blk ^. BlockId) + `on` (\(_txOut :& _addr :& _txInTx :& _txIn :& txOutTx :& blk) -> txOutTx ^. TxBlockId ==. blk ^. BlockId) where_ (addr ^. V.AddressStakeAddressId ==. just (val saId)) pure (txOutTx ^. TxHash, blk ^. BlockTime, txOut ^. V.TxOutValue) diff --git a/cardano-db-tool/src/Cardano/DbTool/Validate/AdaPots.hs b/cardano-db-tool/src/Cardano/DbTool/Validate/AdaPots.hs index e59eff1e1..ab24c7f02 100644 --- a/cardano-db-tool/src/Cardano/DbTool/Validate/AdaPots.hs +++ b/cardano-db-tool/src/Cardano/DbTool/Validate/AdaPots.hs @@ -33,10 +33,10 @@ validateSumAdaPots = do let uniqueCount = List.length $ List.nubOrd (map accSumAdaPots xs) if - | uniqueCount == 0 -> error $ redText "No AdaPots entries found" - | length xs == 1 -> putStrLn $ greenText "ok (but only one AdaPots entry found)" - | uniqueCount == 1 -> putStrLn $ greenText "ok" - | otherwise -> error $ redText (show uniqueCount ++ " unique AdaPots sums (should be 1)") + | uniqueCount == 0 -> error $ redText "No AdaPots entries found" + | length xs == 1 -> putStrLn $ greenText "ok (but only one AdaPots entry found)" + | uniqueCount == 1 -> putStrLn $ greenText "ok" + | otherwise -> error $ redText (show uniqueCount ++ " unique AdaPots sums (should be 1)") -- ----------------------------------------------------------------------------- diff --git a/cardano-db-tool/src/Cardano/DbTool/Validate/BlockTxs.hs b/cardano-db-tool/src/Cardano/DbTool/Validate/BlockTxs.hs index e4e0a9849..d56ead3ca 100644 --- a/cardano-db-tool/src/Cardano/DbTool/Validate/BlockTxs.hs +++ b/cardano-db-tool/src/Cardano/DbTool/Validate/BlockTxs.hs @@ -84,10 +84,10 @@ queryBlockTxCount :: MonadIO m => Word64 -> ReaderT SqlBackend m Word64 queryBlockTxCount blockNo = do res <- select $ do (blk :& _tx) <- - from - $ table @Block + from $ + table @Block `innerJoin` table @Tx - `on` (\(blk :& tx) -> blk ^. BlockId ==. tx ^. TxBlockId) + `on` (\(blk :& tx) -> blk ^. BlockId ==. tx ^. TxBlockId) where_ (blk ^. BlockBlockNo ==. just (val blockNo)) pure countRows pure $ maybe 0 unValue (listToMaybe res) diff --git a/cardano-db-tool/src/Cardano/DbTool/Validate/TxAccounting.hs b/cardano-db-tool/src/Cardano/DbTool/Validate/TxAccounting.hs index d229f045e..3c9606f2f 100644 --- a/cardano-db-tool/src/Cardano/DbTool/Validate/TxAccounting.hs +++ b/cardano-db-tool/src/Cardano/DbTool/Validate/TxAccounting.hs @@ -176,12 +176,12 @@ queryInputsBody :: forall a m. (MonadIO m, TxOutFields a) => Word64 -> ReaderT S queryInputsBody txId = do res <- select $ do (tx :& txin :& txout) <- - from - $ table @Tx + from $ + table @Tx `innerJoin` table @TxIn - `on` (\(tx :& txin) -> tx ^. TxId ==. txin ^. TxInTxInId) + `on` (\(tx :& txin) -> tx ^. TxId ==. txin ^. TxInTxInId) `innerJoin` table @(TxOutTable a) - `on` (\(_tx :& txin :& txout) -> txin ^. TxInTxOutId ==. txout ^. txOutTxIdField @a) + `on` (\(_tx :& txin :& txout) -> txin ^. TxInTxOutId ==. txout ^. txOutTxIdField @a) where_ (tx ^. TxId ==. val (toSqlKey $ fromIntegral txId)) where_ (txout ^. txOutIndexField @a ==. txin ^. TxInTxOutIndex) pure txout @@ -196,10 +196,10 @@ queryTxOutputsBody :: forall a m. (MonadIO m, TxOutFields a) => Word64 -> Reader queryTxOutputsBody txId = do res <- select $ do (tx :& txout) <- - from - $ table @Tx + from $ + table @Tx `innerJoin` table @(TxOutTable a) - `on` (\(tx :& txout) -> tx ^. TxId ==. txout ^. txOutTxIdField @a) + `on` (\(tx :& txout) -> tx ^. TxId ==. txout ^. txOutTxIdField @a) where_ (tx ^. TxId ==. val (toSqlKey $ fromIntegral txId)) pure txout pure $ entityVal <$> res diff --git a/cardano-db/src/Cardano/Db/Operations/Delete.hs b/cardano-db/src/Cardano/Db/Operations/Delete.hs index e84c71cec..7ec0f0bb2 100644 --- a/cardano-db/src/Cardano/Db/Operations/Delete.hs +++ b/cardano-db/src/Cardano/Db/Operations/Delete.hs @@ -187,7 +187,7 @@ deleteTablesAfterBlockId txOutTableType blkId mtxId minIdsW = do pure (sum $ map snd blockLogs, initialLogs <> blockLogs <> offChainLogs <> afterTxIdLogs) deleteTablesAfterTxId :: - (MonadIO m) => + MonadIO m => TxOutTableType -> Maybe TxId -> MinIdsWrapper -> diff --git a/cardano-db/src/Cardano/Db/Operations/Other/ConsumedTxOut.hs b/cardano-db/src/Cardano/Db/Operations/Other/ConsumedTxOut.hs index 47f68e513..513e93ee1 100644 --- a/cardano-db/src/Cardano/Db/Operations/Other/ConsumedTxOut.hs +++ b/cardano-db/src/Cardano/Db/Operations/Other/ConsumedTxOut.hs @@ -97,7 +97,7 @@ querySetNullTxOut txOutTableType mMinTxId = do TxOutVariantAddress -> setNull where setNull :: - (MonadIO m) => + MonadIO m => ReaderT SqlBackend m () setNull = do case txOutId of diff --git a/cardano-db/src/Cardano/Db/Operations/Other/JsonbQuery.hs b/cardano-db/src/Cardano/Db/Operations/Other/JsonbQuery.hs index 7ae86600b..dc7072513 100644 --- a/cardano-db/src/Cardano/Db/Operations/Other/JsonbQuery.hs +++ b/cardano-db/src/Cardano/Db/Operations/Other/JsonbQuery.hs @@ -95,7 +95,7 @@ disableJsonbInSchema = do [] queryJsonbInSchemaExists :: - (MonadIO m) => + MonadIO m => ReaderT SqlBackend m Bool queryJsonbInSchemaExists = do isjsonb <- rawSql query [] diff --git a/cardano-db/src/Cardano/Db/Operations/Other/MinId.hs b/cardano-db/src/Cardano/Db/Operations/Other/MinId.hs index 261c47064..31ba81837 100644 --- a/cardano-db/src/Cardano/Db/Operations/Other/MinId.hs +++ b/cardano-db/src/Cardano/Db/Operations/Other/MinId.hs @@ -80,8 +80,8 @@ textToMinIdsCore :: Text -> Maybe (MinIds 'TxOutCore) textToMinIdsCore txt = case Text.split (== ':') txt of [tminTxInId, tminTxOutId, tminMaTxOutId] -> - Just $ - MinIds + Just + $ MinIds { minTxInId = toSqlKey <$> readMaybe (Text.unpack tminTxInId) , minTxOutId = toSqlKey <$> readMaybe (Text.unpack tminTxOutId) , minMaTxOutId = toSqlKey <$> readMaybe (Text.unpack tminMaTxOutId) @@ -92,15 +92,15 @@ textToMinIdsVariant :: Text -> Maybe (MinIds 'TxOutVariantAddress) textToMinIdsVariant txt = case Text.split (== ':') txt of [tminTxInId, tminTxOutId, tminMaTxOutId] -> - Just $ - MinIds + Just + $ MinIds { minTxInId = toSqlKey <$> readMaybe (Text.unpack tminTxInId) , minTxOutId = readMaybe (Text.unpack tminTxOutId) , minMaTxOutId = toSqlKey <$> readMaybe (Text.unpack tminMaTxOutId) } _otherwise -> Nothing -minJust :: (Ord a) => Maybe a -> Maybe a -> Maybe a +minJust :: Ord a => Maybe a -> Maybe a -> Maybe a minJust Nothing y = y minJust x Nothing = x minJust (Just x) (Just y) = Just (min x y) @@ -109,7 +109,7 @@ minJust (Just x) (Just y) = Just (min x y) -- CompleteMinId -------------------------------------------------------------------------------- completeMinId :: - (MonadIO m) => + MonadIO m => Maybe TxId -> MinIdsWrapper -> ReaderT SqlBackend m MinIdsWrapper @@ -127,8 +127,8 @@ completeMinIdCore mTxId minIds = do mMaTxOutId <- case mTxOutId of Nothing -> pure Nothing Just txOutId -> whenNothingQueryMinRefId (minMaTxOutId minIds) C.MaTxOutTxOutId txOutId - pure $ - MinIds + pure + $ MinIds { minTxInId = mTxInId , minTxOutId = mTxOutId , minMaTxOutId = mMaTxOutId @@ -144,8 +144,8 @@ completeMinIdVariant mTxId minIds = do mMaTxOutId <- case mTxOutId of Nothing -> pure Nothing Just txOutId -> whenNothingQueryMinRefId (minMaTxOutId minIds) V.MaTxOutTxOutId txOutId - pure $ - MinIds + pure + $ MinIds { minTxInId = mTxInId , minTxOutId = mTxOutId , minMaTxOutId = mMaTxOutId diff --git a/cardano-db/src/Cardano/Db/Operations/Query.hs b/cardano-db/src/Cardano/Db/Operations/Query.hs index 904ed1646..65f12bdf0 100644 --- a/cardano-db/src/Cardano/Db/Operations/Query.hs +++ b/cardano-db/src/Cardano/Db/Operations/Query.hs @@ -261,10 +261,10 @@ queryReverseIndexBlockId :: MonadIO m => BlockId -> ReaderT SqlBackend m [Maybe queryReverseIndexBlockId blockId = do res <- select $ do (blk :& ridx) <- - from - $ table @Block + from $ + table @Block `leftJoin` table @ReverseIndex - `on` (\(blk :& ridx) -> just (blk ^. BlockId) ==. ridx ?. ReverseIndexBlockId) + `on` (\(blk :& ridx) -> just (blk ^. BlockId) ==. ridx ?. ReverseIndexBlockId) where_ (blk ^. BlockId >=. val blockId) orderBy [asc (blk ^. BlockId)] pure $ ridx ?. ReverseIndexMinIds @@ -349,10 +349,10 @@ queryTxWithBlocks :: queryTxWithBlocks epochNum blockResult = do txRes <- select $ do (tx :& blk) <- - from - $ table @Tx + from $ + table @Tx `innerJoin` table @Block - `on` (\(tx :& blk) -> tx ^. TxBlockId ==. blk ^. BlockId) + `on` (\(tx :& blk) -> tx ^. TxBlockId ==. blk ^. BlockId) where_ (blk ^. BlockEpochNo ==. just (val epochNum)) pure (sum_ (tx ^. TxOutSum), sum_ (tx ^. TxFee), count (tx ^. TxOutSum)) case (listToMaybe blockResult, listToMaybe txRes) of @@ -774,12 +774,12 @@ queryStakeRefPtr :: MonadIO m => Ptr -> ReaderT SqlBackend m (Maybe StakeAddress queryStakeRefPtr (Ptr (SlotNo slot) (TxIx txIx) (CertIx certIx)) = do res <- select $ do (blk :& tx :& sr) <- - from - $ table @Block + from $ + table @Block `innerJoin` table @Tx - `on` (\(blk :& tx) -> blk ^. BlockId ==. tx ^. TxBlockId) + `on` (\(blk :& tx) -> blk ^. BlockId ==. tx ^. TxBlockId) `innerJoin` table @StakeRegistration - `on` (\(_blk :& tx :& sr) -> sr ^. StakeRegistrationTxId ==. tx ^. TxId) + `on` (\(_blk :& tx :& sr) -> sr ^. StakeRegistrationTxId ==. tx ^. TxId) where_ (blk ^. BlockSlotNo ==. just (val slot)) where_ (tx ^. TxBlockIndex ==. val (fromIntegral txIx)) @@ -796,12 +796,12 @@ queryPoolUpdateByBlock :: MonadIO m => BlockId -> PoolHashId -> ReaderT SqlBacke queryPoolUpdateByBlock blkId poolHashId = do res <- select $ do (blk :& _tx :& poolUpdate) <- - from - $ table @Block + from $ + table @Block `innerJoin` table @Tx - `on` (\(blk :& tx) -> blk ^. BlockId ==. tx ^. TxBlockId) + `on` (\(blk :& tx) -> blk ^. BlockId ==. tx ^. TxBlockId) `innerJoin` table @PoolUpdate - `on` (\(_blk :& tx :& poolUpdate) -> tx ^. TxId ==. poolUpdate ^. PoolUpdateRegisteredTxId) + `on` (\(_blk :& tx :& poolUpdate) -> tx ^. TxId ==. poolUpdate ^. PoolUpdateRegisteredTxId) where_ (poolUpdate ^. PoolUpdateHashId ==. val poolHashId) where_ (blk ^. BlockId ==. val blkId) limit 1 @@ -816,10 +816,10 @@ queryOffChainPoolData :: MonadIO m => ByteString -> ByteString -> ReaderT SqlBac queryOffChainPoolData poolHash poolMetadataHash = do res <- select $ do (pod :& ph) <- - from - $ table @OffChainPoolData + from $ + table @OffChainPoolData `innerJoin` table @PoolHash - `on` (\(pod :& ph) -> pod ^. OffChainPoolDataPoolId ==. ph ^. PoolHashId) + `on` (\(pod :& ph) -> pod ^. OffChainPoolDataPoolId ==. ph ^. PoolHashId) where_ (ph ^. PoolHashHashRaw ==. val poolHash) where_ (pod ^. OffChainPoolDataHash ==. val poolMetadataHash) limit 1 @@ -830,16 +830,16 @@ queryPoolRegister :: MonadIO m => Maybe ByteString -> ReaderT SqlBackend m [Pool queryPoolRegister mPoolHash = do res <- select $ do (poolUpdate :& poolHash :& poolMeta :& tx :& blk) <- - from - $ table @PoolUpdate + from $ + table @PoolUpdate `innerJoin` table @PoolHash - `on` (\(poolUpdate :& poolHash) -> poolUpdate ^. PoolUpdateHashId ==. poolHash ^. PoolHashId) + `on` (\(poolUpdate :& poolHash) -> poolUpdate ^. PoolUpdateHashId ==. poolHash ^. PoolHashId) `innerJoin` table @PoolMetadataRef - `on` (\(poolUpdate :& _poolHash :& poolMeta) -> poolUpdate ^. PoolUpdateMetaId ==. just (poolMeta ^. PoolMetadataRefId)) + `on` (\(poolUpdate :& _poolHash :& poolMeta) -> poolUpdate ^. PoolUpdateMetaId ==. just (poolMeta ^. PoolMetadataRefId)) `innerJoin` table @Tx - `on` (\(poolUpdate :& _poolHash :& _poolMeta :& tx) -> poolUpdate ^. PoolUpdateRegisteredTxId ==. tx ^. TxId) + `on` (\(poolUpdate :& _poolHash :& _poolMeta :& tx) -> poolUpdate ^. PoolUpdateRegisteredTxId ==. tx ^. TxId) `innerJoin` table @Block - `on` (\(_poolUpdate :& _poolHash :& _poolMeta :& tx :& blk) -> tx ^. TxBlockId ==. blk ^. BlockId) + `on` (\(_poolUpdate :& _poolHash :& _poolMeta :& tx :& blk) -> tx ^. TxBlockId ==. blk ^. BlockId) whenJust mPoolHash $ \ph -> where_ (poolHash ^. PoolHashHashRaw ==. val ph) @@ -863,14 +863,14 @@ queryRetiredPools :: MonadIO m => Maybe ByteString -> ReaderT SqlBackend m [Pool queryRetiredPools mPoolHash = do res <- select $ do (retired :& poolHash :& tx :& blk) <- - from - $ table @PoolRetire + from $ + table @PoolRetire `innerJoin` table @PoolHash - `on` (\(retired :& poolHash) -> retired ^. PoolRetireHashId ==. poolHash ^. PoolHashId) + `on` (\(retired :& poolHash) -> retired ^. PoolRetireHashId ==. poolHash ^. PoolHashId) `innerJoin` table @Tx - `on` (\(retired :& _poolHash :& tx) -> retired ^. PoolRetireAnnouncedTxId ==. tx ^. TxId) + `on` (\(retired :& _poolHash :& tx) -> retired ^. PoolRetireAnnouncedTxId ==. tx ^. TxId) `innerJoin` table @Block - `on` (\(_retired :& _poolHash :& tx :& blk) -> tx ^. TxBlockId ==. blk ^. BlockId) + `on` (\(_retired :& _poolHash :& tx :& blk) -> tx ^. TxBlockId ==. blk ^. BlockId) whenJust mPoolHash $ \ph -> where_ (poolHash ^. PoolHashHashRaw ==. val ph) pure @@ -893,10 +893,10 @@ queryUsedTicker :: MonadIO m => ByteString -> ByteString -> ReaderT SqlBackend m queryUsedTicker poolHash metaHash = do res <- select $ do (pod :& ph) <- - from - $ table @OffChainPoolData + from $ + table @OffChainPoolData `innerJoin` table @PoolHash - `on` (\(pod :& ph) -> ph ^. PoolHashId ==. pod ^. OffChainPoolDataPoolId) + `on` (\(pod :& ph) -> ph ^. PoolHashId ==. pod ^. OffChainPoolDataPoolId) where_ (ph ^. PoolHashHashRaw ==. val poolHash) where_ (pod ^. OffChainPoolDataHash ==. val metaHash) pure $ pod ^. OffChainPoolDataTickerName @@ -927,12 +927,12 @@ queryOffChainPoolFetchError :: MonadIO m => ByteString -> Maybe UTCTime -> Reade queryOffChainPoolFetchError hash Nothing = do res <- select $ do (offChainPoolFetchError :& poolHash :& poolMetadataRef) <- - from - $ table @OffChainPoolFetchError + from $ + table @OffChainPoolFetchError `innerJoin` table @PoolHash - `on` (\(offChainPoolFetchError :& poolHash) -> offChainPoolFetchError ^. OffChainPoolFetchErrorPoolId ==. poolHash ^. PoolHashId) + `on` (\(offChainPoolFetchError :& poolHash) -> offChainPoolFetchError ^. OffChainPoolFetchErrorPoolId ==. poolHash ^. PoolHashId) `innerJoin` table @PoolMetadataRef - `on` (\(offChainPoolFetchError :& _ :& poolMetadataRef) -> offChainPoolFetchError ^. OffChainPoolFetchErrorPmrId ==. poolMetadataRef ^. PoolMetadataRefId) + `on` (\(offChainPoolFetchError :& _ :& poolMetadataRef) -> offChainPoolFetchError ^. OffChainPoolFetchErrorPmrId ==. poolMetadataRef ^. PoolMetadataRefId) where_ (poolHash ^. PoolHashHashRaw ==. val hash) orderBy [desc (offChainPoolFetchError ^. OffChainPoolFetchErrorFetchTime)] @@ -944,12 +944,12 @@ queryOffChainPoolFetchError hash Nothing = do queryOffChainPoolFetchError hash (Just fromTime) = do res <- select $ do (offChainPoolFetchError :& poolHash :& poolMetadataRef) <- - from - $ table @OffChainPoolFetchError + from $ + table @OffChainPoolFetchError `innerJoin` table @PoolHash - `on` (\(offChainPoolFetchError :& poolHash) -> offChainPoolFetchError ^. OffChainPoolFetchErrorPoolId ==. poolHash ^. PoolHashId) + `on` (\(offChainPoolFetchError :& poolHash) -> offChainPoolFetchError ^. OffChainPoolFetchErrorPoolId ==. poolHash ^. PoolHashId) `innerJoin` table @PoolMetadataRef - `on` (\(offChainPoolFetchError :& _poolHash :& poolMetadataRef) -> offChainPoolFetchError ^. OffChainPoolFetchErrorPmrId ==. poolMetadataRef ^. PoolMetadataRefId) + `on` (\(offChainPoolFetchError :& _poolHash :& poolMetadataRef) -> offChainPoolFetchError ^. OffChainPoolFetchErrorPmrId ==. poolMetadataRef ^. PoolMetadataRefId) where_ ( poolHash ^. PoolHashHashRaw @@ -982,10 +982,10 @@ queryDepositUpToBlockNo :: MonadIO m => Word64 -> ReaderT SqlBackend m Ada queryDepositUpToBlockNo blkNo = do res <- select $ do (tx :& blk) <- - from - $ table @Tx + from $ + table @Tx `innerJoin` table @Block - `on` (\(tx :& blk) -> tx ^. TxBlockId ==. blk ^. BlockId) + `on` (\(tx :& blk) -> tx ^. TxBlockId ==. blk ^. BlockId) where_ (blk ^. BlockBlockNo <=. just (val blkNo)) pure $ sum_ (tx ^. TxDeposit) pure $ unValueSumAda (listToMaybe res) @@ -1003,10 +1003,10 @@ queryFeesUpToBlockNo :: MonadIO m => Word64 -> ReaderT SqlBackend m Ada queryFeesUpToBlockNo blkNo = do res <- select $ do (tx :& blk) <- - from - $ table @Tx + from $ + table @Tx `innerJoin` table @Block - `on` (\(tx :& blk) -> tx ^. TxBlockId ==. blk ^. BlockId) + `on` (\(tx :& blk) -> tx ^. TxBlockId ==. blk ^. BlockId) where_ (blk ^. BlockBlockNo <=. just (val blkNo)) pure $ sum_ (tx ^. TxFee) pure $ unValueSumAda (listToMaybe res) @@ -1015,10 +1015,10 @@ queryFeesUpToSlotNo :: MonadIO m => Word64 -> ReaderT SqlBackend m Ada queryFeesUpToSlotNo slotNo = do res <- select $ do (tx :& blk) <- - from - $ table @Tx + from $ + table @Tx `innerJoin` table @Block - `on` (\(tx :& blk) -> tx ^. TxBlockId ==. blk ^. BlockId) + `on` (\(tx :& blk) -> tx ^. TxBlockId ==. blk ^. BlockId) where_ (isJust $ blk ^. BlockSlotNo) where_ (blk ^. BlockSlotNo <=. just (val slotNo)) pure $ sum_ (tx ^. TxFee) @@ -1081,12 +1081,12 @@ queryWithdrawalsUpToBlockNo :: MonadIO m => Word64 -> ReaderT SqlBackend m Ada queryWithdrawalsUpToBlockNo blkNo = do res <- select $ do (_tx :& wdrl :& blk) <- - from - $ table @Tx + from $ + table @Tx `innerJoin` table @Withdrawal - `on` (\(tx :& wdrl) -> tx ^. TxId ==. wdrl ^. WithdrawalTxId) + `on` (\(tx :& wdrl) -> tx ^. TxId ==. wdrl ^. WithdrawalTxId) `innerJoin` table @Block - `on` (\(tx :& _wdrl :& blk) -> tx ^. TxBlockId ==. blk ^. BlockId) + `on` (\(tx :& _wdrl :& blk) -> tx ^. TxBlockId ==. blk ^. BlockId) where_ (blk ^. BlockBlockNo <=. val (Just $ fromIntegral blkNo)) pure $ sum_ (wdrl ^. WithdrawalAmount) pure $ unValueSumAda (listToMaybe res) @@ -1140,10 +1140,10 @@ queryTxInFailedTx :: MonadIO m => ReaderT SqlBackend m [TxIn] queryTxInFailedTx = do res <- select $ do (tx_in :& tx) <- - from - $ table @TxIn + from $ + table @TxIn `innerJoin` table @Tx - `on` (\(tx_in :& tx) -> tx_in ^. TxInTxInId ==. tx ^. TxId) + `on` (\(tx_in :& tx) -> tx_in ^. TxInTxInId ==. tx ^. TxId) where_ (tx ^. TxValidContract ==. val False) pure tx_in pure $ entityVal <$> res @@ -1202,10 +1202,10 @@ queryPreviousSlotNo :: MonadIO m => Word64 -> ReaderT SqlBackend m (Maybe Word64 queryPreviousSlotNo slotNo = do res <- select $ do (blk :& pblk) <- - from - $ table @Block + from $ + table @Block `innerJoin` table @Block - `on` (\(blk :& pblk) -> blk ^. BlockPreviousId ==. just (pblk ^. BlockId)) + `on` (\(blk :& pblk) -> blk ^. BlockPreviousId ==. just (pblk ^. BlockId)) where_ (blk ^. BlockSlotNo ==. just (val slotNo)) pure $ pblk ^. BlockSlotNo pure $ unValue =<< listToMaybe res diff --git a/cardano-db/src/Cardano/Db/Operations/TxOut/TxOutQuery.hs b/cardano-db/src/Cardano/Db/Operations/TxOut/TxOutQuery.hs index c6af125ef..0bb535333 100644 --- a/cardano-db/src/Cardano/Db/Operations/TxOut/TxOutQuery.hs +++ b/cardano-db/src/Cardano/Db/Operations/TxOut/TxOutQuery.hs @@ -81,10 +81,10 @@ queryTxOutValue txOutTableType hashIndex = queryTxOutValue' (hash, index) = do res <- select $ do (tx :& txOut) <- - from - $ table @Tx + from $ + table @Tx `innerJoin` table @(TxOutTable a) - `on` (\(tx :& txOut) -> tx ^. TxId ==. txOut ^. txOutTxIdField @a) + `on` (\(tx :& txOut) -> tx ^. TxId ==. txOut ^. txOutTxIdField @a) where_ (txOut ^. txOutIndexField @a ==. val index &&. tx ^. TxHash ==. val hash) pure (txOut ^. txOutTxIdField @a, txOut ^. txOutValueField @a) pure $ maybeToEither (DbLookupTxHash hash) unValue2 (listToMaybe res) @@ -114,10 +114,10 @@ queryTxOutId txOutTableType hashIndex = queryTxOutId' (hash, index) = do res <- select $ do (tx :& txOut) <- - from - $ table @Tx + from $ + table @Tx `innerJoin` table @(TxOutTable a) - `on` (\(tx :& txOut) -> tx ^. TxId ==. txOut ^. txOutTxIdField @a) + `on` (\(tx :& txOut) -> tx ^. TxId ==. txOut ^. txOutTxIdField @a) where_ (txOut ^. txOutIndexField @a ==. val index &&. tx ^. TxHash ==. val hash) pure (txOut ^. txOutTxIdField @a, txOut ^. txOutIdField @a) pure $ maybeToEither (DbLookupTxHash hash) unValue2 (listToMaybe res) @@ -128,7 +128,7 @@ queryTxOutId txOutTableType hashIndex = -- | Like 'queryTxOutId' but also return the 'TxOutIdValue' queryTxOutIdValue :: - (MonadIO m) => + MonadIO m => TxOutTableType -> (ByteString, Word64) -> ReaderT SqlBackend m (Either LookupFail (TxId, TxOutIdW, DbLovelace)) @@ -148,10 +148,10 @@ queryTxOutIdValue getTxOutTableType hashIndex = do queryTxOutIdValue' (hash, index) = do res <- select $ do (tx :& txOut) <- - from - $ table @Tx + from $ + table @Tx `innerJoin` table @(TxOutTable a) - `on` (\(tx :& txOut) -> tx ^. TxId ==. txOut ^. txOutTxIdField @a) + `on` (\(tx :& txOut) -> tx ^. TxId ==. txOut ^. txOutTxIdField @a) where_ (txOut ^. txOutIndexField @a ==. val index &&. tx ^. TxHash ==. val hash) pure (txOut ^. txOutTxIdField @a, txOut ^. txOutIdField @a, txOut ^. txOutValueField @a) pure $ maybeToEither (DbLookupTxHash hash) unValue3 (listToMaybe res) @@ -175,10 +175,10 @@ queryTxOutCredentialsCore :: MonadIO m => (ByteString, Word64) -> ReaderT SqlBac queryTxOutCredentialsCore (hash, index) = do res <- select $ do (tx :& txOut) <- - from - $ table @Tx + from $ + table @Tx `innerJoin` table @C.TxOut - `on` (\(tx :& txOut) -> tx ^. TxId ==. txOut ^. C.TxOutTxId) + `on` (\(tx :& txOut) -> tx ^. TxId ==. txOut ^. C.TxOutTxId) where_ (txOut ^. C.TxOutIndex ==. val index &&. tx ^. TxHash ==. val hash) pure (txOut ^. C.TxOutPaymentCred, txOut ^. C.TxOutAddressHasScript) pure $ maybeToEither (DbLookupTxHash hash) unValue2 (listToMaybe res) @@ -187,13 +187,13 @@ queryTxOutCredentialsVariant :: MonadIO m => (ByteString, Word64) -> ReaderT Sql queryTxOutCredentialsVariant (hash, index) = do res <- select $ do (tx :& txOut :& address) <- - from - $ ( table @Tx - `innerJoin` table @V.TxOut + from $ + ( table @Tx + `innerJoin` table @V.TxOut `on` (\(tx :& txOut) -> tx ^. TxId ==. txOut ^. V.TxOutTxId) - ) + ) `innerJoin` table @V.Address - `on` (\((_ :& txOut) :& address) -> txOut ^. V.TxOutAddressId ==. address ^. V.AddressId) + `on` (\((_ :& txOut) :& address) -> txOut ^. V.TxOutAddressId ==. address ^. V.AddressId) where_ (txOut ^. V.TxOutIndex ==. val index &&. tx ^. TxHash ==. val hash) pure (address ^. V.AddressPaymentCred, address ^. V.AddressHasScript) pure $ maybeToEither (DbLookupTxHash hash) unValue2 (listToMaybe res) @@ -217,7 +217,7 @@ queryAddressId addrRaw = do -- does not include staking rewards that have not yet been withdrawn. Before wihdrawal -- rewards are part of the ledger state and hence not on chain. queryTotalSupply :: - (MonadIO m) => + MonadIO m => TxOutTableType -> ReaderT SqlBackend m Ada queryTotalSupply txOutTableType = @@ -242,7 +242,7 @@ queryTotalSupply txOutTableType = -- | Return the total Genesis coin supply. queryGenesisSupply :: - (MonadIO m) => + MonadIO m => TxOutTableType -> ReaderT SqlBackend m Ada queryGenesisSupply txOutTableType = @@ -257,12 +257,12 @@ queryGenesisSupply txOutTableType = query = do res <- select $ do (_tx :& txOut :& blk) <- - from - $ table @Tx + from $ + table @Tx `innerJoin` table @(TxOutTable a) - `on` (\(tx :& txOut) -> tx ^. TxId ==. txOut ^. txOutTxIdField @a) + `on` (\(tx :& txOut) -> tx ^. TxId ==. txOut ^. txOutTxIdField @a) `innerJoin` table @Block - `on` (\(tx :& _txOut :& blk) -> tx ^. TxBlockId ==. blk ^. BlockId) + `on` (\(tx :& _txOut :& blk) -> tx ^. TxBlockId ==. blk ^. BlockId) where_ (isNothing $ blk ^. BlockPreviousId) pure $ sum_ (txOut ^. txOutValueField @a) pure $ unValueSumAda (listToMaybe res) @@ -303,12 +303,12 @@ queryShelleyGenesisSupply txOutTableType = query = do res <- select $ do (txOut :& _tx :& blk) <- - from - $ table @(TxOutTable a) + from $ + table @(TxOutTable a) `innerJoin` table @Tx - `on` (\(txOut :& tx) -> tx ^. TxId ==. txOut ^. txOutTxIdField @a) + `on` (\(txOut :& tx) -> tx ^. TxId ==. txOut ^. txOutTxIdField @a) `innerJoin` table @Block - `on` (\(_txOut :& tx :& blk) -> tx ^. TxBlockId ==. blk ^. BlockId) + `on` (\(_txOut :& tx :& blk) -> tx ^. TxBlockId ==. blk ^. BlockId) where_ (isJust $ blk ^. BlockPreviousId) where_ (isNothing $ blk ^. BlockEpochNo) pure $ sum_ (txOut ^. txOutValueField @a) @@ -353,19 +353,19 @@ queryUtxoAtBlockIdCore :: MonadIO m => BlockId -> ReaderT SqlBackend m [UtxoQuer queryUtxoAtBlockIdCore blkid = do outputs <- select $ do (txout :& _txin :& _tx1 :& blk :& tx2) <- - from - $ table @C.TxOut + from $ + table @C.TxOut `leftJoin` table @TxIn - `on` ( \(txout :& txin) -> - (just (txout ^. C.TxOutTxId) ==. txin ?. TxInTxOutId) - &&. (just (txout ^. C.TxOutIndex) ==. txin ?. TxInTxOutIndex) - ) + `on` ( \(txout :& txin) -> + (just (txout ^. C.TxOutTxId) ==. txin ?. TxInTxOutId) + &&. (just (txout ^. C.TxOutIndex) ==. txin ?. TxInTxOutIndex) + ) `leftJoin` table @Tx - `on` (\(_txout :& txin :& tx1) -> txin ?. TxInTxInId ==. tx1 ?. TxId) + `on` (\(_txout :& txin :& tx1) -> txin ?. TxInTxInId ==. tx1 ?. TxId) `leftJoin` table @Block - `on` (\(_txout :& _txin :& tx1 :& blk) -> tx1 ?. TxBlockId ==. blk ?. BlockId) + `on` (\(_txout :& _txin :& tx1 :& blk) -> tx1 ?. TxBlockId ==. blk ?. BlockId) `leftJoin` table @Tx - `on` (\(txout :& _ :& _ :& _ :& tx2) -> just (txout ^. C.TxOutTxId) ==. tx2 ?. TxId) + `on` (\(txout :& _ :& _ :& _ :& tx2) -> just (txout ^. C.TxOutTxId) ==. tx2 ?. TxId) where_ $ (txout ^. C.TxOutTxId `in_` txLessEqual blkid) @@ -377,21 +377,21 @@ queryUtxoAtBlockIdVariant :: MonadIO m => BlockId -> ReaderT SqlBackend m [UtxoQ queryUtxoAtBlockIdVariant blkid = do outputs <- select $ do (txout :& _txin :& _tx1 :& blk :& tx2 :& address) <- - from - $ table @V.TxOut + from $ + table @V.TxOut `leftJoin` table @TxIn - `on` ( \(txout :& txin) -> - (just (txout ^. V.TxOutTxId) ==. txin ?. TxInTxOutId) - &&. (just (txout ^. V.TxOutIndex) ==. txin ?. TxInTxOutIndex) - ) + `on` ( \(txout :& txin) -> + (just (txout ^. V.TxOutTxId) ==. txin ?. TxInTxOutId) + &&. (just (txout ^. V.TxOutIndex) ==. txin ?. TxInTxOutIndex) + ) `leftJoin` table @Tx - `on` (\(_txout :& txin :& tx1) -> txin ?. TxInTxInId ==. tx1 ?. TxId) + `on` (\(_txout :& txin :& tx1) -> txin ?. TxInTxInId ==. tx1 ?. TxId) `leftJoin` table @Block - `on` (\(_txout :& _txin :& tx1 :& blk) -> tx1 ?. TxBlockId ==. blk ?. BlockId) + `on` (\(_txout :& _txin :& tx1 :& blk) -> tx1 ?. TxBlockId ==. blk ?. BlockId) `leftJoin` table @Tx - `on` (\(txout :& _ :& _ :& _ :& tx2) -> just (txout ^. V.TxOutTxId) ==. tx2 ?. TxId) + `on` (\(txout :& _ :& _ :& _ :& tx2) -> just (txout ^. V.TxOutTxId) ==. tx2 ?. TxId) `innerJoin` table @V.Address - `on` (\(txout :& _ :& _ :& _ :& _ :& address) -> txout ^. V.TxOutAddressId ==. address ^. V.AddressId) + `on` (\(txout :& _ :& _ :& _ :& _ :& address) -> txout ^. V.TxOutAddressId ==. address ^. V.AddressId) where_ $ (txout ^. V.TxOutTxId `in_` txLessEqual blkid) @@ -438,16 +438,16 @@ queryAddressBalanceAtSlot txOutTableType addr slotNo = do TxOutCore -> do res <- select $ do (txout :& _ :& _ :& blk :& _) <- - from - $ table @C.TxOut + from $ + table @C.TxOut `leftJoin` table @TxIn - `on` (\(txout :& txin) -> just (txout ^. C.TxOutTxId) ==. txin ?. TxInTxOutId) + `on` (\(txout :& txin) -> just (txout ^. C.TxOutTxId) ==. txin ?. TxInTxOutId) `leftJoin` table @Tx - `on` (\(_ :& txin :& tx1) -> txin ?. TxInTxInId ==. tx1 ?. TxId) + `on` (\(_ :& txin :& tx1) -> txin ?. TxInTxInId ==. tx1 ?. TxId) `leftJoin` table @Block - `on` (\(_ :& _ :& tx1 :& blk) -> tx1 ?. TxBlockId ==. blk ?. BlockId) + `on` (\(_ :& _ :& tx1 :& blk) -> tx1 ?. TxBlockId ==. blk ?. BlockId) `leftJoin` table @Tx - `on` (\(txout :& _ :& _ :& _ :& tx2) -> just (txout ^. C.TxOutTxId) ==. tx2 ?. TxId) + `on` (\(txout :& _ :& _ :& _ :& tx2) -> just (txout ^. C.TxOutTxId) ==. tx2 ?. TxId) where_ $ (txout ^. C.TxOutTxId `in_` txLessEqual blkid) &&. (isNothing (blk ?. BlockBlockNo) ||. (blk ?. BlockId >. just (val blkid))) @@ -457,18 +457,18 @@ queryAddressBalanceAtSlot txOutTableType addr slotNo = do TxOutVariantAddress -> do res <- select $ do (txout :& _ :& _ :& blk :& _ :& address) <- - from - $ table @V.TxOut + from $ + table @V.TxOut `leftJoin` table @TxIn - `on` (\(txout :& txin) -> just (txout ^. V.TxOutTxId) ==. txin ?. TxInTxOutId) + `on` (\(txout :& txin) -> just (txout ^. V.TxOutTxId) ==. txin ?. TxInTxOutId) `leftJoin` table @Tx - `on` (\(_ :& txin :& tx1) -> txin ?. TxInTxInId ==. tx1 ?. TxId) + `on` (\(_ :& txin :& tx1) -> txin ?. TxInTxInId ==. tx1 ?. TxId) `leftJoin` table @Block - `on` (\(_ :& _ :& tx1 :& blk) -> tx1 ?. TxBlockId ==. blk ?. BlockId) + `on` (\(_ :& _ :& tx1 :& blk) -> tx1 ?. TxBlockId ==. blk ?. BlockId) `leftJoin` table @Tx - `on` (\(txout :& _ :& _ :& _ :& tx2) -> just (txout ^. V.TxOutTxId) ==. tx2 ?. TxId) + `on` (\(txout :& _ :& _ :& _ :& tx2) -> just (txout ^. V.TxOutTxId) ==. tx2 ?. TxId) `innerJoin` table @V.Address - `on` (\(txout :& _ :& _ :& _ :& _ :& address) -> txout ^. V.TxOutAddressId ==. address ^. V.AddressId) + `on` (\(txout :& _ :& _ :& _ :& _ :& address) -> txout ^. V.TxOutAddressId ==. address ^. V.AddressId) where_ $ (txout ^. V.TxOutTxId `in_` txLessEqual blkid) &&. (isNothing (blk ?. BlockBlockNo) ||. (blk ?. BlockId >. just (val blkid))) diff --git a/cardano-db/src/Cardano/Db/Operations/Types.hs b/cardano-db/src/Cardano/Db/Operations/Types.hs index 21d818870..b92aafcc0 100644 --- a/cardano-db/src/Cardano/Db/Operations/Types.hs +++ b/cardano-db/src/Cardano/Db/Operations/Types.hs @@ -116,7 +116,7 @@ data MaTxOutIdW deriving (Show) -- MaTxOut fields for a given TxOutTableType -class (PersistEntity (MaTxOutTable a)) => MaTxOutFields (a :: TxOutTableType) where +class PersistEntity (MaTxOutTable a) => MaTxOutFields (a :: TxOutTableType) where type MaTxOutTable a :: Type type MaTxOutIdFor a :: Type maTxOutTxOutIdField :: EntityField (MaTxOutTable a) (TxOutIdFor a) @@ -160,7 +160,7 @@ data CollateralTxOutIdW | VCollateralTxOutIdW !V.CollateralTxOutId deriving (Show) -class (PersistEntity (CollateralTxOutTable a)) => CollateralTxOutFields (a :: TxOutTableType) where +class PersistEntity (CollateralTxOutTable a) => CollateralTxOutFields (a :: TxOutTableType) where type CollateralTxOutTable a :: Type type CollateralTxOutIdFor a :: Type collateralTxOutIdField :: EntityField (CollateralTxOutTable a) (CollateralTxOutIdFor a) diff --git a/cardano-db/src/Cardano/Db/Version/V13_0/Query.hs b/cardano-db/src/Cardano/Db/Version/V13_0/Query.hs index 8463e72fd..89be4feef 100644 --- a/cardano-db/src/Cardano/Db/Version/V13_0/Query.hs +++ b/cardano-db/src/Cardano/Db/Version/V13_0/Query.hs @@ -86,14 +86,14 @@ querydatumInfo :: MonadIO m => DatumId -> ReaderT SqlBackend m (Maybe (ByteStrin querydatumInfo datumId = do res <- select $ do (_blk :& _tx :& datum :& prevBlock) <- - from - $ table @Block + from $ + table @Block `innerJoin` table @Tx - `on` (\(blk :& tx) -> tx ^. TxBlockId ==. blk ^. BlockId) + `on` (\(blk :& tx) -> tx ^. TxBlockId ==. blk ^. BlockId) `innerJoin` table @Datum - `on` (\(_blk :& tx :& datum) -> datum ^. DatumTxId ==. tx ^. TxId) + `on` (\(_blk :& tx :& datum) -> datum ^. DatumTxId ==. tx ^. TxId) `innerJoin` table @Block - `on` (\(blk :& _tx :& _datum :& prevBlk) -> blk ^. BlockPreviousId ==. just (prevBlk ^. BlockId)) + `on` (\(blk :& _tx :& _datum :& prevBlk) -> blk ^. BlockPreviousId ==. just (prevBlk ^. BlockId)) where_ (datum ^. DatumId ==. val datumId) pure (prevBlock ^. BlockHash, prevBlock ^. BlockSlotNo) pure $ unValue2 <$> listToMaybe res @@ -126,14 +126,14 @@ queryRedeemerDataInfo :: MonadIO m => RedeemerDataId -> ReaderT SqlBackend m (Ma queryRedeemerDataInfo rdmDataId = do res <- select $ do (_blk :& _tx :& rdmData :& prevBlock) <- - from - $ table @Block + from $ + table @Block `innerJoin` table @Tx - `on` (\(blk :& tx) -> tx ^. TxBlockId ==. blk ^. BlockId) + `on` (\(blk :& tx) -> tx ^. TxBlockId ==. blk ^. BlockId) `innerJoin` table @RedeemerData - `on` (\(_blk :& tx :& rdmData) -> rdmData ^. RedeemerDataTxId ==. tx ^. TxId) + `on` (\(_blk :& tx :& rdmData) -> rdmData ^. RedeemerDataTxId ==. tx ^. TxId) `innerJoin` table @Block - `on` (\(blk :& _tx :& _rdmData :& prevBlk) -> blk ^. BlockPreviousId ==. just (prevBlk ^. BlockId)) + `on` (\(blk :& _tx :& _rdmData :& prevBlk) -> blk ^. BlockPreviousId ==. just (prevBlk ^. BlockId)) where_ (rdmData ^. RedeemerDataId ==. val rdmDataId) pure (prevBlock ^. BlockHash, prevBlock ^. BlockSlotNo) pure $ unValue2 <$> listToMaybe res @@ -169,14 +169,14 @@ queryScriptInfo :: MonadIO m => ScriptId -> ReaderT SqlBackend m (Maybe (ByteStr queryScriptInfo scriptId = do res <- select $ do (_blk :& _tx :& scr :& prevBlock) <- - from - $ table @Block + from $ + table @Block `innerJoin` table @Tx - `on` (\(blk :& tx) -> tx ^. TxBlockId ==. blk ^. BlockId) + `on` (\(blk :& tx) -> tx ^. TxBlockId ==. blk ^. BlockId) `innerJoin` table @Script - `on` (\(_blk :& tx :& scr) -> scr ^. ScriptTxId ==. tx ^. TxId) + `on` (\(_blk :& tx :& scr) -> scr ^. ScriptTxId ==. tx ^. TxId) `innerJoin` table @Block - `on` (\(blk :& _tx :& _scr :& prevBlk) -> blk ^. BlockPreviousId ==. just (prevBlk ^. BlockId)) + `on` (\(blk :& _tx :& _scr :& prevBlk) -> blk ^. BlockPreviousId ==. just (prevBlk ^. BlockId)) where_ (scr ^. ScriptType ==. val PlutusV1 ||. scr ^. ScriptType ==. val PlutusV2) where_ (scr ^. ScriptId ==. val scriptId) pure (prevBlock ^. BlockHash, prevBlock ^. BlockSlotNo) diff --git a/cardano-smash-server/app/cardano-smash-server.hs b/cardano-smash-server/app/cardano-smash-server.hs index e099e6b83..817133fa8 100644 --- a/cardano-smash-server/app/cardano-smash-server.hs +++ b/cardano-smash-server/app/cardano-smash-server.hs @@ -108,14 +108,15 @@ pVersionCommand = command' :: String -> String -> Parser a -> Opt.Mod Opt.CommandFields a command' c descr p = - Opt.command c $ - Opt.info (p <**> Opt.helper) $ - mconcat [Opt.progDesc descr] + Opt.command c + $ Opt.info (p <**> Opt.helper) + $ mconcat [Opt.progDesc descr] runVersionCommand :: IO () runVersionCommand = do - liftIO . putTextLn $ - mconcat + liftIO + . putTextLn + $ mconcat [ "cardano-smash-server " , renderVersion version , " - " diff --git a/cardano-smash-server/src/Cardano/SMASH/Server/Config.hs b/cardano-smash-server/src/Cardano/SMASH/Server/Config.hs index 07068ecd3..d9563fbcc 100644 --- a/cardano-smash-server/src/Cardano/SMASH/Server/Config.hs +++ b/cardano-smash-server/src/Cardano/SMASH/Server/Config.hs @@ -45,8 +45,8 @@ paramsToConfig params = do appUsers <- readAppUsers $ sspAdminUsers params tracer <- configureLogging (sspConfigFile params) "smash-server" - pure $ - SmashServerConfig + pure + $ SmashServerConfig { sscSmashPort = sspSmashPort params , sscTrace = tracer , sscAdmins = appUsers diff --git a/cardano-smash-server/src/Cardano/SMASH/Server/FetchPolicies.hs b/cardano-smash-server/src/Cardano/SMASH/Server/FetchPolicies.hs index c39234c32..4faa37d2d 100644 --- a/cardano-smash-server/src/Cardano/SMASH/Server/FetchPolicies.hs +++ b/cardano-smash-server/src/Cardano/SMASH/Server/FetchPolicies.hs @@ -92,8 +92,8 @@ httpApiCall request = do let httpStatusCode = getResponseStatusCode httpResult - when (httpStatusCode /= 200) $ - left HttpClientStatusNotOk + when (httpStatusCode /= 200) + $ left HttpClientStatusNotOk case parseEither parseJSON httpResponse of Left reason -> left $ HttpClientCannotParseJSON (toS reason) diff --git a/cardano-smash-server/src/Cardano/SMASH/Server/Impl.hs b/cardano-smash-server/src/Cardano/SMASH/Server/Impl.hs index 3a61ef183..b31efe11d 100644 --- a/cardano-smash-server/src/Cardano/SMASH/Server/Impl.hs +++ b/cardano-smash-server/src/Cardano/SMASH/Server/Impl.hs @@ -59,15 +59,15 @@ todoSwagger = , _infoDescription = Just "Stakepool Metadata Aggregation Server" , _infoTermsOfService = Nothing , _infoContact = - Just $ - Contact + Just + $ Contact { _contactName = Just "IOHK" , _contactUrl = Just $ URL "https://iohk.io/" , _contactEmail = Just "operations@iohk.io" } , _infoLicense = - Just $ - License + Just + $ License { _licenseName = "APACHE2" , _licenseUrl = Just $ URL "https://github.com/IntersectMBO/cardano-db-sync/blob/master/LICENSE" } @@ -119,8 +119,10 @@ getOffChainPoolMetadata (ServerEnv trce dataLayer) poolId poolMetaHash = -- | Simple health status, there are ideas for improvement. getHealthStatus :: Handler (ApiResult DBFail HealthStatus) getHealthStatus = - pure . ApiResult . Right $ - HealthStatus + pure + . ApiResult + . Right + $ HealthStatus { hsStatus = "OK" , hsVersion = toS $ showVersion version } diff --git a/cardano-smash-server/src/Cardano/SMASH/Server/PoolDataLayer.hs b/cardano-smash-server/src/Cardano/SMASH/Server/PoolDataLayer.hs index 71eee155d..7453c7ec8 100644 --- a/cardano-smash-server/src/Cardano/SMASH/Server/PoolDataLayer.hs +++ b/cardano-smash-server/src/Cardano/SMASH/Server/PoolDataLayer.hs @@ -59,15 +59,16 @@ postgresqlPoolDataLayer tracer conn = pure $ fmap (\ticker -> (TickerName $ Db.reservedPoolTickerName ticker, dbToServantPoolId $ Db.reservedPoolTickerPoolHash ticker)) tickers , dlAddReservedTicker = \ticker poolId -> do inserted <- - Db.runPoolDbIohkLogging conn tracer $ - Db.insertReservedPoolTicker $ - Db.ReservedPoolTicker (getTickerName ticker) (servantToDbPoolId poolId) + Db.runPoolDbIohkLogging conn tracer + $ Db.insertReservedPoolTicker + $ Db.ReservedPoolTicker (getTickerName ticker) (servantToDbPoolId poolId) case inserted of Just _ -> pure $ Right ticker Nothing -> pure $ Left $ TickerAlreadyReserved ticker , dlCheckReservedTicker = \ticker -> do - Db.runPoolDbIohkLogging conn tracer $ - fmap dbToServantPoolId <$> Db.queryReservedTicker (getTickerName ticker) + Db.runPoolDbIohkLogging conn tracer + $ fmap dbToServantPoolId + <$> Db.queryReservedTicker (getTickerName ticker) , dlGetDelistedPools = do fmap dbToServantPoolId <$> Db.runPoolDbIohkLogging conn tracer Db.queryDelistedPools , dlCheckDelistedPool = \poolHash -> do @@ -83,8 +84,8 @@ postgresqlPoolDataLayer tracer conn = pure $ Right poolHash , dlRemoveDelistedPool = \poolHash -> do deleted <- - Db.runPoolDbIohkLogging conn tracer $ - Db.deleteDelistedPool (servantToDbPoolId poolHash) + Db.runPoolDbIohkLogging conn tracer + $ Db.deleteDelistedPool (servantToDbPoolId poolHash) if deleted then pure $ Right poolHash else pure $ Left RecordDoesNotExist @@ -97,8 +98,8 @@ postgresqlPoolDataLayer tracer conn = pure $ Right $ dbToServantPoolId <$> ls , dlGetFetchErrors = \poolId mTimeFrom -> do fetchErrors <- - Db.runPoolDbIohkLogging conn tracer $ - Db.queryOffChainPoolFetchError (servantToDbPoolId poolId) mTimeFrom + Db.runPoolDbIohkLogging conn tracer + $ Db.queryOffChainPoolFetchError (servantToDbPoolId poolId) mTimeFrom pure $ Right $ dbToServantFetchError poolId <$> fetchErrors , dlGetPool = \poolId -> do isActive <- isPoolActive tracer conn poolId diff --git a/cardano-smash-server/src/Cardano/SMASH/Server/Run.hs b/cardano-smash-server/src/Cardano/SMASH/Server/Run.hs index 7d5e1c99f..4ad480748 100644 --- a/cardano-smash-server/src/Cardano/SMASH/Server/Run.hs +++ b/cardano-smash-server/src/Cardano/SMASH/Server/Run.hs @@ -36,8 +36,8 @@ runSmashServer :: SmashServerConfig -> IO () runSmashServer config = do let trce = sscTrace config let settings = - setPort (sscSmashPort config) $ - setBeforeMainLoop + setPort (sscSmashPort config) + $ setBeforeMainLoop (logInfo trce $ "SMASH listening on port " <> textShow (sscSmashPort config)) defaultSettings @@ -53,8 +53,8 @@ mkApp trce dataLayer appUsers = do -- You can always run the migrations first. threadDelay 2_000_000 - pure $ - serveWithContext + pure + $ serveWithContext fullAPI (basicAuthServerContext appUsers) (server $ ServerEnv trce dataLayer) @@ -91,8 +91,8 @@ checkIfUserValid (ApplicationUsers applicationUsers) applicationUser@(Applicatio runAppStubbed :: Trace IO Text -> Int -> IO () runAppStubbed trce port = do let settings = - setPort port $ - setBeforeMainLoop + setPort port + $ setBeforeMainLoop (hPutStrLn stderr ("SMASH-stubbed listening on port " ++ show port)) defaultSettings @@ -102,8 +102,8 @@ mkAppStubbed :: Trace IO Text -> IO Application mkAppStubbed trce = do dataLayer <- createCachedPoolDataLayer Nothing - pure $ - serveWithContext + pure + $ serveWithContext fullAPI (basicAuthServerContext stubbedApplicationUsers) (server $ ServerEnv trce dataLayer) diff --git a/cardano-smash-server/src/Cardano/SMASH/Server/Types.hs b/cardano-smash-server/src/Cardano/SMASH/Server/Types.hs index 23cae379b..ead9417c9 100644 --- a/cardano-smash-server/src/Cardano/SMASH/Server/Types.hs +++ b/cardano-smash-server/src/Cardano/SMASH/Server/Types.hs @@ -290,11 +290,11 @@ validateTickerName name = do if tickerLen >= 3 && tickerLen <= 5 then Right $ TickerName name else - Left $ - "\"ticker\" must have at least 3 and at most 5 " - <> "characters, but it has " - <> show (length name) - <> " characters." + Left + $ "\"ticker\" must have at least 3 and at most 5 " + <> "characters, but it has " + <> show (length name) + <> " characters." instance ToParamSchema TickerName