First exploration: Jörmungandr NetworkLayer

lib/core/src/Cardano/Wallet.hs

@@ -98,6 +98,7 @@ import Cardano.Wallet.Primitive.Types
     ( Address (..)
     , AddressState (..)
     , Block (..)
+    , BlockId (..)
     , Coin (..)
     , Direction (..)
     , SlotId (..)
@@ -144,7 +145,7 @@ import Data.Coerce
 import Data.Functor
     ( ($>) )
 import Data.Generics.Internal.VL.Lens
-    ( view, (^.) )
+    ( view )
 import Data.Generics.Labels
     ()
 import Data.List.NonEmpty
@@ -439,8 +440,8 @@ newWalletLayer db nw tl = do
                 Left e -> do
                     TIO.putStrLn $ "[ERROR] restoreSleep: " +|| e ||+ ""
                     restoreSleep wid (currentTip w)
-                Right (_, tip) -> do
-                    restoreStep wid (currentTip w, tip ^. #slotId)
+                Right tip -> do
+                    restoreStep wid (currentTip w, tip)
         liftIO $ registerWorker re (wid, worker)
 
     -- | Infinite restoration loop. We drain the whole available chain and try
@@ -450,7 +451,7 @@ newWalletLayer db nw tl = do
     -- The function only terminates if the wallet has disappeared from the DB.
     restoreStep
         :: WalletId
-        -> (SlotId, SlotId)
+        -> ((SlotId, BlockId), (SlotId, BlockId))
         -> IO ()
     restoreStep wid (slot, tip) = do
         runExceptT (nextBlocks nw slot) >>= \case
@@ -461,34 +462,35 @@ newWalletLayer db nw tl = do
                 restoreSleep wid slot
             Right blocks -> do
                 let next = view #slotId . header . last $ blocks
+                let nextBlock = BlockId $ view #prevBlockHash. header . last $ blocks -- TODO: WRONG!! THIS IS PARENT!!!
                 runExceptT (restoreBlocks wid blocks tip) >>= \case
                     Left (ErrNoSuchWallet _) -> TIO.putStrLn $
                         "[ERROR] restoreStep: wallet " +| wid |+ " is gone!"
                     Right () -> do
-                        restoreStep wid (next, tip)
+                        restoreStep wid ((next, nextBlock), tip)
 
     -- | Wait a short delay before querying for blocks again. We do take this
     -- opportunity to also refresh the chain tip as it has probably increased
     -- in order to refine our syncing status.
     restoreSleep
         :: WalletId
-        -> SlotId
+        -> (SlotId, BlockId)
         -> IO ()
     restoreSleep wid slot = do
         let tenSeconds = 10000000 in threadDelay tenSeconds
         runExceptT (networkTip nw) >>= \case
             Left e -> do
                 TIO.putStrLn $ "[ERROR] restoreSleep: " +|| e ||+ ""
                 restoreSleep wid slot
-            Right (_, tip) ->
-                restoreStep wid (slot, tip ^. #slotId)
+            Right tip -> do
+                restoreStep wid (slot, tip)
 
     -- | Apply the given blocks to the wallet and update the wallet state,
     -- transaction history and corresponding metadata.
     restoreBlocks
         :: WalletId
         -> [Block]
-        -> SlotId -- ^ Network tip
+        -> (SlotId, BlockId) -- ^ Network tip
         -> ExceptT ErrNoSuchWallet IO ()
     restoreBlocks wid blocks tip = do
         let (inf, sup) =
@@ -511,7 +513,7 @@ newWalletLayer db nw tl = do
             let nonEmpty = not . null . transactions
             let (h,q) = first (filter nonEmpty) $ splitAt (length blocks - 1) blocks
             let (txs, cp') = applyBlocks (h ++ q) cp
-            let progress = slotRatio sup tip
+            let progress = slotRatio sup (fst tip)
             let status' = if progress == maxBound
                     then Ready
                     else Restoring progress
@@ -598,7 +600,7 @@ newWalletLayer db nw tl = do
                     let meta = TxMeta
                             { status = Pending
                             , direction = Outgoing
-                            , slotId = currentTip w
+                            , slotId = fst $ currentTip w
                             , amount = Quantity (amtInps - amtChng)
                             }
                     return (tx, meta, wit)

lib/core/src/Cardano/Wallet/DB/Sqlite.hs

@@ -398,14 +398,15 @@ mkCheckpointEntity wid wal =
     sl = W.currentTip wal
     cp = Checkpoint
         { checkpointTableWalletId = wid
-        , checkpointTableSlot = sl
+        , checkpointTableSlot = fst sl
+        , checkpointTableBlock = snd sl
         }
     pendingTx tid = PendingTx
         { pendingTxTableWalletId = wid
-        , pendingTxTableCheckpointSlot = sl
+        , pendingTxTableCheckpointSlot = fst sl
         , pendingTxTableId2 = tid
         }
-    utxo = [ UTxO wid sl (TxId input) ix addr coin
+    utxo = [ UTxO wid (fst sl) (TxId input) ix addr coin
            | (W.TxIn input ix, W.TxOut addr coin) <- utxoMap ]
     utxoMap = Map.assocs (W.getUTxO (W.totalUTxO wal))
 
@@ -419,8 +420,8 @@ checkpointFromEntity
     -> [TxOut]
     -> s
     -> W.Wallet s t
-checkpointFromEntity (Checkpoint _ tip) utxo ins outs =
-    W.unsafeInitWallet utxo' pending tip
+checkpointFromEntity (Checkpoint _ tip prevBlockId) utxo ins outs =
+    W.unsafeInitWallet utxo' pending (tip, prevBlockId)
   where
     utxo' = W.UTxO . Map.fromList $
         [ (W.TxIn input ix, W.TxOut addr coin)
@@ -524,12 +525,13 @@ insertCheckpoint
     -> SqlPersistM ()
 insertCheckpoint wid cp = do
     let (cp', utxo, pendings, ins, outs) = mkCheckpointEntity wid cp
+    let (slot, blockId) = W.currentTip cp
     insert_ cp'
     dbChunked insertMany_ ins
     dbChunked insertMany_ outs
     dbChunked insertMany_ pendings
     dbChunked insertMany_ utxo
-    insertState (wid, W.currentTip cp) (W.getState cp)
+    insertState (wid, slot, blockId) (W.getState cp)
 
 -- | Delete all checkpoints associated with a wallet.
 deleteCheckpoints
@@ -647,13 +649,15 @@ selectLatestCheckpoint wid = fmap entityVal <$>
 selectUTxO
     :: Checkpoint
     -> SqlPersistM [UTxO]
-selectUTxO (Checkpoint wid sl) = fmap entityVal <$>
-    selectList [UtxoTableWalletId ==. wid, UtxoTableCheckpointSlot ==. sl] []
+selectUTxO (Checkpoint wid sl _bl) = fmap entityVal <$>
+    selectList [ UtxoTableWalletId ==. wid
+               , UtxoTableCheckpointSlot ==. sl
+               ] []
 
 selectPending
     :: Checkpoint
     -> SqlPersistM [TxId]
-selectPending (Checkpoint wid sl) = fmap (pendingTxTableId2 . entityVal) <$>
+selectPending (Checkpoint wid sl _) = fmap (pendingTxTableId2 . entityVal) <$>
     selectList [ PendingTxTableWalletId ==. wid
                , PendingTxTableCheckpointSlot ==. sl ] []
 
@@ -681,29 +685,29 @@ selectTxHistory wid = do
 
 -- | Get a @(WalletId, SlotId)@ pair from the checkpoint table, for use with
 -- 'insertState' and 'selectState'.
-checkpointId :: Checkpoint -> (W.WalletId, W.SlotId)
-checkpointId cp = (checkpointTableWalletId cp, checkpointTableSlot cp)
+checkpointId :: Checkpoint -> (W.WalletId, W.SlotId, W.BlockId)
+checkpointId cp = (checkpointTableWalletId cp, checkpointTableSlot cp, checkpointTableBlock cp)
 
 -- | Functions for saving/loading the wallet's address discovery state into
 -- SQLite.
 class PersistState s where
     -- | Store the state for a checkpoint.
-    insertState :: (W.WalletId, W.SlotId) -> s -> SqlPersistM ()
+    insertState :: (W.WalletId, W.SlotId, W.BlockId) -> s -> SqlPersistM ()
     -- | Load the state for a checkpoint.
-    selectState :: (W.WalletId, W.SlotId) -> SqlPersistM (Maybe s)
+    selectState :: (W.WalletId, W.SlotId, W.BlockId) -> SqlPersistM (Maybe s)
     -- | Remove the state for all checkpoints of a wallet.
     deleteState :: W.WalletId -> SqlPersistM ()
 
 instance W.KeyToAddress t => PersistState (W.SeqState t) where
-    insertState (wid, sl) st = do
+    insertState (wid, sl, _prevBlockId) st = do
         ssid <- insert (SeqState wid sl)
         intApId <- insertAddressPool $ W.internalPool st
         extApId <- insertAddressPool $ W.externalPool st
         insert_ $ SeqStateInternalPool ssid intApId
         insert_ $ SeqStateExternalPool ssid extApId
         insertMany_ $ mkSeqStatePendingIxs ssid $ W.pendingChangeIxs st
 
-    selectState (wid, sl) = runMaybeT $ do
+    selectState (wid, sl, _blockId) = runMaybeT $ do
         ssid <- MaybeT $ fmap entityKey <$>
             selectFirst [ SeqStateTableWalletId ==. wid
                         , SeqStateTableCheckpointSlot ==. sl ] []

lib/core/src/Cardano/Wallet/DB/Sqlite/TH.hs

@@ -122,6 +122,7 @@ TxOut
 Checkpoint
     checkpointTableWalletId    W.WalletId  sql=wallet_id
     checkpointTableSlot        W.SlotId    sql=slot
+    checkpointTableBlock       W.BlockId sql=block
 
     Primary checkpointTableWalletId checkpointTableSlot
     Foreign Wallet fk_wallet_checkpoint checkpointTableWalletId

lib/core/src/Cardano/Wallet/DB/Sqlite/Types.hs

@@ -28,6 +28,7 @@ import Cardano.Wallet.Primitive.AddressDiscovery
     ( AddressPoolGap (..), getAddressPoolGap, mkAddressPoolGap )
 import Cardano.Wallet.Primitive.Types
     ( Address (..)
+    , BlockId (..)
     , Coin (..)
     , Direction (..)
     , Hash (..)
@@ -202,6 +203,38 @@ instance ToJSON SlotId where
 instance FromJSON SlotId where
     parseJSON = genericParseJSON defaultOptions
 
+
+----------------------------------------------------------------------------
+-- BlockId
+
+instance PersistField BlockId where
+    toPersistValue = toPersistValue . toText . getBlockId
+    fromPersistValue = fmap BlockId <$> fromPersistValueFromText
+
+instance PersistFieldSql BlockId where
+    sqlType _ = sqlType (Proxy @Text)
+
+instance Read BlockId where
+    readsPrec _ = error "readsPrec stub needed for persistent"
+
+instance ToJSON BlockId where
+    toJSON = String . toText . getBlockId
+
+instance FromJSON BlockId where
+    parseJSON = fmap BlockId . aesonFromText "WalletId"
+
+instance ToHttpApiData BlockId where
+    toUrlPiece = toText . getBlockId
+
+instance FromHttpApiData BlockId where
+    parseUrlPiece = fmap BlockId . fromText'
+
+instance PathPiece BlockId where
+    toPathPiece = toText . getBlockId
+    fromPathPiece = fmap BlockId . fromTextMaybe
+
+----------------------------------------------------------------------------
+
 ----------------------------------------------------------------------------
 -- WalletState
 

lib/core/src/Cardano/Wallet/Network.hs

@@ -17,7 +17,7 @@ module Cardano.Wallet.Network
 import Prelude
 
 import Cardano.Wallet.Primitive.Types
-    ( Block (..), BlockHeader (..), Hash (..), SlotId (..), Tx, TxWitness )
+    ( Block (..), BlockId, SlotId (..), Tx, TxWitness )
 import Control.Exception
     ( Exception )
 import Control.Monad.Trans.Except
@@ -28,15 +28,15 @@ import GHC.Generics
     ( Generic )
 
 data NetworkLayer t m = NetworkLayer
-    { nextBlocks :: SlotId -> ExceptT ErrNetworkUnreachable m [Block]
+    { nextBlocks :: (SlotId, BlockId) -> ExceptT ErrNetworkUnreachable m [Block]
         -- ^ Gets some blocks from the node. It will not necessarily return all
         -- the blocks that the node has, but will receive a reasonable-sized
         -- chunk. It will never return blocks from before the given slot. It
         -- may return an empty list if the node does not have any blocks from
         -- after the starting slot.
 
     , networkTip
-        :: ExceptT ErrNetworkTip m (Hash "BlockHeader", BlockHeader)
+        :: ExceptT ErrNetworkTip m (SlotId, BlockId)
         -- ^ Get the current network tip from the chain producer
 
     , postTx

lib/core/src/Cardano/Wallet/Primitive/Model.hs

@@ -54,6 +54,7 @@ import Cardano.Wallet.Primitive.AddressDiscovery
     ( IsOurs (..) )
 import Cardano.Wallet.Primitive.Types
     ( Block (..)
+    , BlockId (..)
     , Direction (..)
     , Dom (..)
     , Hash (..)
@@ -137,7 +138,7 @@ data Wallet s t where
     Wallet :: (IsOurs s, NFData s, Show s, TxId t)
         => UTxO -- Unspent tx outputs belonging to this wallet
         -> Set Tx -- Pending outgoing transactions
-        -> SlotId -- Latest applied block (current tip)
+        -> (SlotId, BlockId) -- Latest applied block (current tip)
         -> s -- Address discovery state
         -> Wallet s t
 
@@ -159,7 +160,7 @@ initWallet
     :: (IsOurs s, NFData s, Show s, TxId t)
     => s
     -> Wallet s t
-initWallet = Wallet mempty mempty (SlotId 0 0)
+initWallet = Wallet mempty mempty (SlotId 0 0, error "todo: genesisHash")
 
 -- | Update the state of an existing Wallet model
 updateState
@@ -188,9 +189,10 @@ applyBlock !b (Wallet !utxo !pending _ s) =
         txs' = Map.fromList $ map
             (\(tx, meta) -> (txId @t tx, (tx, meta)))
             txs
+        h = b ^. #header
     in
         ( txs'
-        , Wallet utxo' pending' (b ^. #header . #slotId) s'
+        , Wallet utxo' pending' (h ^. #slotId, BlockId (h ^. #prevBlockHash)) s'
         )
 
 -- | Helper to apply multiple blocks in sequence to an existing wallet. It's
@@ -223,7 +225,7 @@ unsafeInitWallet
        -- ^ Unspent tx outputs belonging to this wallet
     -> Set Tx
     -- ^ Pending outgoing transactions
-    -> SlotId
+    -> (SlotId, BlockId)
     -- ^ Latest applied block (current tip)
     -> s
     -- ^Address discovery state
@@ -235,7 +237,7 @@ unsafeInitWallet = Wallet
 -------------------------------------------------------------------------------}
 
 -- | Get the wallet current tip
-currentTip :: Wallet s t -> SlotId
+currentTip :: Wallet s t -> (SlotId, BlockId)
 currentTip (Wallet _ _ tip _) = tip
 
 -- | Get the wallet current state

lib/core/src/Cardano/Wallet/Primitive/Types.hs

@@ -30,6 +30,7 @@ module Cardano.Wallet.Primitive.Types
     -- * Block
       Block(..)
     , BlockHeader(..)
+    , BlockId (..)
 
     -- * Tx
     , Tx(..)
@@ -714,6 +715,10 @@ fromFlatSlot n = SlotId e (fromIntegral s)
 epochLength :: Integral a => a
 epochLength = 21600
 
+
+newtype BlockId = BlockId { getBlockId :: Hash "BlockHeader" }
+    deriving (Show, Eq, NFData, Ord)
+
 {-------------------------------------------------------------------------------
                                Polymorphic Types
 -------------------------------------------------------------------------------}
@@ -761,6 +766,19 @@ instance FromText (Hash "Tx") where
 instance ToText (Hash "Tx") where
     toText = T.decodeUtf8 . convertToBase Base16 . getHash
 
+
+instance FromText (Hash "BlockHeader") where
+    fromText x = either
+        (const $ Left $ TextDecodingError err)
+        (pure . Hash)
+        (convertFromBase Base16 $ T.encodeUtf8 x)
+      where
+        err = "Unable to decode (Hash \"BlockHeader\"): \
+                    \expected Base16 encoding"
+
+instance ToText (Hash "BlockHeader") where
+    toText = T.decodeUtf8 . convertToBase Base16 . getHash
+
 -- | A polymorphic wrapper type with a custom show instance to display data
 -- through 'Buildable' instances.
 newtype ShowFmt a = ShowFmt a

lib/http-bridge/src/Cardano/Wallet/HttpBridge/Network.hs

@@ -46,7 +46,14 @@ import Cardano.Wallet.Network
     , NetworkLayer (..)
     )
 import Cardano.Wallet.Primitive.Types
-    ( Block (..), BlockHeader (..), Hash (..), SlotId (..), Tx, TxWitness )
+    ( Block (..)
+    , BlockHeader (..)
+    , BlockId (..)
+    , Hash (..)
+    , SlotId (..)
+    , Tx
+    , TxWitness
+    )
 import Control.Arrow
     ( left )
 import Control.Exception
@@ -91,8 +98,8 @@ import qualified Servant.Extra.ContentTypes as Api
 -- | Constructs a network layer with the given cardano-http-bridge API.
 mkNetworkLayer :: Monad m => HttpBridgeLayer m -> NetworkLayer t m
 mkNetworkLayer httpBridge = NetworkLayer
-    { nextBlocks = rbNextBlocks httpBridge
-    , networkTip = getNetworkTip httpBridge
+    { nextBlocks = \(sl, _) -> rbNextBlocks httpBridge sl
+    , networkTip = (\(hash, h) -> (slotId h, BlockId hash)) <$> getNetworkTip httpBridge
     , postTx = postSignedTx httpBridge
     }