From cea4cdcaeb096c931e99e9b41d22532a9c50f949 Mon Sep 17 00:00:00 2001 From: Johannes Lund Date: Tue, 27 Oct 2020 16:03:08 +0100 Subject: [PATCH] Fix listWallets race condition --- lib/core/cardano-wallet-core.cabal | 1 + lib/core/src/Cardano/Wallet/Api/Server.hs | 31 +++++++++--- lib/core/src/Cardano/Wallet/Api/Types.hs | 49 +++++++++++++++++++ .../src/Cardano/Wallet/Primitive/Types.hs | 2 + 4 files changed, 76 insertions(+), 7 deletions(-) diff --git a/lib/core/cardano-wallet-core.cabal b/lib/core/cardano-wallet-core.cabal index 59526f4d5a6..df732280479 100644 --- a/lib/core/cardano-wallet-core.cabal +++ b/lib/core/cardano-wallet-core.cabal @@ -81,6 +81,7 @@ library , random-shuffle , retry , safe + , safe-exceptions , scientific , scrypt , servant diff --git a/lib/core/src/Cardano/Wallet/Api/Server.hs b/lib/core/src/Cardano/Wallet/Api/Server.hs index 29bfc04e322..af8539716eb 100644 --- a/lib/core/src/Cardano/Wallet/Api/Server.hs +++ b/lib/core/src/Cardano/Wallet/Api/Server.hs @@ -332,13 +332,17 @@ import Control.Arrow import Control.Concurrent ( threadDelay ) import Control.Concurrent.Async - ( race_ ) + ( race_, withAsync ) +import Control.DeepSeq + ( NFData, deepseq, ($!!) ) import Control.Exception - ( IOException, bracket, throwIO, try, tryJust ) + ( IOException, SomeException, bracket, evaluate, throwIO, tryJust ) +import Control.Exception.Safe + ( tryAnyDeep ) import Control.Monad - ( forM, forever, void, when, (>=>) ) + ( forM, forever, join, void, when, (>=>) ) import Control.Monad.Catch - ( handle ) + ( MonadCatch, catch, handle, try ) import Control.Monad.IO.Class ( MonadIO, liftIO ) import Control.Monad.Trans.Class @@ -346,7 +350,7 @@ import Control.Monad.Trans.Class import Control.Monad.Trans.Except ( ExceptT (..), runExceptT, throwE, withExceptT ) import Control.Monad.Trans.Maybe - ( MaybeT (..) ) + ( MaybeT (..), exceptToMaybeT ) import Control.Tracer ( Tracer ) import Data.Aeson @@ -357,6 +361,8 @@ import Data.ByteString ( ByteString ) import Data.Coerce ( coerce ) +import Data.Either.Extra + ( eitherToMaybe ) import Data.Function ( (&) ) import Data.Functor @@ -372,7 +378,7 @@ import Data.List.NonEmpty import Data.Map.Strict ( Map ) import Data.Maybe - ( fromMaybe, isJust ) + ( catMaybes, fromMaybe, isJust ) import Data.Proxy ( Proxy (..) ) import Data.Quantity @@ -1046,16 +1052,27 @@ getWallet ctx mkApiWallet (ApiT wid) = do listWallets :: forall ctx s t k apiWallet. ( ctx ~ ApiLayer s t k + , NFData apiWallet + , Show apiWallet ) => ctx -> MkApiWallet ctx s apiWallet -> Handler [(apiWallet, UTCTime)] listWallets ctx mkApiWallet = do wids <- liftIO $ listDatabases df - sortOn snd <$> mapM (getWallet ctx mkApiWallet) (ApiT <$> wids) + liftIO $ sortOn snd . catMaybes <$> mapM maybeGetWallet (ApiT <$> wids) where df = ctx ^. dbFactory @s @k + -- Under extreme circumstances (like integration tests running in parallel) + -- there may be race conditions where the wallet is deleted just before we + -- try to read it. + -- + -- ... or not? + maybeGetWallet :: ApiT WalletId -> IO (Maybe (apiWallet, UTCTime)) + maybeGetWallet = + fmap (join . eitherToMaybe) . tryAnyDeep . fmap eitherToMaybe . runHandler . getWallet ctx mkApiWallet + putWallet :: forall ctx s t k apiWallet. ( ctx ~ ApiLayer s t k diff --git a/lib/core/src/Cardano/Wallet/Api/Types.hs b/lib/core/src/Cardano/Wallet/Api/Types.hs index 9ab460121e3..5f670128ad0 100644 --- a/lib/core/src/Cardano/Wallet/Api/Types.hs +++ b/lib/core/src/Cardano/Wallet/Api/Types.hs @@ -1,5 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} @@ -218,6 +219,8 @@ import Control.Applicative ( optional, (<|>) ) import Control.Arrow ( left ) +import Control.DeepSeq + ( NFData ) import Control.Monad ( guard, (>=>) ) import Data.Aeson @@ -383,11 +386,13 @@ data ApiAddress (n :: NetworkDiscriminant) = ApiAddress { id :: !(ApiT Address, Proxy n) , state :: !(ApiT AddressState) } deriving (Eq, Generic, Show) + deriving anyclass NFData data ApiEpochInfo = ApiEpochInfo { epochNumber :: !(ApiT EpochNo) , epochStartTime :: !UTCTime } deriving (Eq, Generic, Show) + deriving anyclass NFData data ApiSelectCoinsData (n :: NetworkDiscriminant) = ApiSelectForPayment (ApiSelectCoinsPayments n) @@ -397,6 +402,7 @@ data ApiSelectCoinsData (n :: NetworkDiscriminant) newtype ApiSelectCoinsPayments (n :: NetworkDiscriminant) = ApiSelectCoinsPayments { payments :: NonEmpty (AddressAmount (ApiT Address, Proxy n)) } deriving (Eq, Generic, Show) + deriving anyclass NFData newtype ApiSelectCoinsAction = ApiSelectCoinsAction { delegationAction :: ApiT DelegationAction @@ -414,6 +420,7 @@ data ApiCertificate { rewardAccountPath :: NonEmpty (ApiT DerivationIndex) } deriving (Eq, Generic, Show) + deriving anyclass NFData data ApiCoinSelection (n :: NetworkDiscriminant) = ApiCoinSelection { inputs :: !(NonEmpty (ApiCoinSelectionInput n)) @@ -421,12 +428,14 @@ data ApiCoinSelection (n :: NetworkDiscriminant) = ApiCoinSelection , change :: ![ApiCoinSelectionChange n] , certificates :: Maybe (NonEmpty ApiCertificate) } deriving (Eq, Generic, Show) + deriving anyclass NFData data ApiCoinSelectionChange (n :: NetworkDiscriminant) = ApiCoinSelectionChange { address :: !(ApiT Address, Proxy n) , amount :: !(Quantity "lovelace" Natural) , derivationPath :: NonEmpty (ApiT DerivationIndex) } deriving (Eq, Generic, Show) + deriving anyclass NFData data ApiCoinSelectionInput (n :: NetworkDiscriminant) = ApiCoinSelectionInput { id :: !(ApiT (Hash "Tx")) @@ -435,11 +444,13 @@ data ApiCoinSelectionInput (n :: NetworkDiscriminant) = ApiCoinSelectionInput , derivationPath :: NonEmpty (ApiT DerivationIndex) , amount :: !(Quantity "lovelace" Natural) } deriving (Eq, Generic, Show) + deriving anyclass NFData data ApiCoinSelectionOutput (n :: NetworkDiscriminant) = ApiCoinSelectionOutput { address :: !(ApiT Address, Proxy n) , amount :: !(Quantity "lovelace" Natural) } deriving (Eq, Ord, Generic, Show) + deriving anyclass NFData data ApiWallet = ApiWallet { id :: !(ApiT WalletId) @@ -451,30 +462,36 @@ data ApiWallet = ApiWallet , state :: !(ApiT SyncProgress) , tip :: !ApiBlockReference } deriving (Eq, Generic, Show) + deriving anyclass NFData newtype ApiWalletPassphraseInfo = ApiWalletPassphraseInfo { lastUpdatedAt :: UTCTime } deriving (Eq, Generic, Show) + deriving anyclass NFData data ApiWalletDelegation = ApiWalletDelegation { active :: !ApiWalletDelegationNext , next :: ![ApiWalletDelegationNext] } deriving (Eq, Generic, Show) + deriving anyclass NFData data ApiWalletDelegationNext = ApiWalletDelegationNext { status :: !ApiWalletDelegationStatus , target :: !(Maybe (ApiT PoolId)) , changesAt :: !(Maybe ApiEpochInfo) } deriving (Eq, Generic, Show) + deriving anyclass NFData data ApiWalletDelegationStatus = NotDelegating | Delegating deriving (Eq, Generic, Show) + deriving anyclass NFData newtype ApiWalletPassphrase = ApiWalletPassphrase { passphrase :: ApiT (Passphrase "lenient") } deriving (Eq, Generic, Show) + deriving anyclass NFData data ApiStakePool = ApiStakePool { id :: !(ApiT PoolId) @@ -492,12 +509,14 @@ data ApiStakePoolMetrics = ApiStakePoolMetrics , saturation :: !Double , producedBlocks :: !(Quantity "block" Natural) } deriving (Eq, Generic, Show) + deriving anyclass NFData data ApiUtxoStatistics = ApiUtxoStatistics { total :: !(Quantity "lovelace" Natural) , scale :: !(ApiT BoundType) , distribution :: !(Map Word64 Word64) } deriving (Eq, Generic, Show) + deriving anyclass NFData toApiUtxoStatistics :: UTxOStatistics -> ApiUtxoStatistics toApiUtxoStatistics (UTxOStatistics histo totalStakes bType) = @@ -542,10 +561,12 @@ data ByronWalletFromXPrvPostData = ByronWalletFromXPrvPostData -- - r = 8 -- - p = 1 } deriving (Eq, Generic, Show) + deriving anyclass NFData newtype ApiAccountPublicKey = ApiAccountPublicKey { key :: (ApiT XPub) } deriving (Eq, Generic, Show) + deriving anyclass NFData newtype WalletOrAccountPostData = WalletOrAccountPostData { postData :: Either WalletPostData AccountPostData @@ -639,6 +660,7 @@ toApiNetworkParameters (NetworkParameters gp pp) = (np, view #hardforkEpochNo pp newtype ApiTxId = ApiTxId { id :: ApiT (Hash "Tx") } deriving (Eq, Generic, Show) + deriving anyclass NFData data ApiTransaction (n :: NetworkDiscriminant) = ApiTransaction { id :: !(ApiT (Hash "Tx")) @@ -654,15 +676,18 @@ data ApiTransaction (n :: NetworkDiscriminant) = ApiTransaction , status :: !(ApiT TxStatus) , metadata :: !ApiTxMetadata } deriving (Eq, Generic, Show) + deriving anyclass NFData newtype ApiTxMetadata = ApiTxMetadata { getApiTxMetadata :: Maybe (ApiT TxMetadata) } deriving (Eq, Generic, Show) + deriving anyclass NFData data ApiWithdrawal n = ApiWithdrawal { stakeAddress :: !(ApiT ChimericAccount, Proxy n) , amount :: !(Quantity "lovelace" Natural) } deriving (Eq, Generic, Show) + deriving anyclass NFData data ApiWithdrawalPostData = SelfWithdrawal @@ -673,31 +698,37 @@ data ApiTxInput (n :: NetworkDiscriminant) = ApiTxInput { source :: !(Maybe (AddressAmount (ApiT Address, Proxy n))) , input :: !(ApiT TxIn) } deriving (Eq, Generic, Show) + deriving anyclass NFData data AddressAmount addr = AddressAmount { address :: !addr , amount :: !(Quantity "lovelace" Natural) } deriving (Eq, Generic, Show) + deriving anyclass NFData newtype ApiAddressInspect = ApiAddressInspect { unApiAddressInspect :: Aeson.Value } deriving (Eq, Generic, Show) + deriving anyclass NFData newtype ApiAddressInspectData = ApiAddressInspectData { unApiAddressInspectData :: Text } deriving (Eq, Generic, Show) deriving newtype (IsString) + deriving anyclass NFData data ApiSlotReference = ApiSlotReference { absoluteSlotNumber :: !(ApiT SlotNo) , slotId :: !ApiSlotId , time :: !UTCTime } deriving (Eq, Generic, Show) + deriving anyclass NFData data ApiSlotId = ApiSlotId { epochNumber :: !(ApiT EpochNo) , slotNumber :: !(ApiT SlotInEpoch) } deriving (Eq, Generic, Show) + deriving anyclass NFData data ApiBlockReference = ApiBlockReference { absoluteSlotNumber :: !(ApiT SlotNo) @@ -705,10 +736,12 @@ data ApiBlockReference = ApiBlockReference , time :: !UTCTime , block :: !ApiBlockInfo } deriving (Eq, Generic, Show) + deriving anyclass NFData newtype ApiBlockInfo = ApiBlockInfo { height :: Quantity "block" Natural } deriving (Eq, Generic, Show) + deriving anyclass NFData data ApiNetworkInformation = ApiNetworkInformation { syncProgress :: !(ApiT SyncProgress) @@ -716,26 +749,31 @@ data ApiNetworkInformation = ApiNetworkInformation , nodeTip :: !ApiBlockReference , networkTip :: !(Maybe ApiSlotReference) } deriving (Eq, Generic, Show) + deriving anyclass NFData data NtpSyncingStatus = NtpSyncingStatusUnavailable | NtpSyncingStatusPending | NtpSyncingStatusAvailable deriving (Eq, Generic, Show) + deriving anyclass NFData data ApiNtpStatus = ApiNtpStatus { status :: !NtpSyncingStatus , offset :: !(Maybe (Quantity "microsecond" Integer)) } deriving (Eq, Generic, Show) + deriving anyclass NFData newtype ApiNetworkClock = ApiNetworkClock { ntpStatus :: ApiNtpStatus } deriving (Eq, Generic, Show) + deriving anyclass NFData data ApiPostRandomAddressData = ApiPostRandomAddressData { passphrase :: !(ApiT (Passphrase "lenient")) , addressIndex :: !(Maybe (ApiT (Index 'AD.Hardened 'AddressK))) } deriving (Eq, Generic, Show) + deriving anyclass NFData data ApiWalletMigrationPostData (n :: NetworkDiscriminant) (s :: Symbol) = @@ -743,27 +781,33 @@ data ApiWalletMigrationPostData (n :: NetworkDiscriminant) (s :: Symbol) = { passphrase :: !(ApiT (Passphrase s)) , addresses :: ![(ApiT Address, Proxy n)] } deriving (Eq, Generic, Show) + deriving anyclass NFData newtype ApiPutAddressesData (n :: NetworkDiscriminant) = ApiPutAddressesData { addresses :: [(ApiT Address, Proxy n)] } deriving (Eq, Generic, Show) + deriving anyclass NFData data ApiWalletMigrationInfo = ApiWalletMigrationInfo { migrationCost :: Quantity "lovelace" Natural , leftovers :: Quantity "lovelace" Natural } deriving (Eq, Generic, Show) + deriving anyclass NFData newtype ApiWithdrawRewards = ApiWithdrawRewards Bool deriving (Eq, Generic, Show) + deriving anyclass NFData data ApiWalletSignData = ApiWalletSignData { metadata :: ApiT TxMetadata , passphrase :: ApiT (Passphrase "lenient") } deriving (Eq, Generic, Show) + deriving anyclass NFData newtype ApiVerificationKey = ApiVerificationKey { getApiVerificationKey :: (XPub, AccountingStyle) } deriving (Eq, Generic, Show) + deriving anyclass NFData -- | Error codes returned by the API, in the form of snake_cased strings data ApiErrorCode @@ -816,6 +860,7 @@ data ApiErrorCode | UnableToAssignInputOutput | SoftDerivationRequired deriving (Eq, Generic, Show) + deriving anyclass NFData -- | Defines a point in time that can be formatted as and parsed from an -- ISO 8601-compliant string. @@ -940,11 +985,13 @@ data ApiByronWallet = ApiByronWallet , state :: !(ApiT SyncProgress) , tip :: !ApiBlockReference } deriving (Eq, Generic, Show) + deriving anyclass NFData data ApiWalletDiscovery = DiscoveryRandom | DiscoverySequential deriving (Eq, Generic, Show) + deriving anyclass NFData class KnownDiscovery s where knownDiscovery :: ApiWalletDiscovery @@ -966,6 +1013,7 @@ instance KnownDiscovery (SeqState network key) where newtype ApiT a = ApiT { getApiT :: a } deriving (Generic, Show, Eq, Functor) + deriving anyclass NFData deriving instance Ord a => Ord (ApiT a) -- | Representation of mnemonics at the API-level, using a polymorphic type in @@ -1339,6 +1387,7 @@ data ApiByronWalletBalance = ApiByronWalletBalance { available :: !(Quantity "lovelace" Natural) , total :: !(Quantity "lovelace" Natural) } deriving (Eq, Generic, Show) + deriving anyclass NFData instance FromJSON ApiByronWalletBalance where parseJSON = genericParseJSON defaultRecordTypeOptions diff --git a/lib/core/src/Cardano/Wallet/Primitive/Types.hs b/lib/core/src/Cardano/Wallet/Primitive/Types.hs index e64186c0a53..1988e43fce9 100644 --- a/lib/core/src/Cardano/Wallet/Primitive/Types.hs +++ b/lib/core/src/Cardano/Wallet/Primitive/Types.hs @@ -459,6 +459,8 @@ data WalletBalance = WalletBalance , reward :: !(Quantity "lovelace" Natural) } deriving (Eq, Generic, Show) +instance NFData WalletBalance + {------------------------------------------------------------------------------- Queries -------------------------------------------------------------------------------}