diff --git a/lib/core/src/Cardano/Wallet/DB/Checkpoints.hs b/lib/core/src/Cardano/Wallet/DB/Checkpoints.hs index 7df73b0ac2b..b81f560cd6d 100644 --- a/lib/core/src/Cardano/Wallet/DB/Checkpoints.hs +++ b/lib/core/src/Cardano/Wallet/DB/Checkpoints.hs @@ -13,8 +13,10 @@ module Cardano.Wallet.DB.Checkpoints ( getPoint -- * Checkpoints - , Checkpoints (..) - , singleton + , Checkpoints + , checkpoints + , loadCheckpoints + , fromGenesis , getLatest , findNearestPoint @@ -85,21 +87,30 @@ getPoint = -- | Collection of checkpoints indexed by 'Slot'. data Checkpoints a = Checkpoints { checkpoints :: Map W.Slot a + -- ^ Map of checkpoints. Always contains the genesis checkpoint. } deriving (Eq,Show,Generic) -- FIXME LATER during ADP-1043: -- Use a more sophisticated 'Checkpoints' type that stores deltas. --- | Make a single checkpoint. -singleton :: W.Slot -> a -> Checkpoints a -singleton key a = Checkpoints $ Map.singleton key a +-- | Turn the list of checkpoints into a map of checkpoints. +-- +-- FIXME LATER during ADP-1043: +-- The database actually does not store the checkpoint at genesis, +-- but the checkpoint after that. +-- Hence, this function does not check whether the genesis checkpoint +-- is in the list of checkpoints. +loadCheckpoints :: [(W.Slot, a)] -> Checkpoints a +loadCheckpoints = Checkpoints . Map.fromList + +-- | Begin with the genesis checkpoint. +fromGenesis :: a -> Checkpoints a +fromGenesis a = Checkpoints $ Map.singleton W.Origin a -- | Get the checkpoint with the largest 'SlotNo'. getLatest :: Checkpoints a -> (W.Slot, a) getLatest = from . Map.lookupMax . view #checkpoints where - from = fromMaybe (error "getLatest: Genesis checkpoint is missing!") - -- FIXME LATER during ADP-1043: - -- Make sure that 'Checkpoints' always has a genesis checkpoint + from = fromMaybe (error "getLatest: there should always be at least a genesis checkpoint") -- | Find the nearest 'Checkpoint' that is either at the given point or before. findNearestPoint :: Checkpoints a -> W.Slot -> Maybe W.Slot @@ -123,7 +134,7 @@ instance Delta (DeltaCheckpoints a) where apply (RollbackTo pt) = over #checkpoints $ Map.filterWithKey (\k _ -> k <= pt) apply (RestrictTo pts) = over #checkpoints $ \m -> - Map.restrictKeys m $ Set.fromList pts + Map.restrictKeys m $ Set.fromList (W.Origin:pts) {------------------------------------------------------------------------------- A Delta type for Maps diff --git a/lib/core/src/Cardano/Wallet/DB/Sqlite.hs b/lib/core/src/Cardano/Wallet/DB/Sqlite.hs index c0d294c63ad..42a319b5e4a 100644 --- a/lib/core/src/Cardano/Wallet/DB/Sqlite.hs +++ b/lib/core/src/Cardano/Wallet/DB/Sqlite.hs @@ -90,9 +90,9 @@ import Cardano.Wallet.DB.Checkpoints ( DeltaCheckpoints (..) , DeltaMap (..) , findNearestPoint + , fromGenesis , getLatest , getPoint - , singleton ) import Cardano.Wallet.DB.Sqlite.CheckpointsOld ( PersistState (..), blockHeaderFromEntity, mkStoreWalletsCheckpoints ) @@ -535,15 +535,26 @@ newDBLayerWith _cacheBehavior tr ti SqliteContext{runQuery} = do -- mutex (queryLock), which means no concurrent queries. queryLock <- newMVar () -- fixme: ADP-586 - -- Insert a checkpoint into the DBVar + -- Insert a checkpoint for a given wallet ID into the DBVar, + -- assuming that the wallet already exists. let insertCheckpointCached wid cp = do liftIO $ traceWith tr $ MsgCheckpointCache wid MsgPutCheckpoint modifyDBMaybe checkpointsVar $ \ws -> let point = getPoint cp in case Map.lookup wid ws of - Nothing -> (Just $ Insert wid $ singleton point cp, ()) + Nothing -> (Nothing, ()) Just _ -> (Just $ Adjust wid $ PutCheckpoint point cp, ()) + -- Insert genesis checkpoint into the DBVar. + -- Throws an internal error if the checkpoint is not actually at genesis. + let insertCheckpointGenesis wid cp + | W.isGenesisBlockHeader header = + updateDBVar checkpointsVar $ Insert wid $ fromGenesis cp + | otherwise = + throwIO $ ErrInitializeNotGenesis wid header + where + header = cp ^. #currentTip + -- Retrieve the latest checkpoint from the DBVar let selectLatestCheckpointCached :: W.WalletId @@ -588,7 +599,7 @@ newDBLayerWith _cacheBehavior tr ti SqliteContext{runQuery} = do res <- handleConstraint (ErrWalletAlreadyExists wid) $ insert_ (mkWalletEntity wid meta gp) when (isRight res) $ do - insertCheckpointCached wid cp + insertCheckpointGenesis wid cp let (metas, txins, txcins, txouts, txoutTokens, ws) = mkTxHistory wid txs putTxs metas txins txcins txouts txoutTokens ws @@ -1538,6 +1549,9 @@ selectGenesisParameters wid = do gp <- selectFirst [WalId ==. wid] [] pure $ (genesisParametersFromEntity . entityVal) <$> gp +{------------------------------------------------------------------------------- + Internal errors +-------------------------------------------------------------------------------} -- | A fatal exception thrown when trying to rollback but, there's no checkpoint -- to rollback to. The database maintain the invariant that there's always at -- least one checkpoint (the first one made for genesis) present in the @@ -1547,3 +1561,9 @@ selectGenesisParameters wid = do -- violated. data ErrRollbackTo = ErrNoOlderCheckpoint W.WalletId W.Slot deriving (Show) instance Exception ErrRollbackTo + +-- | Can't initialize a wallet because the given 'BlockHeader' is not genesis. +data ErrInitializeNotGenesis + = ErrInitializeNotGenesis W.WalletId W.BlockHeader deriving (Eq, Show) + +instance Exception ErrInitializeNotGenesis diff --git a/lib/core/src/Cardano/Wallet/DB/Sqlite/CheckpointsOld.hs b/lib/core/src/Cardano/Wallet/DB/Sqlite/CheckpointsOld.hs index bfe5adc491d..6e010f3caa3 100644 --- a/lib/core/src/Cardano/Wallet/DB/Sqlite/CheckpointsOld.hs +++ b/lib/core/src/Cardano/Wallet/DB/Sqlite/CheckpointsOld.hs @@ -37,7 +37,12 @@ import Cardano.Address.Script import Cardano.DB.Sqlite ( dbChunked ) import Cardano.Wallet.DB.Checkpoints - ( Checkpoints (..), DeltaCheckpoints (..), DeltaMap (..), getPoint ) + ( Checkpoints (..) + , DeltaCheckpoints (..) + , DeltaMap (..) + , getPoint + , loadCheckpoints + ) import Cardano.Wallet.DB.Sqlite.TH ( Checkpoint (..) , CosignerKey (..) @@ -187,10 +192,9 @@ mkStoreCheckpoints wid = where load = do cps <- selectAllCheckpoints wid - pure $ Right $ Checkpoints{ checkpoints = Map.fromList cps } + pure $ Right $ loadCheckpoints cps - write Checkpoints{checkpoints} = - forM_ (Map.toList checkpoints) $ \(pt,cp) -> + write cps = forM_ (Map.toList $ checkpoints cps) $ \(pt,cp) -> update (PutCheckpoint pt cp) update (PutCheckpoint _ state) = diff --git a/lib/core/test/unit/Cardano/Wallet/DB/Properties.hs b/lib/core/test/unit/Cardano/Wallet/DB/Properties.hs index 3680398b442..f919269b4e8 100644 --- a/lib/core/test/unit/Cardano/Wallet/DB/Properties.hs +++ b/lib/core/test/unit/Cardano/Wallet/DB/Properties.hs @@ -445,51 +445,51 @@ assertWith lbl condition = do -- | Can list created wallets prop_createListWallet :: DBLayer IO s ShelleyKey - -> KeyValPairs WalletId (Wallet s , WalletMetadata) + -> KeyValPairs WalletId (InitialCheckpoint s, WalletMetadata) -> Property prop_createListWallet db@DBLayer{..} (KeyValPairs pairs) = monadicIO (setup >> prop) where setup = liftIO (cleanDB db) prop = liftIO $ do - res <- once pairs $ \(k, (cp, meta)) -> + res <- once pairs $ \(k, (InitialCheckpoint cp0, meta)) -> atomically $ unsafeRunExceptT $ - initializeWallet k cp meta mempty gp + initializeWallet k cp0 meta mempty gp (length <$> atomically listWallets) `shouldReturn` length res -- | Trying to create a same wallet twice should yield an error prop_createWalletTwice :: DBLayer IO s ShelleyKey -> ( WalletId - , Wallet s + , InitialCheckpoint s , WalletMetadata ) -> Property -prop_createWalletTwice db@DBLayer{..} (wid, cp, meta) = +prop_createWalletTwice db@DBLayer{..} (wid, InitialCheckpoint cp0, meta) = monadicIO (setup >> prop) where setup = liftIO (cleanDB db) prop = liftIO $ do let err = ErrWalletAlreadyExists wid - atomically (runExceptT $ initializeWallet wid cp meta mempty gp) + atomically (runExceptT $ initializeWallet wid cp0 meta mempty gp) `shouldReturn` Right () - atomically (runExceptT $ initializeWallet wid cp meta mempty gp) + atomically (runExceptT $ initializeWallet wid cp0 meta mempty gp) `shouldReturn` Left err -- | Trying to remove a same wallet twice should yield an error prop_removeWalletTwice :: DBLayer IO s ShelleyKey -> ( WalletId - , Wallet s + , InitialCheckpoint s , WalletMetadata ) -> Property -prop_removeWalletTwice db@DBLayer{..} (wid, cp, meta) = +prop_removeWalletTwice db@DBLayer{..} (wid, InitialCheckpoint cp0, meta) = monadicIO (setup >> prop) where setup = liftIO $ do cleanDB db - atomically $ unsafeRunExceptT $ initializeWallet wid cp meta mempty gp + atomically $ unsafeRunExceptT $ initializeWallet wid cp0 meta mempty gp prop = liftIO $ do let err = ErrNoSuchWallet wid atomically (runExceptT $ removeWallet wid) `shouldReturn` Right () @@ -516,9 +516,9 @@ prop_readAfterPut putOp readOp db@DBLayer{..} (wid, a) = where setup = do run $ cleanDB db - (InitialCheckpoint cp, meta) <- namedPick "Initial Checkpoint" arbitrary + (InitialCheckpoint cp0, meta) <- pick arbitrary run $ atomically $ unsafeRunExceptT $ - initializeWallet wid cp meta mempty gp + initializeWallet wid cp0 meta mempty gp prop = do run $ unsafeRunExceptT $ putOp db wid a res <- run $ readOp db wid @@ -538,9 +538,9 @@ prop_getTxAfterPutValidTxId db@DBLayer{..} wid txGen = where setup = do run $ cleanDB db - (InitialCheckpoint cp, meta) <- namedPick "Initial Checkpoint" arbitrary + (InitialCheckpoint cp0, meta) <- pick arbitrary run $ atomically $ unsafeRunExceptT $ - initializeWallet wid cp meta mempty gp + initializeWallet wid cp0 meta mempty gp prop = do let txs = unGenTxHistory txGen run $ unsafeRunExceptT $ mapExceptT atomically $ putTxHistory wid txs @@ -566,9 +566,9 @@ prop_getTxAfterPutInvalidTxId db@DBLayer{..} wid txGen txId' = where setup = do run $ cleanDB db - (InitialCheckpoint cp, meta) <- namedPick "Initial Checkpoint" arbitrary + (InitialCheckpoint cp0, meta) <- pick arbitrary run $ atomically $ unsafeRunExceptT $ - initializeWallet wid cp meta mempty gp + initializeWallet wid cp0 meta mempty gp prop = do let txs = unGenTxHistory txGen run $ unsafeRunExceptT $ mapExceptT atomically $ putTxHistory wid txs @@ -579,18 +579,19 @@ prop_getTxAfterPutInvalidTxId db@DBLayer{..} wid txGen txId' = prop_getTxAfterPutInvalidWalletId :: DBLayer IO s ShelleyKey -> ( WalletId - , Wallet s + , InitialCheckpoint s , WalletMetadata ) -> GenTxHistory -> WalletId -> Property -prop_getTxAfterPutInvalidWalletId db@DBLayer{..} (wid, cp, meta) txGen wid' = - wid /= wid' ==> monadicIO (setup >> prop) +prop_getTxAfterPutInvalidWalletId db@DBLayer{..} + (wid, InitialCheckpoint cp0, meta) txGen wid' + = wid /= wid' ==> monadicIO (setup >> prop) where setup = liftIO $ do cleanDB db - atomically $ unsafeRunExceptT $ initializeWallet wid cp meta mempty gp + atomically $ unsafeRunExceptT $ initializeWallet wid cp0 meta mempty gp prop = liftIO $ do let txs = unGenTxHistory txGen atomically (runExceptT $ putTxHistory wid txs) `shouldReturn` Right () @@ -600,7 +601,7 @@ prop_getTxAfterPutInvalidWalletId db@DBLayer{..} (wid, cp, meta) txGen wid' = -- | Can't put resource before a wallet has been initialized prop_putBeforeInit - :: (Buildable (f a), Eq (f a)) + :: (Buildable (f a), Eq (f a), GenState s) => ( DBLayer IO s ShelleyKey -> WalletId -> a @@ -633,7 +634,7 @@ prop_isolation :: ( Buildable (f b), Eq (f b) , Buildable (g c), Eq (g c) , Buildable (h d), Eq (h d) - , Arbitrary (Wallet s) + , GenState s , Show s ) => ( DBLayer IO s ShelleyKey @@ -661,16 +662,16 @@ prop_isolation putA readB readC readD db@DBLayer{..} (ShowFmt wid, ShowFmt a) = monadicIO (setup >>= prop) where setup = do - liftIO (cleanDB db) - (cp, meta, GenTxHistory txs) <- pick arbitrary - liftIO $ atomically $ do - unsafeRunExceptT $ initializeWallet wid cp meta mempty gp + run $ cleanDB db + (InitialCheckpoint cp0, meta) <- pick arbitrary + (GenTxHistory txs) <- pick arbitrary + run $ atomically $ do + unsafeRunExceptT $ initializeWallet wid cp0 meta mempty gp unsafeRunExceptT $ putTxHistory wid txs - (b, c, d) <- liftIO $ (,,) + run $ (,,) <$> readB db wid <*> readC db wid <*> readD db wid - return (b, c, d) prop (b, c, d) = liftIO $ do unsafeRunExceptT $ putA db wid a @@ -694,10 +695,10 @@ prop_readAfterDelete readOp empty db@DBLayer{..} (ShowFmt wid) = monadicIO (setup >> prop) where setup = do - liftIO (cleanDB db) - (cp, meta) <- pick arbitrary - liftIO $ atomically $ unsafeRunExceptT $ - initializeWallet wid cp meta mempty gp + run $ cleanDB db + (InitialCheckpoint cp0, meta) <- pick arbitrary + run $ atomically $ unsafeRunExceptT $ + initializeWallet wid cp0 meta mempty gp prop = liftIO $ do atomically $ unsafeRunExceptT $ removeWallet wid (ShowFmt <$> readOp db wid) `shouldReturn` ShowFmt empty @@ -731,9 +732,9 @@ prop_sequentialPut putOp readOp resolve db@DBLayer{..} kv = ids = map fst pairs setup = do run $ cleanDB db - (InitialCheckpoint cp, meta) <- pick arbitrary + (InitialCheckpoint cp0, meta) <- pick arbitrary run $ atomically $ unsafeRunExceptT $ once_ pairs $ \(k, _) -> - initializeWallet k cp meta mempty gp + initializeWallet k cp0 meta mempty gp prop = do run $ unsafeRunExceptT $ forM_ pairs $ uncurry (putOp db) res <- run $ once pairs (readOp db . fst) @@ -744,7 +745,7 @@ prop_sequentialPut putOp readOp resolve db@DBLayer{..} kv = -- | Check that the DB supports multiple sequential puts for a given resource prop_parallelPut - :: (Arbitrary (Wallet s), Show s) + :: (GenState s) => ( DBLayer IO s ShelleyKey -> WalletId -> a @@ -769,10 +770,10 @@ prop_parallelPut putOp readOp resolve db@DBLayer{..} (KeyValPairs pairs) = where ids = map fst pairs setup = do - liftIO (cleanDB db) - (cp, meta) <- pick arbitrary - liftIO $ atomically $ unsafeRunExceptT $ once_ pairs $ \(k, _) -> - initializeWallet k cp meta mempty gp + run $ cleanDB db + (InitialCheckpoint cp0, meta) <- pick arbitrary + run $ atomically $ unsafeRunExceptT $ once_ pairs $ \(k, _) -> + initializeWallet k cp0 meta mempty gp prop = liftIO $ do forConcurrently_ pairs $ unsafeRunExceptT . uncurry (putOp db) res <- once pairs (readOp db . fst) @@ -783,10 +784,10 @@ prop_parallelPut putOp readOp resolve db@DBLayer{..} (KeyValPairs pairs) = prop_rollbackCheckpoint :: forall s k. (GenState s, Eq s) => DBLayer IO s k - -> Wallet s + -> InitialCheckpoint s -> MockChain -> Property -prop_rollbackCheckpoint db@DBLayer{..} cp0 (MockChain chain) = do +prop_rollbackCheckpoint db@DBLayer{..} (InitialCheckpoint cp0) (MockChain chain) = do monadicIO $ do ShowFmt wid <- namedPick "Wallet ID" arbitrary ShowFmt meta <- namedPick "Wallet Metadata" arbitrary diff --git a/lib/core/test/unit/Cardano/Wallet/DB/SqliteSpec.hs b/lib/core/test/unit/Cardano/Wallet/DB/SqliteSpec.hs index 5eb9d3bc489..a37b23ff4c2 100644 --- a/lib/core/test/unit/Cardano/Wallet/DB/SqliteSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/DB/SqliteSpec.hs @@ -173,7 +173,7 @@ import Data.ByteString import Data.Coerce ( coerce ) import Data.Generics.Internal.VL.Lens - ( view, (^.) ) + ( over, view, (^.) ) import Data.Generics.Labels () import Data.Maybe @@ -717,10 +717,15 @@ prop_randomOpChunks (KeyValPairs pairs) = unsafeRunExceptT $ putCheckpoint k cp unsafeRunExceptT $ putWalletMeta k meta else do - atomically $ unsafeRunExceptT $ initializeWallet k cp meta mempty gp + let cp0 = imposeGenesisState cp + atomically $ unsafeRunExceptT $ initializeWallet k cp0 meta mempty gp Set.fromList <$> atomically listWallets `shouldReturn` Set.fromList (k:keys) + imposeGenesisState :: Wallet s -> Wallet s + imposeGenesisState = over #currentTip $ \(BlockHeader _ _ h _) -> + BlockHeader (SlotNo 0) (Quantity 0) h Nothing + shouldBeConsistentWith :: (Eq s, Show s) => DBLayer IO s k -> DBLayer IO s k -> IO () shouldBeConsistentWith db1 db2 = do wids1 <- Set.fromList <$> listWallets' db1