From da85cb3da9ba53dedda91427d804f4ff06030f68 Mon Sep 17 00:00:00 2001 From: John Ky Date: Thu, 29 Sep 2022 00:05:06 +1000 Subject: [PATCH 01/11] Type application symbol @ should not be followed with space --- .../src/Cardano/Benchmarking/FundSet.hs | 95 +++++++++ .../src/Cardano/Benchmarking/GeneratorTx.hs | 31 +++ .../Benchmarking/GeneratorTx/SizedMetadata.hs | 8 +- .../GeneratorTx/SubmissionClient.hs | 2 +- .../Cardano/Benchmarking/GeneratorTx/Tx.hs | 110 ++++++++++ .../src/Cardano/Benchmarking/Script/Core.hs | 43 +++- .../src/Cardano/Benchmarking/Wallet.hs | 192 ++++++++++++++++++ cardano-api/src/Cardano/Api/LedgerEvent.hs | 2 +- cardano-api/test/Test/Cardano/Api/Crypto.hs | 6 +- cardano-node/src/Cardano/Node/Queries.hs | 2 +- .../src/Cardano/Node/Tracing/Era/HardFork.hs | 22 +- .../Tracing/OrphanInstances/HardFork.hs | 24 +-- cardano-node/src/Cardano/Tracing/Tracers.hs | 2 +- 13 files changed, 499 insertions(+), 40 deletions(-) create mode 100644 bench/tx-generator/src/Cardano/Benchmarking/FundSet.hs create mode 100644 bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Tx.hs diff --git a/bench/tx-generator/src/Cardano/Benchmarking/FundSet.hs b/bench/tx-generator/src/Cardano/Benchmarking/FundSet.hs new file mode 100644 index 00000000000..88ee31fdea9 --- /dev/null +++ b/bench/tx-generator/src/Cardano/Benchmarking/FundSet.hs @@ -0,0 +1,95 @@ +{-# OPTIONS_GHC -Wwarn #-} +{-# Language DataKinds #-} +{-# Language FlexibleInstances #-} +{-# Language GADTs #-} +{-# Language MultiParamTypeClasses #-} +{-# Language RankNTypes #-} +{-# Language TypeApplications #-} +{-# Language ScopedTypeVariables #-} + +module Cardano.Benchmarking.FundSet +where +import Prelude + +import Cardano.Api as Api + +import Cardano.Benchmarking.Fifo as Fifo + +-- Outputs that are available for spending. +-- When building a new TX they provide the TxIn parts. + +data FundInEra era = FundInEra { + _fundTxIn :: !TxIn + , _fundWitness :: Witness WitCtxTxIn era + , _fundVal :: !(TxOutValue era) + , _fundSigningKey :: !(Maybe (SigningKey PaymentKey)) + } deriving (Show) + +newtype Fund = Fund {unFund :: InAnyCardanoEra FundInEra} + +type FundSet = Fifo Fund + +type FundSource m = m (Either String [Fund]) +type FundToStore m = Fund -> m () +type FundToStoreList m = [Fund] -> m () + +getFundTxIn :: Fund -> TxIn +getFundTxIn (Fund (InAnyCardanoEra _ a)) = _fundTxIn a + +getFundKey :: Fund -> Maybe (SigningKey PaymentKey) +getFundKey (Fund (InAnyCardanoEra _ a)) = _fundSigningKey a + +getFundLovelace :: Fund -> Lovelace +getFundLovelace (Fund (InAnyCardanoEra _ a)) = case _fundVal a of + TxOutAdaOnly _era l -> l + TxOutValue _era v -> selectLovelace v + +-- This effectively rules out era-transitions for transactions ! +-- This is not what we want !! +getFundWitness :: forall era. IsShelleyBasedEra era => Fund -> Witness WitCtxTxIn era +getFundWitness fund = case (cardanoEra @era, fund) of + (ByronEra , Fund (InAnyCardanoEra ByronEra a)) -> _fundWitness a + (ShelleyEra , Fund (InAnyCardanoEra ShelleyEra a)) -> _fundWitness a + (AllegraEra , Fund (InAnyCardanoEra AllegraEra a)) -> _fundWitness a + (MaryEra , Fund (InAnyCardanoEra MaryEra a)) -> _fundWitness a + (AlonzoEra , Fund (InAnyCardanoEra AlonzoEra a)) -> _fundWitness a + (BabbageEra , Fund (InAnyCardanoEra BabbageEra a)) -> _fundWitness a +-- This effectively rules out era-transitions for transactions ! +-- This is not what we want !! +-- It should be possible to cast KeyWitnesses from one era to an other ! + (_ , _) -> error "getFundWitness: era mismatch" + +instance Show Fund where + show (Fund (InAnyCardanoEra _ f)) = show f + +-- TxIn/fundTxOut is the primary key. +-- There must be no two entries for the same TxIn !. + +instance Eq Fund where + (==) a b = getFundTxIn a == getFundTxIn b + +instance Ord Fund where + compare a b = compare (getFundTxIn a) (getFundTxIn b) + +emptyFundSet :: FundSet +emptyFundSet = Fifo.emptyFifo + +insertFund :: FundSet -> Fund -> FundSet +insertFund = Fifo.insert + +liftAnyEra :: ( forall era. IsCardanoEra era => f1 era -> f2 era ) -> InAnyCardanoEra f1 -> InAnyCardanoEra f2 +liftAnyEra f x = case x of + InAnyCardanoEra ByronEra a -> InAnyCardanoEra ByronEra $ f a + InAnyCardanoEra ShelleyEra a -> InAnyCardanoEra ShelleyEra $ f a + InAnyCardanoEra AllegraEra a -> InAnyCardanoEra AllegraEra $ f a + InAnyCardanoEra MaryEra a -> InAnyCardanoEra MaryEra $ f a + InAnyCardanoEra AlonzoEra a -> InAnyCardanoEra AlonzoEra $ f a + InAnyCardanoEra BabbageEra a -> InAnyCardanoEra BabbageEra $ f a + +-- Todo: check sufficient funds and minimumValuePerUtxo +inputsToOutputsWithFee :: Lovelace -> Int -> [Lovelace] -> [Lovelace] +inputsToOutputsWithFee fee count inputs = map (quantityToLovelace . Quantity) outputs + where + (Quantity totalAvailable) = lovelaceToQuantity $ sum inputs - fee + (out, rest) = divMod totalAvailable (fromIntegral count) + outputs = (out + rest) : replicate (count-1) out diff --git a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx.hs b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx.hs index 4ca178880ca..eb939018d29 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx.hs @@ -52,6 +52,37 @@ readSigningKey = , FromSomeType (AsSigningKey AsPaymentKey) id ] +secureGenesisFund :: forall era. IsShelleyBasedEra era + => Tracer IO (TraceBenchTxSubmit TxId) + -> (TxInMode CardanoMode -> IO (SubmitResult (TxValidationErrorInMode CardanoMode))) + -> NetworkId + -> ShelleyGenesis StandardShelley + -> Lovelace + -> SlotNo + -> SigningKey PaymentKey + -> AddressInEra era + -> ExceptT TxGenError IO Fund +secureGenesisFund submitTracer localSubmitTx networkId genesis txFee ttl key outAddr = do + let (_inAddr, lovelace) = genesisFundForKey @era networkId genesis key + (tx, fund) = + genesisExpenditure networkId key outAddr lovelace txFee ttl + r <- liftIO $ + catches (localSubmitTx $ txInModeCardano tx) + [ Handler $ \e@SomeException{} -> + fail $ mconcat + [ "Exception while moving genesis funds via local socket: " + , show e + ]] + case r of + SubmitSuccess -> + liftIO . traceWith submitTracer . TraceBenchTxSubDebug + $ mconcat + [ "******* Funding secured (" + , show $ fundTxIn fund, " -> ", show $ fundAdaValue fund + , ")"] + SubmitFail e -> fail $ show e + return fund + type AsyncBenchmarkControl = (Async (), [Async ()], IO SubmissionSummary, IO ()) waitBenchmark :: Tracer IO (TraceBenchTxSubmit TxId) -> AsyncBenchmarkControl -> ExceptT TxGenError IO () diff --git a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SizedMetadata.hs b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SizedMetadata.hs index ff0c23a585b..e51c3d32986 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SizedMetadata.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SizedMetadata.hs @@ -57,7 +57,7 @@ assumeMapCosts _proxy = stepFunction [ , ( 744 , 4) -- 744 entries at 4 bytes. ] where - firstEntry = case shelleyBasedEra @ era of + firstEntry = case shelleyBasedEra @era of ShelleyBasedEraShelley -> 37 ShelleyBasedEraAllegra -> 39 ShelleyBasedEraMary -> 39 @@ -128,11 +128,11 @@ dummyTxSizeInEra metadata = case createAndValidateTransactionBody dummyTx of } dummyTxSize :: forall era . IsShelleyBasedEra era => AsType era -> Maybe TxMetadata -> Int -dummyTxSize _p m = (dummyTxSizeInEra @ era) $ metadataInEra m +dummyTxSize _p m = (dummyTxSizeInEra @era) $ metadataInEra m metadataInEra :: forall era . IsShelleyBasedEra era => Maybe TxMetadata -> TxMetadataInEra era metadataInEra Nothing = TxMetadataNone -metadataInEra (Just m) = case txMetadataSupportedInEra (cardanoEra @ era) of +metadataInEra (Just m) = case txMetadataSupportedInEra (cardanoEra @era) of Nothing -> error "unreachable" Just e -> TxMetadataInEra e m @@ -143,7 +143,7 @@ mkMetadata size then Left $ "Error : metadata must be 0 or at least " ++ show minSize ++ " bytes in this era." else Right $ metadataInEra $ Just metadata where - minSize = case shelleyBasedEra @ era of + minSize = case shelleyBasedEra @era of ShelleyBasedEraShelley -> 37 ShelleyBasedEraAllegra -> 39 ShelleyBasedEraMary -> 39 diff --git a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SubmissionClient.hs b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SubmissionClient.hs index d6b4500b058..4d7b1ca8d32 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SubmissionClient.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/SubmissionClient.hs @@ -186,7 +186,7 @@ txSubmissionClient tr bmtr initialTxSource endOfProtocolCallback = txToIdSize = (Mempool.txId &&& txInBlockSize) . toGenTx toGenTx :: tx -> GenTx CardanoBlock - toGenTx tx = case shelleyBasedEra @ era of + toGenTx tx = case shelleyBasedEra @era of ShelleyBasedEraShelley -> toConsensusGenTx $ TxInMode tx ShelleyEraInCardanoMode ShelleyBasedEraAllegra -> toConsensusGenTx $ TxInMode tx AllegraEraInCardanoMode ShelleyBasedEraMary -> toConsensusGenTx $ TxInMode tx MaryEraInCardanoMode diff --git a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Tx.hs b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Tx.hs new file mode 100644 index 00000000000..a0e891fc5f4 --- /dev/null +++ b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Tx.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-all-missed-specialisations #-} + +module Cardano.Benchmarking.GeneratorTx.Tx + ( Fund + , fundTxIn + , fundAdaValue + , keyAddress + , mkGenesisTransaction + , mkFund + , mkFee + , mkTxOutValueAdaOnly + , mkValidityUpperBound + , txOutValueToLovelace + , txInModeCardano + ) +where + +import Prelude +import Cardano.Benchmarking.Types (TxAdditionalSize (..)) + +import Cardano.Api + +type Fund = (TxIn, InAnyCardanoEra TxOutValue) + +mkFund :: forall era. IsCardanoEra era => TxIn -> TxOutValue era -> Fund +mkFund txIn val = (txIn, InAnyCardanoEra cardanoEra val) + +fundTxIn :: Fund -> TxIn +fundTxIn (x,_) = x + +fundAdaValue :: Fund -> Lovelace +fundAdaValue (_, InAnyCardanoEra _ txOut) = txOutValueToLovelace txOut + +keyAddress :: forall era. IsShelleyBasedEra era => NetworkId -> SigningKey PaymentKey -> AddressInEra era +keyAddress networkId k + = makeShelleyAddressInEra + networkId + (PaymentCredentialByKey $ verificationKeyHash $ getVerificationKey k) + NoStakeAddress + +--{-# DEPRECATED mkGenesisTransaction "to be removed" #-} +mkGenesisTransaction :: forall era . + IsShelleyBasedEra era + => SigningKey GenesisUTxOKey + -> TxAdditionalSize + -> SlotNo + -> Lovelace + -> [TxIn] + -> [TxOut CtxTx era] + -> Tx era +mkGenesisTransaction key _payloadSize ttl fee txins txouts + = case makeTransactionBody txBodyContent of + Right b -> signShelleyTransaction b [WitnessGenesisUTxOKey key] + Left err -> error $ show err + where + txBodyContent = TxBodyContent { + txIns = zip txins $ repeat $ BuildTxWith $ KeyWitness KeyWitnessForSpending + , txInsCollateral = TxInsCollateralNone + , txInsReference = TxInsReferenceNone + , txOuts = txouts + , txFee = mkFee fee + , txValidityRange = (TxValidityNoLowerBound, validityUpperBound) + , txMetadata = TxMetadataNone + , txAuxScripts = TxAuxScriptsNone + , txExtraKeyWits = TxExtraKeyWitnessesNone + , txProtocolParams = BuildTxWith Nothing + , txWithdrawals = TxWithdrawalsNone + , txCertificates = TxCertificatesNone + , txUpdateProposal = TxUpdateProposalNone + , txMintValue = TxMintNone + , txScriptValidity = TxScriptValidityNone + , txReturnCollateral = TxReturnCollateralNone + , txTotalCollateral = TxTotalCollateralNone + } + validityUpperBound = case shelleyBasedEra @era of + ShelleyBasedEraShelley -> TxValidityUpperBound ValidityUpperBoundInShelleyEra ttl + ShelleyBasedEraAllegra -> TxValidityUpperBound ValidityUpperBoundInAllegraEra ttl + ShelleyBasedEraMary -> TxValidityUpperBound ValidityUpperBoundInMaryEra ttl + ShelleyBasedEraAlonzo -> TxValidityUpperBound ValidityUpperBoundInAlonzoEra ttl + ShelleyBasedEraBabbage -> TxValidityUpperBound ValidityUpperBoundInBabbageEra ttl + +mkFee :: forall era . + IsShelleyBasedEra era + => Lovelace + -> TxFee era +mkFee f = case txFeesExplicitInEra (cardanoEra @era) of + Right e -> TxFeeExplicit e f + Left b -> TxFeeImplicit b -- error "unreachable" + +mkValidityUpperBound :: forall era . + IsShelleyBasedEra era + => SlotNo + -> TxValidityUpperBound era +mkValidityUpperBound ttl = case validityUpperBoundSupportedInEra (cardanoEra @era) of + Just p -> TxValidityUpperBound p ttl + Nothing -> error "unreachable" + +mkTxOutValueAdaOnly :: forall era . IsShelleyBasedEra era => Lovelace -> TxOutValue era +mkTxOutValueAdaOnly l = case multiAssetSupportedInEra (cardanoEra @era) of + Right p -> TxOutValue p $ lovelaceToValue l + Left p -> TxOutAdaOnly p l + +txInModeCardano :: forall era . IsShelleyBasedEra era => Tx era -> TxInMode CardanoMode +txInModeCardano tx = case toEraInMode (cardanoEra @era) CardanoMode of + Just t -> TxInMode tx t + Nothing -> error "txInModeCardano :unreachable" diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs b/bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs index 32edd9563c0..e5cbd82a51b 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs @@ -112,7 +112,7 @@ addFund era wallet txIn lovelace keyName = do fundKey <- getName keyName let mkOutValue :: forall era. IsShelleyBasedEra era => AsType era -> ActionM (InAnyCardanoEra TxOutValue) - mkOutValue = \_ -> return $ InAnyCardanoEra (cardanoEra @ era) (lovelaceToTxOutValue lovelace) + mkOutValue = \_ -> return $ InAnyCardanoEra (cardanoEra @era) (lovelaceToTxOutValue lovelace) outValue <- withEra era mkOutValue addFundToWallet wallet txIn outValue fundKey @@ -354,8 +354,8 @@ selectCollateralFunds (Just walletName) = do collateralFunds <- liftIO ( askWalletRef cw FundQueue.toList ) >>= \case [] -> throwE $ WalletError "selectCollateralFunds: emptylist" l -> return l - case collateralSupportedInEra (cardanoEra @ era) of - Nothing -> throwE $ WalletError $ "selectCollateralFunds: collateral: era not supported :" ++ show (cardanoEra @ era) + case collateralSupportedInEra (cardanoEra @era) of + Nothing -> throwE $ WalletError $ "selectCollateralFunds: collateral: era not supported :" ++ show (cardanoEra @era) Just p -> return (TxInsCollateral p $ map getFundTxIn collateralFunds, collateralFunds) dumpToFile :: FilePath -> TxInMode CardanoMode -> ActionM () @@ -364,6 +364,37 @@ dumpToFile filePath tx = liftIO $ dumpToFileIO filePath tx dumpToFileIO :: FilePath -> TxInMode CardanoMode -> IO () dumpToFileIO filePath tx = appendFile filePath ('\n' : show tx) +importGenesisFund + :: AnyCardanoEra + -> WalletName + -> SubmitMode + -> KeyName + -> KeyName + -> ActionM () +importGenesisFund era wallet submitMode genesisKeyName destKey = do + tracer <- btTxSubmit_ <$> get BenchTracers + localSubmit <- case submitMode of + LocalSocket -> getLocalSubmitTx + NodeToNode _ -> throwE $ WalletError "NodeToNode mode not supported in importGenesisFund" + DumpToFile filePath -> return $ \tx -> dumpToFileIO filePath tx >> return SubmitSuccess + DiscardTX -> return $ \_ -> return SubmitSuccess + networkId <- getUser TNetworkId + genesis <- get Genesis + fee <- getUser TFee + ttl <- getUser TTTL + fundKey <- getName destKey + genesisKey <- getName genesisKeyName + let + coreCall :: forall era. IsShelleyBasedEra era => AsType era -> ExceptT TxGenError IO Store.Fund + coreCall _proxy = do + let addr = Core.keyAddress @era networkId fundKey + f <- GeneratorTx.secureGenesisFund tracer localSubmit networkId genesis fee ttl genesisKey addr + return (f, fundKey) + result <- liftCoreWithEra era coreCall + case result of + Left err -> liftTxGenError err + Right ((txIn, outVal), skey) -> addFundToWallet wallet txIn outVal skey + initWallet :: WalletName -> ActionM () initWallet name = liftIO Wallet.initWallet >>= setName name @@ -375,7 +406,7 @@ interpretPayMode payMode = do fundKey <- getName keyName walletRef <- getName destWallet return ( createAndStore (mkUTxOVariant networkId fundKey) (mkWalletFundStore walletRef) - , Text.unpack $ serialiseAddress $ Utils.keyAddress @ era networkId fundKey) + , Text.unpack $ serialiseAddress $ Utils.keyAddress @era networkId fundKey) PayToScript scriptSpec destWallet -> do walletRef <- getName destWallet (witness, script, scriptData, _scriptFee) <- makePlutusContext scriptSpec @@ -483,8 +514,8 @@ makePlutusContext scriptSpec = do PlutusScript PlutusScriptV1 script' = script scriptWitness :: ScriptWitness WitCtxTxIn era - scriptWitness = case scriptLanguageSupportedInEra (cardanoEra @ era) (PlutusScriptLanguage PlutusScriptV1) of - Nothing -> error $ "runPlutusBenchmark: Plutus V1 scriptlanguage not supported : in era" ++ show (cardanoEra @ era) + scriptWitness = case scriptLanguageSupportedInEra (cardanoEra @era) (PlutusScriptLanguage PlutusScriptV1) of + Nothing -> error $ "runPlutusBenchmark: Plutus V1 scriptlanguage not supported : in era" ++ show (cardanoEra @era) Just scriptLang -> PlutusScriptWitness scriptLang PlutusScriptV1 diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Wallet.hs b/bench/tx-generator/src/Cardano/Benchmarking/Wallet.hs index 45f6a910f45..32912e3ae4f 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/Wallet.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/Wallet.hs @@ -71,3 +71,195 @@ mangle fkts values worker (toUTxO, value, idx) = let (o, f ) = toUTxO value in (o, f idx) + +--TODO use Error monad +--TODO need to break this up +sourceToStoreTransaction :: + TxGenerator era + -> FundSource IO + -> ([Lovelace] -> split) + -> ToUTxOList era split + -> FundToStoreList IO --inline to ToUTxOList + -> IO (Either String (Tx era)) +sourceToStoreTransaction txGenerator fundSource inToOut mkTxOut fundToStore = do + fundSource >>= \case + Left err -> return $ Left err + Right inputFunds -> work inputFunds + where + work inputFunds = do + let + outValues = inToOut $ map getFundLovelace inputFunds + (outputs, toFunds) = mkTxOut outValues + case txGenerator inputFunds outputs of + Left err -> return $ Left err + Right (tx, txId) -> do + fundToStore $ toFunds txId + return $ Right tx + +sourceToStoreTransactionNew :: + TxGenerator era + -> FundSource IO + -> ([Lovelace] -> split) + -> CreateAndStoreList IO era split + -> IO (Either String (Tx era)) +sourceToStoreTransactionNew txGenerator fundSource valueSplitter toStore = do + fundSource >>= \case + Left err -> return $ Left err + Right inputFunds -> work inputFunds + where + work inputFunds = do + let + split = valueSplitter $ map getFundLovelace inputFunds + (outputs, storeAction) = toStore split + case txGenerator inputFunds outputs of + Left err -> return $ Left err + Right (tx, txId) -> do + storeAction txId + return $ Right tx + +includeChange :: Lovelace -> [Lovelace] -> [Lovelace] -> [Lovelace] +includeChange fee spend have = case compare changeValue 0 of + GT -> changeValue : spend + EQ -> spend + LT -> error "genTX: Bad transaction: insufficient funds" + where changeValue = sum have - sum spend - fee + +includeChangeNew :: Lovelace -> [Lovelace] -> [Lovelace] -> PayWithChange +includeChangeNew fee spend have = case compare changeValue 0 of + GT -> PayWithChange changeValue spend + EQ -> PayExact spend + LT -> error "genTX: Bad transaction: insufficient funds" + where changeValue = sum have - sum spend - fee + +mkUTxOVariant :: forall era. IsShelleyBasedEra era + => NetworkId + -> SigningKey PaymentKey + -> ToUTxO era +mkUTxOVariant networkId key value + = ( mkTxOut value + , mkNewFund value + ) + where + mkTxOut v = TxOut (keyAddress @era networkId key) (lovelaceToTxOutValue v) TxOutDatumNone ReferenceScriptNone + + mkNewFund :: Lovelace -> TxIx -> TxId -> Fund + mkNewFund val txIx txId = Fund $ InAnyCardanoEra (cardanoEra @era) $ FundInEra { + _fundTxIn = TxIn txId txIx + , _fundWitness = KeyWitness KeyWitnessForSpending + , _fundVal = lovelaceToTxOutValue val + , _fundSigningKey = Just key + } + +-- to be merged with mkUTxOVariant +mkUTxOScript :: forall era. + IsShelleyBasedEra era + => NetworkId + -> (Script PlutusScriptV1, ScriptData) + -> Witness WitCtxTxIn era + -> ToUTxO era +mkUTxOScript networkId (script, txOutDatum) witness value + = ( mkTxOut value + , mkNewFund value + ) + where + plutusScriptAddr = makeShelleyAddressInEra + networkId + (PaymentCredentialByScript $ hashScript script) + NoStakeAddress + + mkTxOut v = case scriptDataSupportedInEra (cardanoEra @era) of + Nothing -> error " mkUtxOScript scriptDataSupportedInEra==Nothing" + Just tag -> TxOut + plutusScriptAddr + (lovelaceToTxOutValue v) + (TxOutDatumHash tag $ hashScriptData txOutDatum) + ReferenceScriptNone + + mkNewFund :: Lovelace -> TxIx -> TxId -> Fund + mkNewFund val txIx txId = Fund $ InAnyCardanoEra (cardanoEra @era) $ FundInEra { + _fundTxIn = TxIn txId txIx + , _fundWitness = witness + , _fundVal = lovelaceToTxOutValue val + , _fundSigningKey = Nothing + } + +genTx :: forall era. IsShelleyBasedEra era => + ProtocolParameters + -> (TxInsCollateral era, [Fund]) + -> TxFee era + -> TxMetadataInEra era + -> TxGenerator era +genTx protocolParameters (collateral, collFunds) fee metadata inFunds outputs + = case makeTransactionBody txBodyContent of + Left err -> error $ show err + Right b -> Right ( signShelleyTransaction b $ map WitnessPaymentKey allKeys + , getTxId b + ) + where + allKeys = mapMaybe getFundKey $ inFunds ++ collFunds + txBodyContent = TxBodyContent { + txIns = map (\f -> (getFundTxIn f, BuildTxWith $ getFundWitness f)) inFunds + , txInsCollateral = collateral + , txInsReference = TxInsReferenceNone + , txOuts = outputs + , txFee = fee + , txValidityRange = (TxValidityNoLowerBound, upperBound) + , txMetadata = metadata + , txAuxScripts = TxAuxScriptsNone + , txExtraKeyWits = TxExtraKeyWitnessesNone + , txProtocolParams = BuildTxWith $ Just protocolParameters + , txWithdrawals = TxWithdrawalsNone + , txCertificates = TxCertificatesNone + , txUpdateProposal = TxUpdateProposalNone + , txMintValue = TxMintNone + , txScriptValidity = TxScriptValidityNone + , txReturnCollateral = TxReturnCollateralNone + , txTotalCollateral = TxTotalCollateralNone + } + + upperBound :: TxValidityUpperBound era + upperBound = case shelleyBasedEra @era of + ShelleyBasedEraShelley -> TxValidityUpperBound ValidityUpperBoundInShelleyEra $ SlotNo maxBound + ShelleyBasedEraAllegra -> TxValidityNoUpperBound ValidityNoUpperBoundInAllegraEra + ShelleyBasedEraMary -> TxValidityNoUpperBound ValidityNoUpperBoundInMaryEra + ShelleyBasedEraAlonzo -> TxValidityNoUpperBound ValidityNoUpperBoundInAlonzoEra + ShelleyBasedEraBabbage -> TxValidityNoUpperBound ValidityNoUpperBoundInBabbageEra + +newtype WalletScript era = WalletScript { runWalletScript :: IO (WalletStep era) } + +data WalletStep era + = Done + | NextTx !(WalletScript era) !(Tx era) + | Error String + +-- TODO: +-- Define generator for a single transaction and define combinator for +-- repeat and sequence. + + +benchmarkWalletScript :: forall era . + IsShelleyBasedEra era + => IO (Either String (Tx era)) -- make polymorphic + -> NumberOfTxs + -> WalletScript era +benchmarkWalletScript sourceToStore totalCount + = WalletScript $ walletStep totalCount + where + walletStep :: NumberOfTxs -> IO (WalletStep era) + walletStep (NumberOfTxs 0) = return Done + walletStep count = sourceToStore >>= \case + Left err -> return $ Error err + Right tx -> return $ NextTx (benchmarkWalletScript sourceToStore (pred count)) tx + +limitSteps :: + NumberOfTxs + -> WalletScript era + -> WalletScript era +limitSteps = undefined + +keyAddress :: forall era. IsShelleyBasedEra era => NetworkId -> SigningKey PaymentKey -> AddressInEra era +keyAddress networkId k + = makeShelleyAddressInEra + networkId + (PaymentCredentialByKey $ verificationKeyHash $ getVerificationKey k) + NoStakeAddress diff --git a/cardano-api/src/Cardano/Api/LedgerEvent.hs b/cardano-api/src/Cardano/Api/LedgerEvent.hs index 38926b871e4..9c883019f20 100644 --- a/cardano-api/src/Cardano/Api/LedgerEvent.hs +++ b/cardano-api/src/Cardano/Api/LedgerEvent.hs @@ -97,7 +97,7 @@ instance instance All ConvertLedgerEvent xs => ConvertLedgerEvent (HardForkBlock xs) where toLedgerEvent = hcollapse - . hcmap (Proxy @ ConvertLedgerEvent) (K . toLedgerEvent) + . hcmap (Proxy @ConvertLedgerEvent) (K . toLedgerEvent) . getOneEraLedgerEvent . unwrapLedgerEvent diff --git a/cardano-api/test/Test/Cardano/Api/Crypto.hs b/cardano-api/test/Test/Cardano/Api/Crypto.hs index 00bc7552f73..1a482e59976 100644 --- a/cardano-api/test/Test/Cardano/Api/Crypto.hs +++ b/cardano-api/test/Test/Cardano/Api/Crypto.hs @@ -69,13 +69,13 @@ testDSIGNAlgorithm _ n = , testGroup "size" [ testProperty "VerKey" $ prop_size_serialise @(VerKeyDSIGN v) rawSerialiseVerKeyDSIGN - (sizeVerKeyDSIGN (Proxy @ v)) + (sizeVerKeyDSIGN (Proxy @v)) , testProperty "SignKey" $ prop_size_serialise @(SignKeyDSIGN v) rawSerialiseSignKeyDSIGN - (sizeSignKeyDSIGN (Proxy @ v)) + (sizeSignKeyDSIGN (Proxy @v)) , testProperty "Sig" $ prop_size_serialise @(SigDSIGN v) rawSerialiseSigDSIGN - (sizeSigDSIGN (Proxy @ v)) + (sizeSigDSIGN (Proxy @v)) ] , testGroup "direct CBOR" diff --git a/cardano-node/src/Cardano/Node/Queries.hs b/cardano-node/src/Cardano/Node/Queries.hs index 2db5824500c..9a084408194 100644 --- a/cardano-node/src/Cardano/Node/Queries.hs +++ b/cardano-node/src/Cardano/Node/Queries.hs @@ -106,7 +106,7 @@ instance All ConvertTxId xs => ConvertTxId (HardForkBlock xs) where txIdToRawBytes = hcollapse - . hcmap (Proxy @ ConvertTxId) (K . txIdToRawBytes . unwrapGenTxId) + . hcmap (Proxy @ConvertTxId) (K . txIdToRawBytes . unwrapGenTxId) . getOneEraGenTxId . getHardForkGenTxId diff --git a/cardano-node/src/Cardano/Node/Tracing/Era/HardFork.hs b/cardano-node/src/Cardano/Node/Tracing/Era/HardFork.hs index 0a138e060eb..c9068248628 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Era/HardFork.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Era/HardFork.hs @@ -55,7 +55,7 @@ import Ouroboros.Consensus.Util.Condense (Condense (..)) instance All (LogFormatting `Compose` Header) xs => LogFormatting (Header (HardForkBlock xs)) where forMachine dtal = hcollapse - . hcmap (Proxy @ (LogFormatting `Compose` Header)) (K . forMachine dtal) + . hcmap (Proxy @(LogFormatting `Compose` Header)) (K . forMachine dtal) . getOneEraHeader . getHardForkHeader @@ -67,7 +67,7 @@ instance All (LogFormatting `Compose` Header) xs => LogFormatting (Header (HardF instance All (Compose LogFormatting GenTx) xs => LogFormatting (GenTx (HardForkBlock xs)) where forMachine dtal = hcollapse - . hcmap (Proxy @ (LogFormatting `Compose` GenTx)) (K . forMachine dtal) + . hcmap (Proxy @(LogFormatting `Compose` GenTx)) (K . forMachine dtal) . getOneEraGenTx . getHardForkGenTx @@ -90,7 +90,7 @@ instance All (LogFormatting `Compose` WrapApplyTxErr) xs => LogFormatting (HardF instance All (LogFormatting `Compose` WrapApplyTxErr) xs => LogFormatting (OneEraApplyTxErr xs) where forMachine dtal = hcollapse - . hcmap (Proxy @ (LogFormatting `Compose` WrapApplyTxErr)) (K . forMachine dtal) + . hcmap (Proxy @(LogFormatting `Compose` WrapApplyTxErr)) (K . forMachine dtal) . getOneEraApplyTxErr instance LogFormatting (ApplyTxErr blk) => LogFormatting (WrapApplyTxErr blk) where @@ -116,7 +116,7 @@ instance All (LogFormatting `Compose` WrapLedgerErr) xs => LogFormatting (HardFo instance All (LogFormatting `Compose` WrapLedgerErr) xs => LogFormatting (OneEraLedgerError xs) where forMachine dtal = hcollapse - . hcmap (Proxy @ (LogFormatting `Compose` WrapLedgerErr)) (K . forMachine dtal) + . hcmap (Proxy @(LogFormatting `Compose` WrapLedgerErr)) (K . forMachine dtal) . getOneEraLedgerError instance LogFormatting (LedgerError blk) => LogFormatting (WrapLedgerErr blk) where @@ -166,7 +166,7 @@ instance ( All (LogFormatting `Compose` WrapLedgerWarning) xs instance All (LogFormatting `Compose` WrapLedgerWarning) xs => LogFormatting (OneEraLedgerWarning xs) where forMachine dtal = hcollapse - . hcmap (Proxy @ (LogFormatting `Compose` WrapLedgerWarning)) (K . forMachine dtal) + . hcmap (Proxy @(LogFormatting `Compose` WrapLedgerWarning)) (K . forMachine dtal) . getOneEraLedgerWarning instance LogFormatting (LedgerWarning blk) => LogFormatting (WrapLedgerWarning blk) where @@ -219,7 +219,7 @@ instance ( All (LogFormatting `Compose` WrapLedgerUpdate) xs instance All (LogFormatting `Compose` WrapLedgerUpdate) xs => LogFormatting (OneEraLedgerUpdate xs) where forMachine dtal = hcollapse - . hcmap (Proxy @ (LogFormatting `Compose` WrapLedgerUpdate)) (K . forMachine dtal) + . hcmap (Proxy @(LogFormatting `Compose` WrapLedgerUpdate)) (K . forMachine dtal) . getOneEraLedgerUpdate instance LogFormatting (LedgerUpdate blk) => LogFormatting (WrapLedgerUpdate blk) where @@ -245,7 +245,7 @@ instance All (LogFormatting `Compose` WrapEnvelopeErr) xs => LogFormatting (Hard instance All (LogFormatting `Compose` WrapEnvelopeErr) xs => LogFormatting (OneEraEnvelopeErr xs) where forMachine dtal = hcollapse - . hcmap (Proxy @ (LogFormatting `Compose` WrapEnvelopeErr)) (K . forMachine dtal) + . hcmap (Proxy @(LogFormatting `Compose` WrapEnvelopeErr)) (K . forMachine dtal) . getOneEraEnvelopeErr instance LogFormatting (OtherHeaderEnvelopeError blk) => LogFormatting (WrapEnvelopeErr blk) where @@ -271,7 +271,7 @@ instance All (LogFormatting `Compose` WrapValidationErr) xs => LogFormatting (Ha instance All (LogFormatting `Compose` WrapValidationErr) xs => LogFormatting (OneEraValidationErr xs) where forMachine dtal = hcollapse - . hcmap (Proxy @ (LogFormatting `Compose` WrapValidationErr)) (K . forMachine dtal) + . hcmap (Proxy @(LogFormatting `Compose` WrapValidationErr)) (K . forMachine dtal) . getOneEraValidationErr instance LogFormatting (ValidationErr (BlockProtocol blk)) => LogFormatting (WrapValidationErr blk) where @@ -288,7 +288,7 @@ instance LogFormatting (ValidationErr (BlockProtocol blk)) => LogFormatting (Wra instance All (LogFormatting `Compose` WrapCannotForge) xs => LogFormatting (OneEraCannotForge xs) where forMachine dtal = hcollapse - . hcmap (Proxy @ (LogFormatting `Compose` WrapCannotForge)) + . hcmap (Proxy @(LogFormatting `Compose` WrapCannotForge)) (K . forMachine dtal) . getOneEraCannotForge @@ -313,7 +313,7 @@ instance All (LogFormatting `Compose` WrapForgeStateInfo) xs => LogFormatting (O forgeStateInfo' :: Object forgeStateInfo' = hcollapse - . hcmap (Proxy @ (LogFormatting `Compose` WrapForgeStateInfo)) + . hcmap (Proxy @(LogFormatting `Compose` WrapForgeStateInfo)) (K . forMachine dtal) . getOneEraForgeStateInfo $ forgeStateInfo @@ -339,7 +339,7 @@ instance All (LogFormatting `Compose` WrapForgeStateUpdateError) xs => LogFormat forgeStateUpdateError' :: Object forgeStateUpdateError' = hcollapse - . hcmap (Proxy @ (LogFormatting `Compose` WrapForgeStateUpdateError)) + . hcmap (Proxy @(LogFormatting `Compose` WrapForgeStateUpdateError)) (K . forMachine dtal) . getOneEraForgeStateUpdateError $ forgeStateUpdateError diff --git a/cardano-node/src/Cardano/Tracing/OrphanInstances/HardFork.hs b/cardano-node/src/Cardano/Tracing/OrphanInstances/HardFork.hs index 0ca9e2adf6b..4f49c371a3f 100644 --- a/cardano-node/src/Cardano/Tracing/OrphanInstances/HardFork.hs +++ b/cardano-node/src/Cardano/Tracing/OrphanInstances/HardFork.hs @@ -63,7 +63,7 @@ instance Condense (OneEraHash xs) where instance All (ToObject `Compose` Header) xs => ToObject (Header (HardForkBlock xs)) where toObject verb = hcollapse - . hcmap (Proxy @ (ToObject `Compose` Header)) (K . toObject verb) + . hcmap (Proxy @(ToObject `Compose` Header)) (K . toObject verb) . getOneEraHeader . getHardForkHeader @@ -75,14 +75,14 @@ instance All (ToObject `Compose` Header) xs => ToObject (Header (HardForkBlock x instance All (Compose ToObject GenTx) xs => ToObject (GenTx (HardForkBlock xs)) where toObject verb = hcollapse - . hcmap (Proxy @ (ToObject `Compose` GenTx)) (K . toObject verb) + . hcmap (Proxy @(ToObject `Compose` GenTx)) (K . toObject verb) . getOneEraGenTx . getHardForkGenTx instance All (Compose ToJSON WrapGenTxId) xs => ToJSON (TxId (GenTx (HardForkBlock xs))) where toJSON = hcollapse - . hcmap (Proxy @ (ToJSON `Compose` WrapGenTxId)) (K . toJSON) + . hcmap (Proxy @(ToJSON `Compose` WrapGenTxId)) (K . toJSON) . getOneEraGenTxId . getHardForkGenTxId @@ -108,7 +108,7 @@ instance All (ToObject `Compose` WrapApplyTxErr) xs => ToObject (HardForkApplyTx instance All (ToObject `Compose` WrapApplyTxErr) xs => ToObject (OneEraApplyTxErr xs) where toObject verb = hcollapse - . hcmap (Proxy @ (ToObject `Compose` WrapApplyTxErr)) (K . toObject verb) + . hcmap (Proxy @(ToObject `Compose` WrapApplyTxErr)) (K . toObject verb) . getOneEraApplyTxErr instance ToObject (ApplyTxErr blk) => ToObject (WrapApplyTxErr blk) where @@ -134,7 +134,7 @@ instance All (ToObject `Compose` WrapLedgerErr) xs => ToObject (HardForkLedgerEr instance All (ToObject `Compose` WrapLedgerErr) xs => ToObject (OneEraLedgerError xs) where toObject verb = hcollapse - . hcmap (Proxy @ (ToObject `Compose` WrapLedgerErr)) (K . toObject verb) + . hcmap (Proxy @(ToObject `Compose` WrapLedgerErr)) (K . toObject verb) . getOneEraLedgerError instance ToObject (LedgerError blk) => ToObject (WrapLedgerErr blk) where @@ -184,7 +184,7 @@ instance ( All (ToObject `Compose` WrapLedgerWarning) xs instance All (ToObject `Compose` WrapLedgerWarning) xs => ToObject (OneEraLedgerWarning xs) where toObject verb = hcollapse - . hcmap (Proxy @ (ToObject `Compose` WrapLedgerWarning)) (K . toObject verb) + . hcmap (Proxy @(ToObject `Compose` WrapLedgerWarning)) (K . toObject verb) . getOneEraLedgerWarning instance ToObject (LedgerWarning blk) => ToObject (WrapLedgerWarning blk) where @@ -237,7 +237,7 @@ instance ( All (ToObject `Compose` WrapLedgerUpdate) xs instance All (ToObject `Compose` WrapLedgerUpdate) xs => ToObject (OneEraLedgerUpdate xs) where toObject verb = hcollapse - . hcmap (Proxy @ (ToObject `Compose` WrapLedgerUpdate)) (K . toObject verb) + . hcmap (Proxy @(ToObject `Compose` WrapLedgerUpdate)) (K . toObject verb) . getOneEraLedgerUpdate instance ToObject (LedgerUpdate blk) => ToObject (WrapLedgerUpdate blk) where @@ -263,7 +263,7 @@ instance All (ToObject `Compose` WrapEnvelopeErr) xs => ToObject (HardForkEnvelo instance All (ToObject `Compose` WrapEnvelopeErr) xs => ToObject (OneEraEnvelopeErr xs) where toObject verb = hcollapse - . hcmap (Proxy @ (ToObject `Compose` WrapEnvelopeErr)) (K . toObject verb) + . hcmap (Proxy @(ToObject `Compose` WrapEnvelopeErr)) (K . toObject verb) . getOneEraEnvelopeErr instance ToObject (OtherHeaderEnvelopeError blk) => ToObject (WrapEnvelopeErr blk) where @@ -289,7 +289,7 @@ instance All (ToObject `Compose` WrapValidationErr) xs => ToObject (HardForkVali instance All (ToObject `Compose` WrapValidationErr) xs => ToObject (OneEraValidationErr xs) where toObject verb = hcollapse - . hcmap (Proxy @ (ToObject `Compose` WrapValidationErr)) (K . toObject verb) + . hcmap (Proxy @(ToObject `Compose` WrapValidationErr)) (K . toObject verb) . getOneEraValidationErr instance ToObject (ValidationErr (BlockProtocol blk)) => ToObject (WrapValidationErr blk) where @@ -306,7 +306,7 @@ instance ToObject (ValidationErr (BlockProtocol blk)) => ToObject (WrapValidatio instance All (ToObject `Compose` WrapCannotForge) xs => ToObject (OneEraCannotForge xs) where toObject verb = hcollapse - . hcmap (Proxy @ (ToObject `Compose` WrapCannotForge)) + . hcmap (Proxy @(ToObject `Compose` WrapCannotForge)) (K . toObject verb) . getOneEraCannotForge @@ -331,7 +331,7 @@ instance All (ToObject `Compose` WrapForgeStateInfo) xs => ToObject (OneEraForge forgeStateInfo' :: Object forgeStateInfo' = hcollapse - . hcmap (Proxy @ (ToObject `Compose` WrapForgeStateInfo)) + . hcmap (Proxy @(ToObject `Compose` WrapForgeStateInfo)) (K . toObject verb) . getOneEraForgeStateInfo $ forgeStateInfo @@ -357,7 +357,7 @@ instance All (ToObject `Compose` WrapForgeStateUpdateError) xs => ToObject (OneE forgeStateUpdateError' :: Object forgeStateUpdateError' = hcollapse - . hcmap (Proxy @ (ToObject `Compose` WrapForgeStateUpdateError)) + . hcmap (Proxy @(ToObject `Compose` WrapForgeStateUpdateError)) (K . toObject verb) . getOneEraForgeStateUpdateError $ forgeStateUpdateError diff --git a/cardano-node/src/Cardano/Tracing/Tracers.hs b/cardano-node/src/Cardano/Tracing/Tracers.hs index 5ba1f507dd2..548a301c56b 100644 --- a/cardano-node/src/Cardano/Tracing/Tracers.hs +++ b/cardano-node/src/Cardano/Tracing/Tracers.hs @@ -680,7 +680,7 @@ mkConsensusTracers mbEKGDirect trSel verb tr nodeKern fStats = do tLocalUp tMaxSlotNo $ tracerOnOff (traceBlockFetchServer trSel) verb "BlockFetchServer" tr , Consensus.keepAliveClientTracer = tracerOnOff (traceKeepAliveClient trSel) verb "KeepAliveClient" tr , Consensus.forgeStateInfoTracer = tracerOnOff' (traceForgeStateInfo trSel) $ - forgeStateInfoTracer (Proxy @ blk) trSel tr + forgeStateInfoTracer (Proxy @blk) trSel tr , Consensus.txInboundTracer = tracerOnOff' (traceTxInbound trSel) $ Tracer $ \ev -> do traceWith (annotateSeverity . toLogObject' verb $ appendName "TxInbound" tr) ev From 9d31ae48f74b3cf677d69a2315c2a023843cc1eb Mon Sep 17 00:00:00 2001 From: John Ky Date: Thu, 29 Sep 2022 07:23:20 +1000 Subject: [PATCH 02/11] Operators must be separated by spaces --- .../src/Cardano/Benchmarking/FundSet.hs | 95 --------- .../src/Cardano/Benchmarking/GeneratorTx.hs | 31 --- .../Cardano/Benchmarking/GeneratorTx/Tx.hs | 110 ---------- .../src/Cardano/Benchmarking/Script/Core.hs | 31 --- .../src/Cardano/Benchmarking/Wallet.hs | 192 ------------------ .../src/Cardano/Api/TxSubmit/ErrorRender.hs | 12 +- cardano-api/src/Cardano/Api/TxSubmit/Types.hs | 2 +- cardano-cli/src/Cardano/CLI/Byron/Key.hs | 6 +- cardano-cli/src/Cardano/CLI/Byron/Tx.hs | 2 +- .../src/Cardano/TxSubmit/ErrorRender.hs | 12 +- 10 files changed, 17 insertions(+), 476 deletions(-) delete mode 100644 bench/tx-generator/src/Cardano/Benchmarking/FundSet.hs delete mode 100644 bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Tx.hs diff --git a/bench/tx-generator/src/Cardano/Benchmarking/FundSet.hs b/bench/tx-generator/src/Cardano/Benchmarking/FundSet.hs deleted file mode 100644 index 88ee31fdea9..00000000000 --- a/bench/tx-generator/src/Cardano/Benchmarking/FundSet.hs +++ /dev/null @@ -1,95 +0,0 @@ -{-# OPTIONS_GHC -Wwarn #-} -{-# Language DataKinds #-} -{-# Language FlexibleInstances #-} -{-# Language GADTs #-} -{-# Language MultiParamTypeClasses #-} -{-# Language RankNTypes #-} -{-# Language TypeApplications #-} -{-# Language ScopedTypeVariables #-} - -module Cardano.Benchmarking.FundSet -where -import Prelude - -import Cardano.Api as Api - -import Cardano.Benchmarking.Fifo as Fifo - --- Outputs that are available for spending. --- When building a new TX they provide the TxIn parts. - -data FundInEra era = FundInEra { - _fundTxIn :: !TxIn - , _fundWitness :: Witness WitCtxTxIn era - , _fundVal :: !(TxOutValue era) - , _fundSigningKey :: !(Maybe (SigningKey PaymentKey)) - } deriving (Show) - -newtype Fund = Fund {unFund :: InAnyCardanoEra FundInEra} - -type FundSet = Fifo Fund - -type FundSource m = m (Either String [Fund]) -type FundToStore m = Fund -> m () -type FundToStoreList m = [Fund] -> m () - -getFundTxIn :: Fund -> TxIn -getFundTxIn (Fund (InAnyCardanoEra _ a)) = _fundTxIn a - -getFundKey :: Fund -> Maybe (SigningKey PaymentKey) -getFundKey (Fund (InAnyCardanoEra _ a)) = _fundSigningKey a - -getFundLovelace :: Fund -> Lovelace -getFundLovelace (Fund (InAnyCardanoEra _ a)) = case _fundVal a of - TxOutAdaOnly _era l -> l - TxOutValue _era v -> selectLovelace v - --- This effectively rules out era-transitions for transactions ! --- This is not what we want !! -getFundWitness :: forall era. IsShelleyBasedEra era => Fund -> Witness WitCtxTxIn era -getFundWitness fund = case (cardanoEra @era, fund) of - (ByronEra , Fund (InAnyCardanoEra ByronEra a)) -> _fundWitness a - (ShelleyEra , Fund (InAnyCardanoEra ShelleyEra a)) -> _fundWitness a - (AllegraEra , Fund (InAnyCardanoEra AllegraEra a)) -> _fundWitness a - (MaryEra , Fund (InAnyCardanoEra MaryEra a)) -> _fundWitness a - (AlonzoEra , Fund (InAnyCardanoEra AlonzoEra a)) -> _fundWitness a - (BabbageEra , Fund (InAnyCardanoEra BabbageEra a)) -> _fundWitness a --- This effectively rules out era-transitions for transactions ! --- This is not what we want !! --- It should be possible to cast KeyWitnesses from one era to an other ! - (_ , _) -> error "getFundWitness: era mismatch" - -instance Show Fund where - show (Fund (InAnyCardanoEra _ f)) = show f - --- TxIn/fundTxOut is the primary key. --- There must be no two entries for the same TxIn !. - -instance Eq Fund where - (==) a b = getFundTxIn a == getFundTxIn b - -instance Ord Fund where - compare a b = compare (getFundTxIn a) (getFundTxIn b) - -emptyFundSet :: FundSet -emptyFundSet = Fifo.emptyFifo - -insertFund :: FundSet -> Fund -> FundSet -insertFund = Fifo.insert - -liftAnyEra :: ( forall era. IsCardanoEra era => f1 era -> f2 era ) -> InAnyCardanoEra f1 -> InAnyCardanoEra f2 -liftAnyEra f x = case x of - InAnyCardanoEra ByronEra a -> InAnyCardanoEra ByronEra $ f a - InAnyCardanoEra ShelleyEra a -> InAnyCardanoEra ShelleyEra $ f a - InAnyCardanoEra AllegraEra a -> InAnyCardanoEra AllegraEra $ f a - InAnyCardanoEra MaryEra a -> InAnyCardanoEra MaryEra $ f a - InAnyCardanoEra AlonzoEra a -> InAnyCardanoEra AlonzoEra $ f a - InAnyCardanoEra BabbageEra a -> InAnyCardanoEra BabbageEra $ f a - --- Todo: check sufficient funds and minimumValuePerUtxo -inputsToOutputsWithFee :: Lovelace -> Int -> [Lovelace] -> [Lovelace] -inputsToOutputsWithFee fee count inputs = map (quantityToLovelace . Quantity) outputs - where - (Quantity totalAvailable) = lovelaceToQuantity $ sum inputs - fee - (out, rest) = divMod totalAvailable (fromIntegral count) - outputs = (out + rest) : replicate (count-1) out diff --git a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx.hs b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx.hs index eb939018d29..4ca178880ca 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx.hs @@ -52,37 +52,6 @@ readSigningKey = , FromSomeType (AsSigningKey AsPaymentKey) id ] -secureGenesisFund :: forall era. IsShelleyBasedEra era - => Tracer IO (TraceBenchTxSubmit TxId) - -> (TxInMode CardanoMode -> IO (SubmitResult (TxValidationErrorInMode CardanoMode))) - -> NetworkId - -> ShelleyGenesis StandardShelley - -> Lovelace - -> SlotNo - -> SigningKey PaymentKey - -> AddressInEra era - -> ExceptT TxGenError IO Fund -secureGenesisFund submitTracer localSubmitTx networkId genesis txFee ttl key outAddr = do - let (_inAddr, lovelace) = genesisFundForKey @era networkId genesis key - (tx, fund) = - genesisExpenditure networkId key outAddr lovelace txFee ttl - r <- liftIO $ - catches (localSubmitTx $ txInModeCardano tx) - [ Handler $ \e@SomeException{} -> - fail $ mconcat - [ "Exception while moving genesis funds via local socket: " - , show e - ]] - case r of - SubmitSuccess -> - liftIO . traceWith submitTracer . TraceBenchTxSubDebug - $ mconcat - [ "******* Funding secured (" - , show $ fundTxIn fund, " -> ", show $ fundAdaValue fund - , ")"] - SubmitFail e -> fail $ show e - return fund - type AsyncBenchmarkControl = (Async (), [Async ()], IO SubmissionSummary, IO ()) waitBenchmark :: Tracer IO (TraceBenchTxSubmit TxId) -> AsyncBenchmarkControl -> ExceptT TxGenError IO () diff --git a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Tx.hs b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Tx.hs deleted file mode 100644 index a0e891fc5f4..00000000000 --- a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Tx.hs +++ /dev/null @@ -1,110 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -Wno-all-missed-specialisations #-} - -module Cardano.Benchmarking.GeneratorTx.Tx - ( Fund - , fundTxIn - , fundAdaValue - , keyAddress - , mkGenesisTransaction - , mkFund - , mkFee - , mkTxOutValueAdaOnly - , mkValidityUpperBound - , txOutValueToLovelace - , txInModeCardano - ) -where - -import Prelude -import Cardano.Benchmarking.Types (TxAdditionalSize (..)) - -import Cardano.Api - -type Fund = (TxIn, InAnyCardanoEra TxOutValue) - -mkFund :: forall era. IsCardanoEra era => TxIn -> TxOutValue era -> Fund -mkFund txIn val = (txIn, InAnyCardanoEra cardanoEra val) - -fundTxIn :: Fund -> TxIn -fundTxIn (x,_) = x - -fundAdaValue :: Fund -> Lovelace -fundAdaValue (_, InAnyCardanoEra _ txOut) = txOutValueToLovelace txOut - -keyAddress :: forall era. IsShelleyBasedEra era => NetworkId -> SigningKey PaymentKey -> AddressInEra era -keyAddress networkId k - = makeShelleyAddressInEra - networkId - (PaymentCredentialByKey $ verificationKeyHash $ getVerificationKey k) - NoStakeAddress - ---{-# DEPRECATED mkGenesisTransaction "to be removed" #-} -mkGenesisTransaction :: forall era . - IsShelleyBasedEra era - => SigningKey GenesisUTxOKey - -> TxAdditionalSize - -> SlotNo - -> Lovelace - -> [TxIn] - -> [TxOut CtxTx era] - -> Tx era -mkGenesisTransaction key _payloadSize ttl fee txins txouts - = case makeTransactionBody txBodyContent of - Right b -> signShelleyTransaction b [WitnessGenesisUTxOKey key] - Left err -> error $ show err - where - txBodyContent = TxBodyContent { - txIns = zip txins $ repeat $ BuildTxWith $ KeyWitness KeyWitnessForSpending - , txInsCollateral = TxInsCollateralNone - , txInsReference = TxInsReferenceNone - , txOuts = txouts - , txFee = mkFee fee - , txValidityRange = (TxValidityNoLowerBound, validityUpperBound) - , txMetadata = TxMetadataNone - , txAuxScripts = TxAuxScriptsNone - , txExtraKeyWits = TxExtraKeyWitnessesNone - , txProtocolParams = BuildTxWith Nothing - , txWithdrawals = TxWithdrawalsNone - , txCertificates = TxCertificatesNone - , txUpdateProposal = TxUpdateProposalNone - , txMintValue = TxMintNone - , txScriptValidity = TxScriptValidityNone - , txReturnCollateral = TxReturnCollateralNone - , txTotalCollateral = TxTotalCollateralNone - } - validityUpperBound = case shelleyBasedEra @era of - ShelleyBasedEraShelley -> TxValidityUpperBound ValidityUpperBoundInShelleyEra ttl - ShelleyBasedEraAllegra -> TxValidityUpperBound ValidityUpperBoundInAllegraEra ttl - ShelleyBasedEraMary -> TxValidityUpperBound ValidityUpperBoundInMaryEra ttl - ShelleyBasedEraAlonzo -> TxValidityUpperBound ValidityUpperBoundInAlonzoEra ttl - ShelleyBasedEraBabbage -> TxValidityUpperBound ValidityUpperBoundInBabbageEra ttl - -mkFee :: forall era . - IsShelleyBasedEra era - => Lovelace - -> TxFee era -mkFee f = case txFeesExplicitInEra (cardanoEra @era) of - Right e -> TxFeeExplicit e f - Left b -> TxFeeImplicit b -- error "unreachable" - -mkValidityUpperBound :: forall era . - IsShelleyBasedEra era - => SlotNo - -> TxValidityUpperBound era -mkValidityUpperBound ttl = case validityUpperBoundSupportedInEra (cardanoEra @era) of - Just p -> TxValidityUpperBound p ttl - Nothing -> error "unreachable" - -mkTxOutValueAdaOnly :: forall era . IsShelleyBasedEra era => Lovelace -> TxOutValue era -mkTxOutValueAdaOnly l = case multiAssetSupportedInEra (cardanoEra @era) of - Right p -> TxOutValue p $ lovelaceToValue l - Left p -> TxOutAdaOnly p l - -txInModeCardano :: forall era . IsShelleyBasedEra era => Tx era -> TxInMode CardanoMode -txInModeCardano tx = case toEraInMode (cardanoEra @era) CardanoMode of - Just t -> TxInMode tx t - Nothing -> error "txInModeCardano :unreachable" diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs b/bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs index e5cbd82a51b..604b6b24265 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs @@ -364,37 +364,6 @@ dumpToFile filePath tx = liftIO $ dumpToFileIO filePath tx dumpToFileIO :: FilePath -> TxInMode CardanoMode -> IO () dumpToFileIO filePath tx = appendFile filePath ('\n' : show tx) -importGenesisFund - :: AnyCardanoEra - -> WalletName - -> SubmitMode - -> KeyName - -> KeyName - -> ActionM () -importGenesisFund era wallet submitMode genesisKeyName destKey = do - tracer <- btTxSubmit_ <$> get BenchTracers - localSubmit <- case submitMode of - LocalSocket -> getLocalSubmitTx - NodeToNode _ -> throwE $ WalletError "NodeToNode mode not supported in importGenesisFund" - DumpToFile filePath -> return $ \tx -> dumpToFileIO filePath tx >> return SubmitSuccess - DiscardTX -> return $ \_ -> return SubmitSuccess - networkId <- getUser TNetworkId - genesis <- get Genesis - fee <- getUser TFee - ttl <- getUser TTTL - fundKey <- getName destKey - genesisKey <- getName genesisKeyName - let - coreCall :: forall era. IsShelleyBasedEra era => AsType era -> ExceptT TxGenError IO Store.Fund - coreCall _proxy = do - let addr = Core.keyAddress @era networkId fundKey - f <- GeneratorTx.secureGenesisFund tracer localSubmit networkId genesis fee ttl genesisKey addr - return (f, fundKey) - result <- liftCoreWithEra era coreCall - case result of - Left err -> liftTxGenError err - Right ((txIn, outVal), skey) -> addFundToWallet wallet txIn outVal skey - initWallet :: WalletName -> ActionM () initWallet name = liftIO Wallet.initWallet >>= setName name diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Wallet.hs b/bench/tx-generator/src/Cardano/Benchmarking/Wallet.hs index 32912e3ae4f..45f6a910f45 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/Wallet.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/Wallet.hs @@ -71,195 +71,3 @@ mangle fkts values worker (toUTxO, value, idx) = let (o, f ) = toUTxO value in (o, f idx) - ---TODO use Error monad ---TODO need to break this up -sourceToStoreTransaction :: - TxGenerator era - -> FundSource IO - -> ([Lovelace] -> split) - -> ToUTxOList era split - -> FundToStoreList IO --inline to ToUTxOList - -> IO (Either String (Tx era)) -sourceToStoreTransaction txGenerator fundSource inToOut mkTxOut fundToStore = do - fundSource >>= \case - Left err -> return $ Left err - Right inputFunds -> work inputFunds - where - work inputFunds = do - let - outValues = inToOut $ map getFundLovelace inputFunds - (outputs, toFunds) = mkTxOut outValues - case txGenerator inputFunds outputs of - Left err -> return $ Left err - Right (tx, txId) -> do - fundToStore $ toFunds txId - return $ Right tx - -sourceToStoreTransactionNew :: - TxGenerator era - -> FundSource IO - -> ([Lovelace] -> split) - -> CreateAndStoreList IO era split - -> IO (Either String (Tx era)) -sourceToStoreTransactionNew txGenerator fundSource valueSplitter toStore = do - fundSource >>= \case - Left err -> return $ Left err - Right inputFunds -> work inputFunds - where - work inputFunds = do - let - split = valueSplitter $ map getFundLovelace inputFunds - (outputs, storeAction) = toStore split - case txGenerator inputFunds outputs of - Left err -> return $ Left err - Right (tx, txId) -> do - storeAction txId - return $ Right tx - -includeChange :: Lovelace -> [Lovelace] -> [Lovelace] -> [Lovelace] -includeChange fee spend have = case compare changeValue 0 of - GT -> changeValue : spend - EQ -> spend - LT -> error "genTX: Bad transaction: insufficient funds" - where changeValue = sum have - sum spend - fee - -includeChangeNew :: Lovelace -> [Lovelace] -> [Lovelace] -> PayWithChange -includeChangeNew fee spend have = case compare changeValue 0 of - GT -> PayWithChange changeValue spend - EQ -> PayExact spend - LT -> error "genTX: Bad transaction: insufficient funds" - where changeValue = sum have - sum spend - fee - -mkUTxOVariant :: forall era. IsShelleyBasedEra era - => NetworkId - -> SigningKey PaymentKey - -> ToUTxO era -mkUTxOVariant networkId key value - = ( mkTxOut value - , mkNewFund value - ) - where - mkTxOut v = TxOut (keyAddress @era networkId key) (lovelaceToTxOutValue v) TxOutDatumNone ReferenceScriptNone - - mkNewFund :: Lovelace -> TxIx -> TxId -> Fund - mkNewFund val txIx txId = Fund $ InAnyCardanoEra (cardanoEra @era) $ FundInEra { - _fundTxIn = TxIn txId txIx - , _fundWitness = KeyWitness KeyWitnessForSpending - , _fundVal = lovelaceToTxOutValue val - , _fundSigningKey = Just key - } - --- to be merged with mkUTxOVariant -mkUTxOScript :: forall era. - IsShelleyBasedEra era - => NetworkId - -> (Script PlutusScriptV1, ScriptData) - -> Witness WitCtxTxIn era - -> ToUTxO era -mkUTxOScript networkId (script, txOutDatum) witness value - = ( mkTxOut value - , mkNewFund value - ) - where - plutusScriptAddr = makeShelleyAddressInEra - networkId - (PaymentCredentialByScript $ hashScript script) - NoStakeAddress - - mkTxOut v = case scriptDataSupportedInEra (cardanoEra @era) of - Nothing -> error " mkUtxOScript scriptDataSupportedInEra==Nothing" - Just tag -> TxOut - plutusScriptAddr - (lovelaceToTxOutValue v) - (TxOutDatumHash tag $ hashScriptData txOutDatum) - ReferenceScriptNone - - mkNewFund :: Lovelace -> TxIx -> TxId -> Fund - mkNewFund val txIx txId = Fund $ InAnyCardanoEra (cardanoEra @era) $ FundInEra { - _fundTxIn = TxIn txId txIx - , _fundWitness = witness - , _fundVal = lovelaceToTxOutValue val - , _fundSigningKey = Nothing - } - -genTx :: forall era. IsShelleyBasedEra era => - ProtocolParameters - -> (TxInsCollateral era, [Fund]) - -> TxFee era - -> TxMetadataInEra era - -> TxGenerator era -genTx protocolParameters (collateral, collFunds) fee metadata inFunds outputs - = case makeTransactionBody txBodyContent of - Left err -> error $ show err - Right b -> Right ( signShelleyTransaction b $ map WitnessPaymentKey allKeys - , getTxId b - ) - where - allKeys = mapMaybe getFundKey $ inFunds ++ collFunds - txBodyContent = TxBodyContent { - txIns = map (\f -> (getFundTxIn f, BuildTxWith $ getFundWitness f)) inFunds - , txInsCollateral = collateral - , txInsReference = TxInsReferenceNone - , txOuts = outputs - , txFee = fee - , txValidityRange = (TxValidityNoLowerBound, upperBound) - , txMetadata = metadata - , txAuxScripts = TxAuxScriptsNone - , txExtraKeyWits = TxExtraKeyWitnessesNone - , txProtocolParams = BuildTxWith $ Just protocolParameters - , txWithdrawals = TxWithdrawalsNone - , txCertificates = TxCertificatesNone - , txUpdateProposal = TxUpdateProposalNone - , txMintValue = TxMintNone - , txScriptValidity = TxScriptValidityNone - , txReturnCollateral = TxReturnCollateralNone - , txTotalCollateral = TxTotalCollateralNone - } - - upperBound :: TxValidityUpperBound era - upperBound = case shelleyBasedEra @era of - ShelleyBasedEraShelley -> TxValidityUpperBound ValidityUpperBoundInShelleyEra $ SlotNo maxBound - ShelleyBasedEraAllegra -> TxValidityNoUpperBound ValidityNoUpperBoundInAllegraEra - ShelleyBasedEraMary -> TxValidityNoUpperBound ValidityNoUpperBoundInMaryEra - ShelleyBasedEraAlonzo -> TxValidityNoUpperBound ValidityNoUpperBoundInAlonzoEra - ShelleyBasedEraBabbage -> TxValidityNoUpperBound ValidityNoUpperBoundInBabbageEra - -newtype WalletScript era = WalletScript { runWalletScript :: IO (WalletStep era) } - -data WalletStep era - = Done - | NextTx !(WalletScript era) !(Tx era) - | Error String - --- TODO: --- Define generator for a single transaction and define combinator for --- repeat and sequence. - - -benchmarkWalletScript :: forall era . - IsShelleyBasedEra era - => IO (Either String (Tx era)) -- make polymorphic - -> NumberOfTxs - -> WalletScript era -benchmarkWalletScript sourceToStore totalCount - = WalletScript $ walletStep totalCount - where - walletStep :: NumberOfTxs -> IO (WalletStep era) - walletStep (NumberOfTxs 0) = return Done - walletStep count = sourceToStore >>= \case - Left err -> return $ Error err - Right tx -> return $ NextTx (benchmarkWalletScript sourceToStore (pred count)) tx - -limitSteps :: - NumberOfTxs - -> WalletScript era - -> WalletScript era -limitSteps = undefined - -keyAddress :: forall era. IsShelleyBasedEra era => NetworkId -> SigningKey PaymentKey -> AddressInEra era -keyAddress networkId k - = makeShelleyAddressInEra - networkId - (PaymentCredentialByKey $ verificationKeyHash $ getVerificationKey k) - NoStakeAddress diff --git a/cardano-api/src/Cardano/Api/TxSubmit/ErrorRender.hs b/cardano-api/src/Cardano/Api/TxSubmit/ErrorRender.hs index 725f8323098..1afbfd92013 100644 --- a/cardano-api/src/Cardano/Api/TxSubmit/ErrorRender.hs +++ b/cardano-api/src/Cardano/Api/TxSubmit/ErrorRender.hs @@ -39,15 +39,15 @@ renderTxValidationError tve = "Tx Validation: " <> case tve of TxValidationLovelaceError txt e -> - sformat ("Lovelace error "% stext %": "% build) txt e + sformat ("Lovelace error " % stext % ": " % build) txt e TxValidationFeeTooSmall tx expected actual -> - sformat ("Tx "% build %" fee "% build %"too low, expected "% build) tx actual expected + sformat ("Tx " % build % " fee " % build % "too low, expected " % build) tx actual expected TxValidationWitnessWrongSignature wit pmid sig -> - sformat ("Bad witness "% build %" for signature "% stext %" protocol magic id "% stext) wit (textShow sig) (textShow pmid) + sformat ("Bad witness " % build % " for signature " % stext % " protocol magic id " % stext) wit (textShow sig) (textShow pmid) TxValidationWitnessWrongKey wit addr -> - sformat ("Bad witness "% build %" for address "% build) wit addr + sformat ("Bad witness " % build % " for address " % build) wit addr TxValidationMissingInput tx -> - sformat ("Validation cannot find input tx "% build) tx + sformat ("Validation cannot find input tx " % build) tx -- Fields are TxValidationNetworkMagicMismatch expected actual -> mconcat [ "Bad network magic ", textShow actual, ", expected ", textShow expected ] @@ -62,6 +62,6 @@ renderUTxOError :: UTxOError -> Text renderUTxOError ue = "UTxOError: " <> case ue of - UTxOMissingInput tx -> sformat ("Lookup of tx "% build %" failed") tx + UTxOMissingInput tx -> sformat ("Lookup of tx " % build % " failed") tx UTxOOverlappingUnion -> "Union or two overlapping UTxO sets" diff --git a/cardano-api/src/Cardano/Api/TxSubmit/Types.hs b/cardano-api/src/Cardano/Api/TxSubmit/Types.hs index 05ec0881b29..821ad85fa66 100644 --- a/cardano-api/src/Cardano/Api/TxSubmit/Types.hs +++ b/cardano-api/src/Cardano/Api/TxSubmit/Types.hs @@ -56,7 +56,7 @@ convertJson st = renderTxSubmitStatus :: TxSubmitStatus -> Text renderTxSubmitStatus st = case st of - TxSubmitOk tx -> sformat ("Tx "% build %" submitted successfully") tx + TxSubmitOk tx -> sformat ("Tx " % build % " submitted successfully") tx TxSubmitDecodeHex -> "Provided data was hex encoded and this webapi expects raw binary" TxSubmitEmpty -> "Provided transaction has zero length" TxSubmitDecodeFail err -> sformat build err diff --git a/cardano-cli/src/Cardano/CLI/Byron/Key.hs b/cardano-cli/src/Cardano/CLI/Byron/Key.hs index 03f484e818c..b329f466d74 100644 --- a/cardano-cli/src/Cardano/CLI/Byron/Key.hs +++ b/cardano-cli/src/Cardano/CLI/Byron/Key.hs @@ -70,9 +70,9 @@ newtype NewVerificationKeyFile = -- its hash and formatted view. prettyPublicKey :: VerificationKey ByronKey-> Text prettyPublicKey (ByronVerificationKey vk) = - sformat ( " public key hash: "% build % - "\npublic key (base64): "% Crypto.fullVerificationKeyF % - "\n public key (hex): "% Crypto.fullVerificationKeyHexF) + sformat ( " public key hash: " % build % + "\npublic key (base64): " % Crypto.fullVerificationKeyF % + "\n public key (hex): " % Crypto.fullVerificationKeyHexF) (Common.addressHash vk) vk vk byronWitnessToVerKey :: SomeByronSigningKey -> VerificationKey ByronKey diff --git a/cardano-cli/src/Cardano/CLI/Byron/Tx.hs b/cardano-cli/src/Cardano/CLI/Byron/Tx.hs index 364cd58b6ea..4484c6b608a 100644 --- a/cardano-cli/src/Cardano/CLI/Byron/Tx.hs +++ b/cardano-cli/src/Cardano/CLI/Byron/Tx.hs @@ -78,7 +78,7 @@ newtype NewTxFile = -- its full structure. prettyAddress :: Address ByronAddr -> Text prettyAddress (ByronAddress addr) = sformat - (Common.addressF %"\n"%Common.addressDetailedF) + (Common.addressF % "\n" % Common.addressDetailedF) addr addr readByronTx :: TxFile -> ExceptT ByronTxError IO (UTxO.ATxAux ByteString) diff --git a/cardano-submit-api/src/Cardano/TxSubmit/ErrorRender.hs b/cardano-submit-api/src/Cardano/TxSubmit/ErrorRender.hs index 0b72fa0ede5..d025d15801c 100644 --- a/cardano-submit-api/src/Cardano/TxSubmit/ErrorRender.hs +++ b/cardano-submit-api/src/Cardano/TxSubmit/ErrorRender.hs @@ -40,15 +40,15 @@ renderTxValidationError tve = "Tx Validation: " <> case tve of TxValidationLovelaceError txt e -> - sformat ("Lovelace error "% stext %": "% build) txt e + sformat ("Lovelace error " % stext % ": " % build) txt e TxValidationFeeTooSmall tx expected actual -> - sformat ("Tx "% build %" fee "% build %"too low, expected "% build) tx actual expected + sformat ("Tx " % build % " fee " % build % "too low, expected " % build) tx actual expected TxValidationWitnessWrongSignature wit pmid sig -> - sformat ("Bad witness "% build %" for signature "% stext %" protocol magic id "% stext) wit (textShow sig) (textShow pmid) + sformat ("Bad witness " % build % " for signature " % stext % " protocol magic id " % stext) wit (textShow sig) (textShow pmid) TxValidationWitnessWrongKey wit addr -> - sformat ("Bad witness "% build %" for address "% build) wit addr + sformat ("Bad witness " % build % " for address " % build) wit addr TxValidationMissingInput tx -> - sformat ("Validation cannot find input tx "% build) tx + sformat ("Validation cannot find input tx " % build) tx -- Fields are TxValidationNetworkMagicMismatch expected actual -> mconcat [ "Bad network magic ", textShow actual, ", expected ", textShow expected ] @@ -63,7 +63,7 @@ renderUTxOError :: UTxOError -> Text renderUTxOError ue = "UTxOError: " <> case ue of - UTxOMissingInput tx -> sformat ("Lookup of tx "% build %" failed") tx + UTxOMissingInput tx -> sformat ("Lookup of tx " % build % " failed") tx UTxOOverlappingUnion -> "Union or two overlapping UTxO sets" renderEraMismatch :: EraMismatch -> Text From 1a4adee1b2d41c200503cedfc0605d6aaead124b Mon Sep 17 00:00:00 2001 From: John Ky Date: Thu, 29 Sep 2022 07:48:20 +1000 Subject: [PATCH 03/11] Bang pattern symbol ! must not be followed by space --- .../src/Cardano/Logging/Configuration.hs | 2 +- trace-dispatcher/src/Cardano/Logging/Trace.hs | 6 +++--- trace-dispatcher/src/Cardano/Logging/Types.hs | 18 +++++++++--------- 3 files changed, 13 insertions(+), 13 deletions(-) diff --git a/trace-dispatcher/src/Cardano/Logging/Configuration.hs b/trace-dispatcher/src/Cardano/Logging/Configuration.hs index 04bf0d5bd2b..8fd53314f6c 100644 --- a/trace-dispatcher/src/Cardano/Logging/Configuration.hs +++ b/trace-dispatcher/src/Cardano/Logging/Configuration.hs @@ -96,7 +96,7 @@ withNamespaceConfig name extract withConfig tr = do T.traceWith (unpackTrace tt) (lc, Left Reset) mkTrace ref (lc, Left (Config c)) = do - ! val <- extract c (lcNamespace lc) + !val <- extract c (lcNamespace lc) eitherConf <- liftIO $ readIORef ref case eitherConf of Left (cmap, Nothing) -> diff --git a/trace-dispatcher/src/Cardano/Logging/Trace.hs b/trace-dispatcher/src/Cardano/Logging/Trace.hs index 5db73042570..dde8c38abbb 100644 --- a/trace-dispatcher/src/Cardano/Logging/Trace.hs +++ b/trace-dispatcher/src/Cardano/Logging/Trace.hs @@ -232,7 +232,7 @@ foldTraceM cata initial (Trace tr) = do \case (lc, Right v) -> do x' <- modifyMVar ref $ \x -> - let ! accu = cata x lc v + let !accu = cata x lc v in pure (accu,accu) T.traceWith tr (lc, Right (Folding x')) (lc, Left control) -> do @@ -256,7 +256,7 @@ foldMTraceM cata initial (Trace tr) = do \case (lc, Right v) -> do x' <- modifyMVar ref $ \x -> do - ! accu <- cata x lc v + !accu <- cata x lc v pure $ join (,) accu T.traceWith tr (lc, Right (Folding x')) (lc, Left control) -> do @@ -279,7 +279,7 @@ foldMCondTraceM cata initial flt (Trace tr) = do \case (lc, Right v) -> do x' <- modifyMVar ref $ \x -> do - ! accu <- cata x lc v + !accu <- cata x lc v pure $ join (,) accu when (flt v) $ T.traceWith tr (lc, Right (Folding x')) diff --git a/trace-dispatcher/src/Cardano/Logging/Types.hs b/trace-dispatcher/src/Cardano/Logging/Types.hs index 0cd22abc14b..378ac0e088c 100644 --- a/trace-dispatcher/src/Cardano/Logging/Types.hs +++ b/trace-dispatcher/src/Cardano/Logging/Types.hs @@ -388,15 +388,15 @@ data TraceControl where newtype DocCollector = DocCollector (IORef (Map Int LogDoc)) data LogDoc = LogDoc { - ldDoc :: ! Text - , ldMetricsDoc :: ! (SMap.Map Text Text) - , ldNamespace :: ! [Namespace] - , ldSeverity :: ! [SeverityS] - , ldPrivacy :: ! [Privacy] - , ldDetails :: ! [DetailLevel] - , ldBackends :: ! [BackendConfig] - , ldFiltered :: ! [SeverityF] - , ldLimiter :: ! [(Text, Double)] + ldDoc :: !Text + , ldMetricsDoc :: !(SMap.Map Text Text) + , ldNamespace :: ![Namespace] + , ldSeverity :: ![SeverityS] + , ldPrivacy :: ![Privacy] + , ldDetails :: ![DetailLevel] + , ldBackends :: ![BackendConfig] + , ldFiltered :: ![SeverityF] + , ldLimiter :: ![(Text, Double)] } deriving(Eq, Show) emptyLogDoc :: Text -> [(Text, Text)] -> LogDoc From 47e688a0bef7952b046c2934508cd35b223a2003 Mon Sep 17 00:00:00 2001 From: John Ky Date: Thu, 29 Sep 2022 09:02:38 +1000 Subject: [PATCH 04/11] Use type applications to disambguate use of show --- cardano-node/src/Cardano/Tracing/OrphanInstances/Common.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/cardano-node/src/Cardano/Tracing/OrphanInstances/Common.hs b/cardano-node/src/Cardano/Tracing/OrphanInstances/Common.hs index eae3e2e6398..b6ff5a01986 100644 --- a/cardano-node/src/Cardano/Tracing/OrphanInstances/Common.hs +++ b/cardano-node/src/Cardano/Tracing/OrphanInstances/Common.hs @@ -5,6 +5,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -82,7 +83,7 @@ instance FromJSON TracingVerbosity where <> "Encountered: " <> show invalid instance FromJSON PortNumber where - parseJSON (Number portNum) = case readMaybe . show $ coefficient portNum of + parseJSON (Number portNum) = case readMaybe . show @Integer @Text $ coefficient portNum of Just port -> pure port Nothing -> fail $ show portNum <> " is not a valid port number." parseJSON invalid = fail $ "Parsing of port number failed due to type mismatch. " From bedb2b36d025a007b79379add53fba76e7a6ece0 Mon Sep 17 00:00:00 2001 From: John Ky Date: Tue, 4 Oct 2022 23:17:36 +1100 Subject: [PATCH 05/11] Qualified import for Data.List to avoid ambiguity --- .../src/Cardano/Tracing/OrphanInstances/Common.hs | 2 +- .../src/Cardano/Logging/Tracer/Composed.hs | 11 ++++++----- 2 files changed, 7 insertions(+), 6 deletions(-) diff --git a/cardano-node/src/Cardano/Tracing/OrphanInstances/Common.hs b/cardano-node/src/Cardano/Tracing/OrphanInstances/Common.hs index b6ff5a01986..26496b9c58b 100644 --- a/cardano-node/src/Cardano/Tracing/OrphanInstances/Common.hs +++ b/cardano-node/src/Cardano/Tracing/OrphanInstances/Common.hs @@ -83,7 +83,7 @@ instance FromJSON TracingVerbosity where <> "Encountered: " <> show invalid instance FromJSON PortNumber where - parseJSON (Number portNum) = case readMaybe . show @Integer @Text $ coefficient portNum of + parseJSON (Number portNum) = case readMaybe . show @Integer $ coefficient portNum of Just port -> pure port Nothing -> fail $ show portNum <> " is not a valid port number." parseJSON invalid = fail $ "Parsing of port number failed due to type mismatch. " diff --git a/trace-dispatcher/src/Cardano/Logging/Tracer/Composed.hs b/trace-dispatcher/src/Cardano/Logging/Tracer/Composed.hs index 3f6a5aeaca6..8942c0679a4 100644 --- a/trace-dispatcher/src/Cardano/Logging/Tracer/Composed.hs +++ b/trace-dispatcher/src/Cardano/Logging/Tracer/Composed.hs @@ -9,7 +9,7 @@ module Cardano.Logging.Tracer.Composed ( , documentTracer ) where -import Control.Exception (catch, SomeException) +import Control.Exception (SomeException, catch) import Data.Aeson.Types (ToJSON) import Data.Maybe (fromMaybe) import Data.Text @@ -24,6 +24,7 @@ import Cardano.Logging.Trace import Cardano.Logging.Types import qualified Control.Tracer as NT +import qualified Data.List as L data MessageOrLimit m = Message m | Limit LimitingMessage @@ -111,17 +112,17 @@ mkCardanoTracer' trStdout trForward mbTrEkg tracerName namesFor severityFor priv [EKGBackend, Forwarder, Stdout HumanFormatColoured] mbBackends in do - mbForwardTrace <- if Forwarder `elem` backends' + mbForwardTrace <- if Forwarder `L.elem` backends' then fmap (Just . filterTraceByPrivacy (Just Public)) (forwardFormatter Nothing trForward) else pure Nothing - mbStdoutTrace <- if Stdout HumanFormatColoured `elem` backends' + mbStdoutTrace <- if Stdout HumanFormatColoured `L.elem` backends' then fmap Just (humanFormatter True Nothing trStdout) - else if Stdout HumanFormatUncoloured `elem` backends' + else if Stdout HumanFormatUncoloured `L.elem` backends' then fmap Just (humanFormatter False Nothing trStdout) - else if Stdout MachineFormat `elem` backends' + else if Stdout MachineFormat `L.elem` backends' then fmap Just (machineFormatter Nothing trStdout) else pure Nothing From c049f058f51d4f24430319320fa991b9206fae74 Mon Sep 17 00:00:00 2001 From: John Ky Date: Tue, 4 Oct 2022 23:22:27 +1100 Subject: [PATCH 06/11] Remove unused constraints --- cardano-api/src/Cardano/Api/Query.hs | 3 +-- .../src/Cardano/Node/Tracing/Tracers/Consensus.hs | 3 +-- .../Cardano/Node/Tracing/Tracers/NodeToNode.hs | 6 ++---- .../Cardano/Tracing/OrphanInstances/Consensus.hs | 15 +++++---------- .../Cardano/Tracing/OrphanInstances/Shelley.hs | 1 - .../src/Cardano/Logging/FrequencyLimiter.hs | 2 +- 6 files changed, 10 insertions(+), 20 deletions(-) diff --git a/cardano-api/src/Cardano/Api/Query.hs b/cardano-api/src/Cardano/Api/Query.hs index da103745186..91269192da0 100644 --- a/cardano-api/src/Cardano/Api/Query.hs +++ b/cardano-api/src/Cardano/Api/Query.hs @@ -292,7 +292,7 @@ instance IsCardanoEra era => ToJSON (UTxO era) where toJSON (UTxO m) = toJSON m toEncoding (UTxO m) = toEncoding m -instance (IsCardanoEra era, IsShelleyBasedEra era, FromJSON (TxOut CtxUTxO era)) +instance (IsShelleyBasedEra era, FromJSON (TxOut CtxUTxO era)) => FromJSON (UTxO era) where parseJSON = withObject "UTxO" $ \hm -> do let l = HMS.toList $ KeyMap.toHashMapText hm @@ -381,7 +381,6 @@ newtype CurrentEpochState era = CurrentEpochState (Shelley.EpochState (ShelleyLe decodeCurrentEpochState :: forall era. Ledger.Era (ShelleyLedgerEra era) - => Share (Core.TxOut (ShelleyLedgerEra era)) ~ Interns (Shelley.Credential 'Shelley.Staking (Ledger.Crypto (ShelleyLedgerEra era))) => FromSharedCBOR (Core.TxOut (ShelleyLedgerEra era)) => Share (Core.TxOut (ShelleyLedgerEra era)) ~ Interns (Shelley.Credential 'Shelley.Staking (Ledger.Crypto (ShelleyLedgerEra era))) => FromCBOR (Core.PParams (ShelleyLedgerEra era)) diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs index 35188164474..08d9c92139d 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs @@ -942,8 +942,7 @@ namesForMempool TraceMempoolRemoveTxs {} = ["RemoveTxs"] namesForMempool TraceMempoolManuallyRemovedTxs {} = ["ManuallyRemovedTxs"] instance - ( Show (ApplyTxErr blk) - , LogFormatting (ApplyTxErr blk) + ( LogFormatting (ApplyTxErr blk) , LogFormatting (GenTx blk) , ToJSON (GenTxId blk) , LedgerSupportsMempool blk diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToNode.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToNode.hs index fe642a390ec..0d6870c8b4b 100644 --- a/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToNode.hs +++ b/cardano-node/src/Cardano/Node/Tracing/Tracers/NodeToNode.hs @@ -42,8 +42,8 @@ import Text.Show import Cardano.Node.Queries (ConvertTxId) import Cardano.Node.Tracing.Render (renderHeaderHash, renderTxIdForDetails) -import Ouroboros.Consensus.Block (ConvertRawHash, GetHeader, HasHeader, Header, - StandardHash, getHeader) +import Ouroboros.Consensus.Block (ConvertRawHash, GetHeader, Header, StandardHash, + getHeader) import Ouroboros.Consensus.Ledger.SupportsMempool (GenTx, GenTxId, HasTxId, HasTxs, LedgerSupportsMempool, extractTxs, txId) import Ouroboros.Consensus.Node.Run (SerialiseNodeToNodeConstraints, estimateBlockSize) @@ -189,8 +189,6 @@ namesForTBlockFetch (BlockFetch.TraceLabelPeer _ v) = namesTBlockFetch v namesTBlockFetch'' MsgClientDone {} = ["ClientDone"] instance ( ConvertTxId blk - , ConvertRawHash blk - , HasHeader blk , GetHeader blk , HasTxId (GenTx blk) , SerialiseNodeToNodeConstraints blk diff --git a/cardano-node/src/Cardano/Tracing/OrphanInstances/Consensus.hs b/cardano-node/src/Cardano/Tracing/OrphanInstances/Consensus.hs index ac40b417d72..3b69a78b999 100644 --- a/cardano-node/src/Cardano/Tracing/OrphanInstances/Consensus.hs +++ b/cardano-node/src/Cardano/Tracing/OrphanInstances/Consensus.hs @@ -48,8 +48,8 @@ import Ouroboros.Consensus.Mempool.API (MempoolSize (..), TraceEventMe import Ouroboros.Consensus.MiniProtocol.BlockFetch.Server (TraceBlockFetchServerEvent (..)) import Ouroboros.Consensus.MiniProtocol.ChainSync.Client (TraceChainSyncClientEvent (..)) -import Ouroboros.Consensus.MiniProtocol.ChainSync.Server - (BlockingType (..), TraceChainSyncServerEvent (..)) +import Ouroboros.Consensus.MiniProtocol.ChainSync.Server (BlockingType (..), + TraceChainSyncServerEvent (..)) import Ouroboros.Consensus.MiniProtocol.LocalTxSubmission.Server (TraceLocalTxSubmissionServerEvent (..)) import Ouroboros.Consensus.Node.Run (RunNode, estimateBlockSize) @@ -297,7 +297,7 @@ instance ConvertRawHash blk trTransformer = trStructured -instance ( ToObject (ApplyTxErr blk), Show (ApplyTxErr blk), ToObject (GenTx blk), +instance ( ToObject (ApplyTxErr blk), ToObject (GenTx blk), ToJSON (GenTxId blk), LedgerSupportsMempool blk) => Transformable Text IO (TraceEventMempool blk) where trTransformer = trStructured @@ -319,7 +319,6 @@ showT = pack . show instance ( tx ~ GenTx blk , HasTxId tx , RunNode blk - , Show (TxId tx) , ToObject (LedgerError blk) , ToObject (OtherHeaderEnvelopeError blk) , ToObject (ValidationErr (BlockProtocol blk)) @@ -1262,7 +1261,7 @@ instance ConvertRawHash blk ] <> [ "risingEdge" .= True | RisingEdge <- [enclosing] ] -instance ( Show (ApplyTxErr blk), ToObject (ApplyTxErr blk), ToObject (GenTx blk), +instance ( ToObject (ApplyTxErr blk), ToObject (GenTx blk), ToJSON (GenTxId blk), LedgerSupportsMempool blk ) => ToObject (TraceEventMempool blk) where toObject verb (TraceMempoolAddedTx tx _mpSzBefore mpSzAfter) = @@ -1306,11 +1305,7 @@ instance HasTextFormatter () where instance Transformable Text IO () where trTransformer = trStructuredText -instance ( tx ~ GenTx blk - , ConvertRawHash blk - , HasTxId tx - , RunNode blk - , Show (TxId tx) +instance ( RunNode blk , ToObject (LedgerError blk) , ToObject (OtherHeaderEnvelopeError blk) , ToObject (ValidationErr (BlockProtocol blk)) diff --git a/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs b/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs index dd294fbafda..e6b166913f9 100644 --- a/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs +++ b/cardano-node/src/Cardano/Tracing/OrphanInstances/Shelley.hs @@ -879,7 +879,6 @@ instance ToObject (UpecPredicateFailure era) where instance ( Ledger.Era era , ToJSON (Ledger.Value era) - , Show (Ledger.Value era) , ToJSON (Ledger.TxOut era) , ToObject (PredicateFailure (Ledger.EraRule "UTXOS" era)) , ShelleyBasedEra era diff --git a/trace-dispatcher/src/Cardano/Logging/FrequencyLimiter.hs b/trace-dispatcher/src/Cardano/Logging/FrequencyLimiter.hs index 239c816a1ba..aebc967b949 100644 --- a/trace-dispatcher/src/Cardano/Logging/FrequencyLimiter.hs +++ b/trace-dispatcher/src/Cardano/Logging/FrequencyLimiter.hs @@ -109,7 +109,7 @@ data FrequencyRec a = FrequencyRec { limitFrequency - :: forall a m . (MonadIO m, MonadUnliftIO m) + :: forall a m . MonadUnliftIO m => Double -- messages per second -> Text -- name of this limiter -> Trace m a -- the limited trace From f5a50742d8f8262e0822084b0a74a80fe862f8f9 Mon Sep 17 00:00:00 2001 From: John Ky Date: Tue, 4 Oct 2022 23:34:30 +1100 Subject: [PATCH 07/11] Don't hide import of option. Use qualified import of Options.Applicative instead. --- .../Benchmarking/GeneratorTx/Tx/Byron.hs | 71 +++++++++++++++++++ cardano-cli/app/cardano-cli.hs | 2 +- .../src/Cardano/CLI/Byron/Delegation.hs | 2 +- cardano-cli/src/Cardano/CLI/Byron/Genesis.hs | 3 +- cardano-cli/src/Cardano/CLI/Byron/Key.hs | 2 +- cardano-cli/src/Cardano/CLI/Byron/Parsers.hs | 40 +++++------ cardano-cli/src/Cardano/CLI/Byron/Tx.hs | 2 +- .../src/Cardano/CLI/Shelley/Parsers.hs | 2 +- cardano-node-chairman/app/Cardano/Chairman.hs | 2 +- .../app/Cardano/Chairman/Commands/Run.hs | 7 +- cardano-node/app/cardano-node.hs | 2 +- cardano-node/src/Cardano/Node/Parsers.hs | 14 ++-- 12 files changed, 111 insertions(+), 38 deletions(-) create mode 100644 bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Tx/Byron.hs diff --git a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Tx/Byron.hs b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Tx/Byron.hs new file mode 100644 index 00000000000..6b98797fd63 --- /dev/null +++ b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Tx/Byron.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -Wno-all-missed-specialisations -Wextra #-} + +module Cardano.Benchmarking.GeneratorTx.Tx.Byron + ( normalByronTxToGenTx + , byronGenesisUTxOTxIn + ) +where + +import Cardano.Prelude hiding (trace, (%)) +import Prelude (error) + +import qualified Data.Map.Strict as Map +import qualified Data.Text as T +import Formatting (sformat, (%)) + +import Cardano.Chain.Common (Address) +import qualified Cardano.Chain.Common as Common +import Cardano.Chain.Genesis as Genesis +import qualified Cardano.Chain.UTxO as UTxO +import qualified Cardano.Crypto.Signing as Crypto + +import Ouroboros.Consensus.Byron.Ledger (ByronBlock, GenTx (..)) +import qualified Ouroboros.Consensus.Byron.Ledger as Byron + +-- | The 'GenTx' is all the kinds of transactions that can be submitted +-- and \"normal\" Byron transactions are just one of the kinds. +normalByronTxToGenTx :: UTxO.ATxAux ByteString -> GenTx ByronBlock +normalByronTxToGenTx tx' = Byron.ByronTx (Byron.byronIdTx tx') tx' + +-- | Given a genesis, and a pair of a genesis public key and address, +-- reconstruct a TxIn corresponding to the genesis UTxO entry. +byronGenesisUTxOTxIn :: Genesis.Config -> Crypto.VerificationKey -> Common.Address -> UTxO.TxIn +byronGenesisUTxOTxIn gc vk genAddr = + handleMissingAddr $ fst <$> Map.lookup genAddr initialUtxo + where + initialUtxo :: Map Common.Address (UTxO.TxIn, UTxO.TxOut) + initialUtxo = + Map.fromList + . mapMaybe (\(inp, out) -> mkEntry inp genAddr <$> keyMatchesUTxO vk out) + . map (bimap UTxO.fromCompactTxIn UTxO.fromCompactTxOut) + . Map.toList + . UTxO.unUTxO + . UTxO.genesisUtxo + $ gc + + mkEntry :: UTxO.TxIn + -> Address + -> UTxO.TxOut + -> (Address, (UTxO.TxIn, UTxO.TxOut)) + mkEntry inp addr out = (addr, (inp, out)) + + keyMatchesUTxO :: Crypto.VerificationKey -> UTxO.TxOut -> Maybe UTxO.TxOut + keyMatchesUTxO key out = + if Common.checkVerKeyAddress key (UTxO.txOutAddress out) + then Just out else Nothing + + handleMissingAddr :: Maybe UTxO.TxIn -> UTxO.TxIn + handleMissingAddr = fromMaybe . error + $ "\nGenesis UTxO has no address\n" + <> T.unpack (prettyAddress genAddr) + <> "\n\nIt has the following, though:\n\n" + <> Cardano.Prelude.concat (T.unpack . prettyAddress <$> Map.keys initialUtxo) + + prettyAddress :: Common.Address -> Text + prettyAddress addr = sformat + (Common.addressF % "\n" % Common.addressDetailedF) + addr addr diff --git a/cardano-cli/app/cardano-cli.hs b/cardano-cli/app/cardano-cli.hs index a103a8e4cce..f613c310ccc 100644 --- a/cardano-cli/app/cardano-cli.hs +++ b/cardano-cli/app/cardano-cli.hs @@ -5,7 +5,7 @@ #define UNIX #endif -import Cardano.Prelude hiding (option) +import Cardano.Prelude import Control.Monad.Trans.Except.Exit (orDie) import qualified Options.Applicative as Opt diff --git a/cardano-cli/src/Cardano/CLI/Byron/Delegation.hs b/cardano-cli/src/Cardano/CLI/Byron/Delegation.hs index f64ef3b24a8..7d812c096d6 100644 --- a/cardano-cli/src/Cardano/CLI/Byron/Delegation.hs +++ b/cardano-cli/src/Cardano/CLI/Byron/Delegation.hs @@ -12,7 +12,7 @@ module Cardano.CLI.Byron.Delegation ) where -import Cardano.Prelude hiding (option, show, trace) +import Cardano.Prelude hiding (show, trace) import Control.Monad.Trans.Except.Extra (left) import qualified Data.ByteString.Lazy as LB diff --git a/cardano-cli/src/Cardano/CLI/Byron/Genesis.hs b/cardano-cli/src/Cardano/CLI/Byron/Genesis.hs index 79988b18ab2..0b79d1ef248 100644 --- a/cardano-cli/src/Cardano/CLI/Byron/Genesis.hs +++ b/cardano-cli/src/Cardano/CLI/Byron/Genesis.hs @@ -12,7 +12,7 @@ module Cardano.CLI.Byron.Genesis ) where -import Cardano.Prelude hiding (option, show, trace) +import Cardano.Prelude hiding (show, trace) import Prelude (String) import Control.Monad.Trans.Except.Extra (firstExceptT, left, right) @@ -23,6 +23,7 @@ import Data.Time (UTCTime) import Formatting.Buildable import Cardano.Api (Key (..), NetworkId, textShow, writeSecrets) + import Cardano.Api.Byron (ByronKey, SerialiseAsRawBytes (..), SigningKey (..), toByronRequiresNetworkMagic) import System.Directory (createDirectory, doesPathExist) diff --git a/cardano-cli/src/Cardano/CLI/Byron/Key.hs b/cardano-cli/src/Cardano/CLI/Byron/Key.hs index b329f466d74..1db5bb4c997 100644 --- a/cardano-cli/src/Cardano/CLI/Byron/Key.hs +++ b/cardano-cli/src/Cardano/CLI/Byron/Key.hs @@ -14,7 +14,7 @@ module Cardano.CLI.Byron.Key ) where -import Cardano.Prelude hiding (option, show, trace, (%)) +import Cardano.Prelude hiding (show, trace, (%)) import Prelude (show) import Control.Monad.Trans.Except.Extra (firstExceptT, handleIOExceptT, hoistEither, left, diff --git a/cardano-cli/src/Cardano/CLI/Byron/Parsers.hs b/cardano-cli/src/Cardano/CLI/Byron/Parsers.hs index d7364b58c05..a7951652e2e 100644 --- a/cardano-cli/src/Cardano/CLI/Byron/Parsers.hs +++ b/cardano-cli/src/Cardano/CLI/Byron/Parsers.hs @@ -21,7 +21,7 @@ module Cardano.CLI.Byron.Parsers , parseUpdateVoteThd ) where -import Cardano.Prelude hiding (option) +import Cardano.Prelude import Prelude (String) import Control.Monad (fail) @@ -114,7 +114,7 @@ pNodeCmdBackwardCompatible = Opt.subparser $ pNodeCmd <> Opt.internal parseCBORObject :: Parser CBORObject parseCBORObject = asum - [ CBORBlockByron <$> option auto + [ CBORBlockByron <$> Opt.option auto ( long "byron-block" <> help ( "The CBOR file is a byron era block." @@ -263,7 +263,7 @@ parseTestnetBalanceOptions = parseTxIn :: Parser TxIn parseTxIn = - option + Opt.option (readerFromAttoParser parseTxInAtto) $ long "txin" <> metavar "(TXID,INDEX)" @@ -287,7 +287,7 @@ parseTxIxAtto = toEnum <$> Atto.decimal parseTxOut :: Parser (TxOut CtxTx ByronEra) parseTxOut = - option + Opt.option ( (\(addr, lovelace) -> TxOut (pAddressInEra addr) (pLovelaceTxOut lovelace) TxOutDatumNone @@ -434,7 +434,7 @@ parseByronVote = parseScriptVersion :: Parser Word16 parseScriptVersion = - option auto + Opt.option auto ( long "script-version" <> metavar "WORD16" <> help "Proposed script version." @@ -442,14 +442,14 @@ parseScriptVersion = parseSlotDuration :: Parser Natural parseSlotDuration = - option auto + Opt.option auto ( long "slot-duration" <> metavar "NATURAL" <> help "Proposed slot duration." ) parseSystemTag :: Parser SystemTag -parseSystemTag = option (eitherReader checkSysTag) +parseSystemTag = Opt.option (eitherReader checkSysTag) ( long "system-tag" <> metavar "STRING" <> help "Identify which system (linux, win64, etc) the update proposal is for." @@ -472,7 +472,7 @@ parseInstallerHash = parseMaxBlockSize :: Parser Natural parseMaxBlockSize = - option auto + Opt.option auto ( long "max-block-size" <> metavar "NATURAL" <> help "Proposed max block size." @@ -480,7 +480,7 @@ parseMaxBlockSize = parseMaxHeaderSize :: Parser Natural parseMaxHeaderSize = - option auto + Opt.option auto ( long "max-header-size" <> metavar "NATURAL" <> help "Proposed max block header size." @@ -488,7 +488,7 @@ parseMaxHeaderSize = parseMaxTxSize :: Parser Natural parseMaxTxSize = - option auto + Opt.option auto ( long "max-tx-size" <> metavar "NATURAL" <> help "Proposed max transaction size." @@ -496,7 +496,7 @@ parseMaxTxSize = parseMaxProposalSize :: Parser Natural parseMaxProposalSize = - option auto + Opt.option auto ( long "max-proposal-size" <> metavar "NATURAL" <> help "Proposed max update proposal size." @@ -531,7 +531,7 @@ parseUpdateProposalThd = parseUpdateProposalTTL :: Parser SlotNumber parseUpdateProposalTTL = SlotNumber - <$> option auto + <$> Opt.option auto ( long "time-to-live" <> metavar "WORD64" <> help "Proposed time for an update proposal to live." @@ -550,7 +550,7 @@ parseSoftwareVersion = SoftwareVersion <$> parseApplicationName <*> parseNumSoftwareVersion parseApplicationName :: Parser ApplicationName -parseApplicationName = option (eitherReader checkAppNameLength) +parseApplicationName = Opt.option (eitherReader checkAppNameLength) ( long "application-name" <> metavar "STRING" <> help "The name of the application." @@ -584,7 +584,7 @@ parseVoteBool = flag' True (long "vote-yes" <> help "Vote yes with respect to an parseUnlockStakeEpoch :: Parser EpochNumber parseUnlockStakeEpoch = EpochNumber - <$> option auto + <$> Opt.option auto ( long "unlock-stake-epoch" <> metavar "WORD64" <> help "Proposed epoch to unlock all stake." @@ -592,14 +592,14 @@ parseUnlockStakeEpoch = parseWord :: Integral a => String -> String -> String -> Parser a -parseWord optname desc metvar = option (fromInteger <$> auto) +parseWord optname desc metvar = Opt.option (fromInteger <$> auto) $ long optname <> metavar metvar <> help desc parseAddress :: String -> String -> Parser (Address ByronAddr) parseAddress opt desc = - option (cliParseBase58Address <$> str) + Opt.option (cliParseBase58Address <$> str) $ long opt <> metavar "ADDR" <> help desc parseByronKeyFormat :: Parser ByronKeyFormat @@ -641,7 +641,7 @@ parseFractionWithDefault -> Double -> Parser Rational parseFractionWithDefault optname desc w = - toRational <$> option readDouble + toRational <$> Opt.option readDouble ( long optname <> metavar "DOUBLE" <> help desc @@ -700,7 +700,7 @@ parseTxFile opt = parseUTCTime :: String -> String -> Parser UTCTime parseUTCTime optname desc = - option (posixSecondsToUTCTime . fromInteger <$> auto) + Opt.option (posixSecondsToUTCTime . fromInteger <$> auto) $ long optname <> metavar "POSIXSECONDS" <> help desc cliParseBase58Address :: Text -> Address ByronAddr @@ -711,13 +711,13 @@ cliParseBase58Address t = parseFraction :: String -> String -> Parser Rational parseFraction optname desc = - option (toRational <$> readDouble) $ + Opt.option (toRational <$> readDouble) $ long optname <> metavar "DOUBLE" <> help desc parseIntegral :: Integral a => String -> String -> Parser a -parseIntegral optname desc = option (fromInteger <$> auto) +parseIntegral optname desc = Opt.option (fromInteger <$> auto) $ long optname <> metavar "INT" <> help desc parseLovelace :: String -> String -> Parser Byron.Lovelace diff --git a/cardano-cli/src/Cardano/CLI/Byron/Tx.hs b/cardano-cli/src/Cardano/CLI/Byron/Tx.hs index 4484c6b608a..40cb506d931 100644 --- a/cardano-cli/src/Cardano/CLI/Byron/Tx.hs +++ b/cardano-cli/src/Cardano/CLI/Byron/Tx.hs @@ -22,7 +22,7 @@ module Cardano.CLI.Byron.Tx ) where -import Cardano.Prelude hiding (option, trace, (%)) +import Cardano.Prelude hiding (trace, (%)) import Prelude (error) import Control.Monad.Trans.Except.Extra (firstExceptT, left, newExceptT) diff --git a/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs b/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs index e908d8a7056..ef93403fdfc 100644 --- a/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs +++ b/cardano-cli/src/Cardano/CLI/Shelley/Parsers.hs @@ -14,7 +14,7 @@ module Cardano.CLI.Shelley.Parsers , parseTxIn ) where -import Cardano.Prelude hiding (All, Any, option) +import Cardano.Prelude hiding (All, Any) import Prelude (String) import Control.Monad.Fail (fail) diff --git a/cardano-node-chairman/app/Cardano/Chairman.hs b/cardano-node-chairman/app/Cardano/Chairman.hs index 8f6fc80266b..d3d8c5adce6 100644 --- a/cardano-node-chairman/app/Cardano/Chairman.hs +++ b/cardano-node-chairman/app/Cardano/Chairman.hs @@ -11,7 +11,7 @@ module Cardano.Chairman (chairmanTest) where -import Cardano.Prelude hiding (ByteString, STM, atomically, catch, option, show, throwIO) +import Cardano.Prelude hiding (ByteString, STM, atomically, catch, show, throwIO) import Prelude (String, error, show) import Control.Monad.Class.MonadAsync diff --git a/cardano-node-chairman/app/Cardano/Chairman/Commands/Run.hs b/cardano-node-chairman/app/Cardano/Chairman/Commands/Run.hs index 78166a00f5c..b9da33986cf 100644 --- a/cardano-node-chairman/app/Cardano/Chairman/Commands/Run.hs +++ b/cardano-node-chairman/app/Cardano/Chairman/Commands/Run.hs @@ -7,13 +7,14 @@ module Cardano.Chairman.Commands.Run ( cmdRun ) where -import Cardano.Prelude hiding (option) +import Cardano.Prelude import Control.Monad.Class.MonadTime (DiffTime) import Control.Tracer (Tracer (..), stdoutTracer) import qualified Data.Text as Text import qualified Data.Time.Clock as DTC import Options.Applicative +import qualified Options.Applicative as Opt import qualified System.IO as IO import Cardano.Node.Configuration.NodeAddress @@ -63,7 +64,7 @@ parseSocketPath helpMessage = parseRunningTime :: Parser DiffTime parseRunningTime = - option ((fromIntegral :: Int -> DiffTime) <$> auto) + Opt.option ((fromIntegral :: Int -> DiffTime) <$> auto) ( long "timeout" <> short 't' <> metavar "SECONDS" @@ -72,7 +73,7 @@ parseRunningTime = parseProgress :: Parser BlockNo parseProgress = - option ((fromIntegral :: Int -> BlockNo) <$> auto) + Opt.option ((fromIntegral :: Int -> BlockNo) <$> auto) ( long "require-progress" <> short 'p' <> metavar "INT" diff --git a/cardano-node/app/cardano-node.hs b/cardano-node/app/cardano-node.hs index 9da9009edbb..f9354dc3462 100644 --- a/cardano-node/app/cardano-node.hs +++ b/cardano-node/app/cardano-node.hs @@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} -import Cardano.Prelude hiding (option) +import Cardano.Prelude import qualified Data.Text as Text import Prelude (String) diff --git a/cardano-node/src/Cardano/Node/Parsers.hs b/cardano-node/src/Cardano/Node/Parsers.hs index 55b998e59ff..51df5b31807 100644 --- a/cardano-node/src/Cardano/Node/Parsers.hs +++ b/cardano-node/src/Cardano/Node/Parsers.hs @@ -11,7 +11,7 @@ module Cardano.Node.Parsers , renderHelpDoc ) where -import Cardano.Prelude hiding (option) +import Cardano.Prelude import Prelude (String) import Data.Time.Clock (secondsToDiffTime) @@ -141,7 +141,7 @@ parseTracerSocketMode = parseHostIPv4Addr :: Parser NodeHostIPv4Address parseHostIPv4Addr = - option (eitherReader parseNodeHostIPv4Address) ( + Opt.option (eitherReader parseNodeHostIPv4Address) ( long "host-addr" <> metavar "IPV4" <> help "An optional IPv4 address" @@ -149,7 +149,7 @@ parseHostIPv4Addr = parseHostIPv6Addr :: Parser NodeHostIPv6Address parseHostIPv6Addr = - option (eitherReader parseNodeHostIPv6Address) ( + Opt.option (eitherReader parseNodeHostIPv6Address) ( long "host-ipv6-addr" <> metavar "IPV6" <> help "An optional IPv6 address" @@ -175,7 +175,7 @@ parseNodeHostIPv6Address str = parsePort :: Parser PortNumber parsePort = - option ((fromIntegral :: Int -> PortNumber) <$> auto) ( + Opt.option ((fromIntegral :: Int -> PortNumber) <$> auto) ( long "port" <> metavar "PORT" <> help "The port number" @@ -197,7 +197,7 @@ parseMempoolCapacityOverride = parseOverride <|> parseNoOverride parseOverride :: Parser MempoolCapacityBytesOverride parseOverride = MempoolCapacityBytesOverride . MempoolCapacityBytes <$> - option (auto @Word32) + Opt.option (auto @Word32) ( long "mempool-capacity-override" <> metavar "BYTES" <> help "The number of bytes" @@ -227,7 +227,7 @@ parseValidateDB = parseShutdownIPC :: Parser Fd parseShutdownIPC = - option (Fd <$> auto) ( + Opt.option (Fd <$> auto) ( long "shutdown-ipc" <> metavar "FD" <> help "Shut down the process when this inherited FD reaches EOF" @@ -309,7 +309,7 @@ parseVrfKeyFilePath = parseSnapshotInterval :: Parser SnapshotInterval parseSnapshotInterval = fmap (RequestedSnapshotInterval . secondsToDiffTime) parseDifftime where - parseDifftime = option auto + parseDifftime = Opt.option auto ( long "snapshot-interval" <> metavar "SNAPSHOTINTERVAL" <> help "Snapshot Interval (in second)" From 1838c65fb5516ddab4660fd48bb6830533da83e3 Mon Sep 17 00:00:00 2001 From: John Ky Date: Tue, 4 Oct 2022 23:58:39 +1100 Subject: [PATCH 08/11] Use of $ operator should be followed by whitespace because $( is extrictly for TemplateHaskell --- .../Benchmarking/GeneratorTx/Tx/Byron.hs | 71 ------------------- .../src/Cardano/Benchmarking/Script/Core.hs | 2 +- 2 files changed, 1 insertion(+), 72 deletions(-) delete mode 100644 bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Tx/Byron.hs diff --git a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Tx/Byron.hs b/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Tx/Byron.hs deleted file mode 100644 index 6b98797fd63..00000000000 --- a/bench/tx-generator/src/Cardano/Benchmarking/GeneratorTx/Tx/Byron.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# OPTIONS_GHC -Wno-all-missed-specialisations -Wextra #-} - -module Cardano.Benchmarking.GeneratorTx.Tx.Byron - ( normalByronTxToGenTx - , byronGenesisUTxOTxIn - ) -where - -import Cardano.Prelude hiding (trace, (%)) -import Prelude (error) - -import qualified Data.Map.Strict as Map -import qualified Data.Text as T -import Formatting (sformat, (%)) - -import Cardano.Chain.Common (Address) -import qualified Cardano.Chain.Common as Common -import Cardano.Chain.Genesis as Genesis -import qualified Cardano.Chain.UTxO as UTxO -import qualified Cardano.Crypto.Signing as Crypto - -import Ouroboros.Consensus.Byron.Ledger (ByronBlock, GenTx (..)) -import qualified Ouroboros.Consensus.Byron.Ledger as Byron - --- | The 'GenTx' is all the kinds of transactions that can be submitted --- and \"normal\" Byron transactions are just one of the kinds. -normalByronTxToGenTx :: UTxO.ATxAux ByteString -> GenTx ByronBlock -normalByronTxToGenTx tx' = Byron.ByronTx (Byron.byronIdTx tx') tx' - --- | Given a genesis, and a pair of a genesis public key and address, --- reconstruct a TxIn corresponding to the genesis UTxO entry. -byronGenesisUTxOTxIn :: Genesis.Config -> Crypto.VerificationKey -> Common.Address -> UTxO.TxIn -byronGenesisUTxOTxIn gc vk genAddr = - handleMissingAddr $ fst <$> Map.lookup genAddr initialUtxo - where - initialUtxo :: Map Common.Address (UTxO.TxIn, UTxO.TxOut) - initialUtxo = - Map.fromList - . mapMaybe (\(inp, out) -> mkEntry inp genAddr <$> keyMatchesUTxO vk out) - . map (bimap UTxO.fromCompactTxIn UTxO.fromCompactTxOut) - . Map.toList - . UTxO.unUTxO - . UTxO.genesisUtxo - $ gc - - mkEntry :: UTxO.TxIn - -> Address - -> UTxO.TxOut - -> (Address, (UTxO.TxIn, UTxO.TxOut)) - mkEntry inp addr out = (addr, (inp, out)) - - keyMatchesUTxO :: Crypto.VerificationKey -> UTxO.TxOut -> Maybe UTxO.TxOut - keyMatchesUTxO key out = - if Common.checkVerKeyAddress key (UTxO.txOutAddress out) - then Just out else Nothing - - handleMissingAddr :: Maybe UTxO.TxIn -> UTxO.TxIn - handleMissingAddr = fromMaybe . error - $ "\nGenesis UTxO has no address\n" - <> T.unpack (prettyAddress genAddr) - <> "\n\nIt has the following, though:\n\n" - <> Cardano.Prelude.concat (T.unpack . prettyAddress <$> Map.keys initialUtxo) - - prettyAddress :: Common.Address -> Text - prettyAddress addr = sformat - (Common.addressF % "\n" % Common.addressDetailedF) - addr addr diff --git a/bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs b/bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs index 604b6b24265..5a1eb6fd139 100644 --- a/bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs +++ b/bench/tx-generator/src/Cardano/Benchmarking/Script/Core.hs @@ -145,7 +145,7 @@ getConnectClient = do tracers <- get BenchTracers (Testnet networkMagic) <- getUser TNetworkId protocol <- get Protocol - void $ return $(btSubmission2_ tracers) + void $ return $ btSubmission2_ tracers -- TODO this line looks strange ioManager <- askIOManager return $ benchmarkConnectTxSubmit ioManager From efb6327cd7610eace709c89eef4af425ca350598 Mon Sep 17 00:00:00 2001 From: John Ky Date: Wed, 5 Oct 2022 00:00:32 +1100 Subject: [PATCH 09/11] Add missing type signature of top level function --- bench/tx-generator/test/Main.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/bench/tx-generator/test/Main.hs b/bench/tx-generator/test/Main.hs index 9f4336d482a..25575148f31 100644 --- a/bench/tx-generator/test/Main.hs +++ b/bench/tx-generator/test/Main.hs @@ -17,6 +17,7 @@ tests = testGroup "cardano-tx-generator" sizedMetadata ] +sizedMetadata :: TestTree sizedMetadata = testGroup "properties of the CBOR encoding relevant for generating sized metadat" [ testCase "Shelley metadata map costs" $ assertBool "metadata map costs" prop_mapCostsShelley , testCase "Shelley metadata ByteString costs" $ assertBool "metadata ByteString costs" prop_bsCostsShelley From e609e79b0bdf7895271000ae5178d08b9acdcc2d Mon Sep 17 00:00:00 2001 From: John Ky Date: Wed, 5 Oct 2022 00:02:26 +1100 Subject: [PATCH 10/11] Remove unused dependencies --- cardano-api/cardano-api.cabal | 2 -- cardano-cli/cardano-cli.cabal | 1 - cardano-node-chairman/cardano-node-chairman.cabal | 1 - cardano-node/cardano-node.cabal | 2 -- cardano-testnet/cardano-testnet.cabal | 1 - cardano-tracer/cardano-tracer.cabal | 2 -- 6 files changed, 9 deletions(-) diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index 6264baa497a..b3a614f9963 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -201,10 +201,8 @@ test-suite cardano-api-test type: exitcode-stdio-1.0 build-depends: aeson >= 1.5.6.0 - , bytestring , cardano-api , cardano-api:gen - , cardano-binary , cardano-data , cardano-crypto , cardano-crypto-class diff --git a/cardano-cli/cardano-cli.cabal b/cardano-cli/cardano-cli.cabal index 849697dc899..8d5bb7e1099 100644 --- a/cardano-cli/cardano-cli.cabal +++ b/cardano-cli/cardano-cli.cabal @@ -171,7 +171,6 @@ test-suite cardano-cli-test build-depends: aeson , bech32 >= 1.1.0 - , bytestring , base16-bytestring , cardano-api , cardano-api:gen diff --git a/cardano-node-chairman/cardano-node-chairman.cabal b/cardano-node-chairman/cardano-node-chairman.cabal index 36b8c53abea..08541fe889c 100644 --- a/cardano-node-chairman/cardano-node-chairman.cabal +++ b/cardano-node-chairman/cardano-node-chairman.cabal @@ -40,7 +40,6 @@ executable cardano-node-chairman "-with-rtsopts=-T" build-depends: cardano-api , cardano-git-rev - , cardano-ledger-byron , cardano-node , cardano-prelude , containers diff --git a/cardano-node/cardano-node.cabal b/cardano-node/cardano-node.cabal index 0c8b99c3e7b..81e777f968e 100644 --- a/cardano-node/cardano-node.cabal +++ b/cardano-node/cardano-node.cabal @@ -129,7 +129,6 @@ library , async , base16-bytestring , bytestring - , deepseq , cardano-api , cardano-data , cardano-git-rev @@ -176,7 +175,6 @@ library , scientific , strict-stm , cardano-ledger-shelley - , small-steps , stm , text , time diff --git a/cardano-testnet/cardano-testnet.cabal b/cardano-testnet/cardano-testnet.cabal index c2a1bb940d9..d0889a14bad 100644 --- a/cardano-testnet/cardano-testnet.cabal +++ b/cardano-testnet/cardano-testnet.cabal @@ -34,7 +34,6 @@ library , cardano-api , cardano-cli , cardano-node - , cardano-slotting , containers , directory , exceptions diff --git a/cardano-tracer/cardano-tracer.cabal b/cardano-tracer/cardano-tracer.cabal index 536b36e4ecd..4c4edf21247 100644 --- a/cardano-tracer/cardano-tracer.cabal +++ b/cardano-tracer/cardano-tracer.cabal @@ -123,7 +123,6 @@ library , async-extras , bimap , blaze-html - , blaze-markup , bytestring , cardano-git-rev , cardano-node @@ -274,7 +273,6 @@ test-suite cardano-tracer-test , filepath , ouroboros-network , ouroboros-network-framework - , QuickCheck , stm , tasty , tasty-quickcheck From c22f52379b4ebd96f55f92db6e44fdc21e54afb6 Mon Sep 17 00:00:00 2001 From: John Ky Date: Wed, 5 Oct 2022 00:07:09 +1100 Subject: [PATCH 11/11] Qualified import of Data.Text.Lazy --- cardano-api/src/Cardano/Api/LedgerState.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/cardano-api/src/Cardano/Api/LedgerState.hs b/cardano-api/src/Cardano/Api/LedgerState.hs index afcce8df950..5abadb7303a 100644 --- a/cardano-api/src/Cardano/Api/LedgerState.hs +++ b/cardano-api/src/Cardano/Api/LedgerState.hs @@ -82,7 +82,7 @@ import Data.SOP.Strict (NP (..)) import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text -import Data.Text.Lazy (toStrict) +import qualified Data.Text.Lazy as LT import Data.Text.Lazy.Builder (toLazyText) import Data.Word import qualified Data.Yaml as Yaml @@ -1294,7 +1294,7 @@ instance Error LeadershipError where displayError LeaderErrDecodeLedgerStateFailure = "Failed to successfully decode ledger state" displayError (LeaderErrDecodeProtocolStateFailure (_, decErr)) = - "Failed to successfully decode protocol state: " <> Text.unpack (toStrict . toLazyText $ build decErr) + "Failed to successfully decode protocol state: " <> Text.unpack (LT.toStrict . toLazyText $ build decErr) displayError LeaderErrGenesisSlot = "Leadership schedule currently cannot be calculated from genesis" displayError (LeaderErrStakePoolHasNoStake poolId) =