Restrict Checkpoints to be constructible from genesis only

The function `fromGenesis` replaces the `singleton` function.

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 a list 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: impossible: no 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

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

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) =

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