From dc0816461f3f1470bc2ac6d177f075b0bb505f53 Mon Sep 17 00:00:00 2001 From: paolino Date: Sun, 28 Jul 2024 08:15:19 +0000 Subject: [PATCH] Reformat Cardano.Wallet.Application --- lib/exe/lib/Cardano/Wallet/Application.hs | 381 ++++++++++++---------- 1 file changed, 205 insertions(+), 176 deletions(-) diff --git a/lib/exe/lib/Cardano/Wallet/Application.hs b/lib/exe/lib/Cardano/Wallet/Application.hs index 7b0947abc08..dfb35c35462 100644 --- a/lib/exe/lib/Cardano/Wallet/Application.hs +++ b/lib/exe/lib/Cardano/Wallet/Application.hs @@ -20,7 +20,6 @@ -- -- Functionality specific to this backend for creating transactions is in -- "Cardano.Wallet.Shelley.Transaction" - module Cardano.Wallet.Application ( serveWallet , module Tracers @@ -261,193 +260,223 @@ serveWallet -- ^ Callback to run before the main loop -> IO ExitCode serveWallet - blockchainSource - netParams@NetworkParameters - { protocolParameters - , slottingParameters - } - pipeliningStrategy - network - shelleyGenesisPools - Tracers{..} - databaseDir - mPoolDatabaseDecorator - hostPref - listen - tlsConfig - settings - tokenMetaUri - block0 - beforeMainLoop = withSNetworkId network $ \sNetwork -> evalContT $ do - let netId = networkIdVal sNetwork - lift $ case blockchainSource of - NodeSource nodeConn _ _ -> trace $ MsgStartingNode nodeConn - lift . trace - $ MsgNetworkName - $ networkDiscriminantVal sNetwork - netLayer <- withNetworkLayer - networkTracer - pipeliningStrategy - blockchainSource - network - netParams - stakePoolLayer <- case blockchainSource of - NodeSource{} -> do - stakePoolDbLayer <- withStakePoolDbLayer - poolsDbTracer - databaseDir - mPoolDatabaseDecorator - netLayer - withNodeStakePoolLayer - poolsEngineTracer - settings - stakePoolDbLayer + blockchainSource + netParams@NetworkParameters + { protocolParameters + , slottingParameters + } + pipeliningStrategy + network + shelleyGenesisPools + Tracers{..} + databaseDir + mPoolDatabaseDecorator + hostPref + listen + tlsConfig + settings + tokenMetaUri + block0 + beforeMainLoop = withSNetworkId network $ \sNetwork -> evalContT $ do + let netId = networkIdVal sNetwork + lift $ case blockchainSource of + NodeSource nodeConn _ _ -> trace $ MsgStartingNode nodeConn + lift . trace + $ MsgNetworkName + $ networkDiscriminantVal sNetwork + netLayer <- + withNetworkLayer + networkTracer + pipeliningStrategy + blockchainSource + network netParams - shelleyGenesisPools - netLayer - randomApi <- withRandomApi netId netLayer - icarusApi <- withIcarusApi netId netLayer - shelleyApi <- withShelleyApi netId netLayer - multisigApi <- withMultisigApi netId netLayer - ntpClient <- withNtpClient ntpClientTracer - bindSocket >>= lift . \case - Left err -> do - trace $ MsgServerStartupError err - pure $ ExitFailure $ exitCodeApiServer err - Right (_port, socket) -> do - startServer - sNetwork - socket - randomApi - icarusApi - shelleyApi - multisigApi - stakePoolLayer - ntpClient - pure ExitSuccess + stakePoolLayer <- case blockchainSource of + NodeSource{} -> do + stakePoolDbLayer <- + withStakePoolDbLayer + poolsDbTracer + databaseDir + mPoolDatabaseDecorator + netLayer + withNodeStakePoolLayer + poolsEngineTracer + settings + stakePoolDbLayer + netParams + shelleyGenesisPools + netLayer + randomApi <- withRandomApi netId netLayer + icarusApi <- withIcarusApi netId netLayer + shelleyApi <- withShelleyApi netId netLayer + multisigApi <- withMultisigApi netId netLayer + ntpClient <- withNtpClient ntpClientTracer + eSocket <- bindSocket + lift $ case eSocket of + Left err -> do + trace $ MsgServerStartupError err + pure $ ExitFailure $ exitCodeApiServer err + Right (_port, socket) -> do + startServer + sNetwork + socket + randomApi + icarusApi + shelleyApi + multisigApi + stakePoolLayer + ntpClient + pure ExitSuccess + where + trace :: ApplicationLog -> IO () + trace = traceWith applicationTracer - where - trace :: ApplicationLog -> IO () - trace = traceWith applicationTracer - - bindSocket :: ContT r IO (Either ListenError (Warp.Port, Socket)) - bindSocket = ContT $ Server.withListeningSocket hostPref listen + bindSocket :: ContT r IO (Either ListenError (Warp.Port, Socket)) + bindSocket = ContT $ Server.withListeningSocket hostPref listen - withRandomApi netId netLayer = - lift $ apiLayer (newTransactionLayer ByronKeyS netId) - netLayer Server.idleWorker + withRandomApi netId netLayer = + lift + $ apiLayer + (newTransactionLayer ByronKeyS netId) + netLayer + Server.idleWorker - withIcarusApi netId netLayer = - lift $ apiLayer (newTransactionLayer IcarusKeyS netId) - netLayer Server.idleWorker + withIcarusApi netId netLayer = + lift + $ apiLayer + (newTransactionLayer IcarusKeyS netId) + netLayer + Server.idleWorker - withShelleyApi netId netLayer = - lift $ apiLayer (newTransactionLayer ShelleyKeyS netId) netLayer - $ \wrk _ -> Server.manageRewardBalance - <$> view typed - <*> pure netLayer - <*> view typed - $ wrk + withShelleyApi netId netLayer = + lift + $ apiLayer (newTransactionLayer ShelleyKeyS netId) netLayer + $ \wrk _ -> + Server.manageRewardBalance + <$> view typed + <*> pure netLayer + <*> view typed + $ wrk - withMultisigApi netId netLayer = - lift $ apiLayer (newTransactionLayer SharedKeyS netId) netLayer Server.idleWorker + withMultisigApi netId netLayer = + lift + $ apiLayer + (newTransactionLayer SharedKeyS netId) + netLayer + Server.idleWorker - startServer - :: forall n. - ( HasSNetworkId n - , Typeable n - ) - => SNetworkId n - -> Socket - -> ApiLayer (RndState n) - -> ApiLayer (SeqState n IcarusKey) - -> ApiLayer (SeqState n ShelleyKey) - -> ApiLayer (SharedState n SharedKey) - -> StakePoolLayer - -> NtpClient - -> IO () - startServer _proxy socket byron icarus shelley multisig spl ntp = do - serverUrl <- getServerUrl tlsConfig socket - let serverSettings = Warp.defaultSettings - & setBeforeMainLoop (beforeMainLoop serverUrl) - api = Proxy @(ApiV2 n) - let application = Server.serve api - $ Servant.hoistServer api handleWalletExceptions - $ server byron icarus shelley multisig spl ntp blockchainSource - Server.start serverSettings apiServerTracer tlsConfig socket application + startServer + :: forall n + . ( HasSNetworkId n + , Typeable n + ) + => SNetworkId n + -> Socket + -> ApiLayer (RndState n) + -> ApiLayer (SeqState n IcarusKey) + -> ApiLayer (SeqState n ShelleyKey) + -> ApiLayer (SharedState n SharedKey) + -> StakePoolLayer + -> NtpClient + -> IO () + startServer _proxy socket byron icarus shelley multisig spl ntp = do + serverUrl <- getServerUrl tlsConfig socket + let serverSettings = + Warp.defaultSettings + & setBeforeMainLoop (beforeMainLoop serverUrl) + api = Proxy @(ApiV2 n) + application = + Server.serve api + $ Servant.hoistServer api handleWalletExceptions + $ server + byron + icarus + shelley + multisig + spl + ntp + blockchainSource + Server.start + serverSettings + apiServerTracer + tlsConfig + socket + application - apiLayer - :: forall s k . - ( IsOurs s Address - , IsOurs s RewardAccount - , MaybeLight s - , PersistAddressBook s - , WalletFlavor s - , KeyOf s ~ k - ) - => TransactionLayer k (CredFromOf s) SealedTx - -> NetworkLayer IO (CardanoBlock StandardCrypto) - -> (WorkerCtx (ApiLayer s) -> WalletId -> IO ()) - -> IO (ApiLayer s) - apiLayer txLayer netLayer coworker = do - tokenMetaClient <- newMetadataClient tokenMetadataTracer tokenMetaUri - dbFactory <- Sqlite.newDBFactory - (walletFlavor @s) - walletDbTracer - (DefaultFieldValues - { defaultActiveSlotCoefficient = - getActiveSlotCoefficient slottingParameters - , defaultDesiredNumberOfPool = - desiredNumberOfStakePools protocolParameters - , defaultMinimumUTxOValue = Coin 0 - -- Unused; value does not matter anymore. - , defaultHardforkEpoch = Nothing - -- NOTE: see ADP-643 - -- - -- In ADP-470, we've made it possible to distinguish fees from - -- deposits in the API. This however required a database - -- migration for which the stake key deposit in vigor is needed. - -- This value normally comes from the Shelley genesis file, but - -- we have no direct access to it, nor can we reliably query the - -- network layer to get the current parameters. Indeed, the - -- `currentProtocolParameters` and `currentSlottingParameters` - -- functions both rely on the LSQ protocol, which would: - -- - -- a) Fail if the wallet and the node are drifting too much - -- b) Return potentially outdated information if the node is - -- not synced. - -- - -- Since the migration is only strictly needed for pre-existing - -- mainnet and testnet wallet, we currently hard-code the stake - -- key deposit value that _should_ be used for the migration - -- (which fortunately happens to be the same on both networks). - -- - -- It'll do, but it ain't pretty. Without requiring the Shelley - -- genesis to be provided as argument I currently have no better - -- and safer idea than hard-coding it. And also have very little - -- time to do anything fancier. - , defaultKeyDeposit = - Coin 2_000_000 - } - ) - (neverFails "db layer should never forecast into the future" - $ timeInterpreter netLayer) - databaseDir - Server.newApiLayer - walletEngineTracer - (block0, netParams) - netLayer - txLayer - dbFactory - tokenMetaClient - coworker + apiLayer + :: forall s k + . ( IsOurs s Address + , IsOurs s RewardAccount + , MaybeLight s + , PersistAddressBook s + , WalletFlavor s + , KeyOf s ~ k + ) + => TransactionLayer k (CredFromOf s) SealedTx + -> NetworkLayer IO (CardanoBlock StandardCrypto) + -> (WorkerCtx (ApiLayer s) -> WalletId -> IO ()) + -> IO (ApiLayer s) + apiLayer txLayer netLayer coworker = do + tokenMetaClient <- newMetadataClient tokenMetadataTracer tokenMetaUri + dbFactory <- + Sqlite.newDBFactory + (walletFlavor @s) + walletDbTracer + ( DefaultFieldValues + { defaultActiveSlotCoefficient = + getActiveSlotCoefficient slottingParameters + , defaultDesiredNumberOfPool = + desiredNumberOfStakePools protocolParameters + , defaultMinimumUTxOValue = Coin 0 + , -- Unused; value does not matter anymore. + defaultHardforkEpoch = Nothing + , -- NOTE: see ADP-643 + -- + -- In ADP-470, we've made it possible to distinguish fees from + -- deposits in the API. This however required a database + -- migration for which the stake key deposit in vigor is needed. + -- This value normally comes from the Shelley genesis file, but + -- we have no direct access to it, nor can we reliably query the + -- network layer to get the current parameters. Indeed, the + -- `currentProtocolParameters` and `currentSlottingParameters` + -- functions both rely on the LSQ protocol, which would: + -- + -- a) Fail if the wallet and the node are drifting too much + -- b) Return potentially outdated information if the node is + -- not synced. + -- + -- Since the migration is only strictly needed for pre-existing + -- mainnet and testnet wallet, we currently hard-code the stake + -- key deposit value that _should_ be used for the migration + -- (which fortunately happens to be the same on both networks). + -- + -- It'll do, but it ain't pretty. Without requiring the Shelley + -- genesis to be provided as argument I currently have no better + -- and safer idea than hard-coding it. And also have very little + -- time to do anything fancier. + defaultKeyDeposit = + Coin 2_000_000 + } + ) + ( neverFails "db layer should never forecast into the future" + $ timeInterpreter netLayer + ) + databaseDir + Server.newApiLayer + walletEngineTracer + (block0, netParams) + netLayer + txLayer + dbFactory + tokenMetaClient + coworker handleWalletExceptions :: forall x. Servant.Handler x -> Servant.Handler x handleWalletExceptions = Servant.Handler - . ExceptT - . handle (pure . Left . toServerError @WalletException) - . Servant.runHandler + . ExceptT + . handle (pure . Left . toServerError @WalletException) + . Servant.runHandler withNtpClient :: Tracer IO NtpTrace -> ContT r IO NtpClient withNtpClient tr = do