Skip to content
Permalink
Browse files

Merge pull request #384 from input-output-hk/anviking/219/blockheader…

…-tip

Change wallet `currentTip` from `SlotId` to `BlockHeader`
  • Loading branch information...
Anviking committed Jun 12, 2019
2 parents 8179ddb + e46b2fa commit 869803fa40c6c0acdf28d9f485d5612895eea03e
@@ -47,7 +47,7 @@ import Cardano.Wallet.Api.Types
, WalletPutData (..)
)
import Cardano.Wallet.HttpBridge.Compatibility
( HttpBridge )
( HttpBridge, block0 )
import Cardano.Wallet.HttpBridge.Environment
( KnownNetwork (..), Network (..) )
import Cardano.Wallet.Network
@@ -345,7 +345,7 @@ execHttpBridge args _ = do
nw <- HttpBridge.newNetworkLayer @n bridgePort
waitForConnection nw defaultRetryPolicy
let tl = HttpBridge.newTransactionLayer @n
wallet <- newWalletLayer @_ @(HttpBridge n) db nw tl
wallet <- newWalletLayer @_ @(HttpBridge n) block0 db nw tl
let logStartup port = TIO.hPutStrLn stderr $
"Wallet backend server listening on: " <> toText port
Server.start logStartup walletPort wallet
@@ -98,6 +98,7 @@ import Cardano.Wallet.Primitive.Types
( Address (..)
, AddressState (..)
, Block (..)
, BlockHeader (..)
, Coin (..)
, Direction (..)
, SlotId (..)
@@ -332,11 +333,13 @@ cancelWorker (WorkerRegistry mvar) wid =
-- | Create a new instance of the wallet layer.
newWalletLayer
:: forall s t. ()
=> DBLayer IO s t
=> BlockHeader
-- ^ Very first block header for initialization
-> DBLayer IO s t
-> NetworkLayer t IO
-> TransactionLayer t
-> IO (WalletLayer s t)
newWalletLayer db nw tl = do
newWalletLayer block0 db nw tl = do
registry <- newRegistry
return WalletLayer
{ createWallet = _createWallet
@@ -364,7 +367,7 @@ newWalletLayer db nw tl = do
-> s
-> ExceptT ErrWalletAlreadyExists IO WalletId
_createWallet wid wname s = do
let checkpoint = initWallet s
let checkpoint = initWallet block0 s
currentTime <- liftIO getCurrentTime
let metadata = WalletMetadata
{ name = wname
@@ -436,8 +439,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
@@ -447,7 +450,7 @@ newWalletLayer db nw tl = do
-- The function only terminates if the wallet has disappeared from the DB.
restoreStep
:: WalletId
-> (SlotId, SlotId)
-> (BlockHeader, BlockHeader)
-> IO ()
restoreStep wid (slot, tip) = do
runExceptT (nextBlocks nw slot) >>= \case
@@ -457,8 +460,8 @@ newWalletLayer db nw tl = do
Right [] -> do
restoreSleep wid slot
Right blocks -> do
let next = view #slotId . header . last $ blocks
runExceptT (restoreBlocks wid blocks tip) >>= \case
let next = view #header . last $ blocks
runExceptT (restoreBlocks wid blocks (tip ^. #slotId)) >>= \case
Left (ErrNoSuchWallet _) -> TIO.putStrLn $
"[ERROR] restoreStep: wallet " +| wid |+ " is gone!"
Right () -> do
@@ -469,16 +472,16 @@ newWalletLayer db nw tl = do
-- in order to refine our syncing status.
restoreSleep
:: WalletId
-> SlotId
-> BlockHeader
-> 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 ->
restoreStep wid (slot, tip)

-- | Apply the given blocks to the wallet and update the wallet state,
-- transaction history and corresponding metadata.
@@ -597,7 +600,7 @@ newWalletLayer db nw tl = do
let meta = TxMeta
{ status = Pending
, direction = Outgoing
, slotId = currentTip w
, slotId = (currentTip w) ^. #slotId
, amount = Quantity (amtInps - amtChng)
}
return (tx, meta, wit)
@@ -54,7 +54,7 @@ import Cardano.Wallet.DB.Sqlite.TH
, unWalletKey
)
import Cardano.Wallet.DB.Sqlite.Types
( AddressPoolXPub (..), TxId (..) )
( AddressPoolXPub (..), BlockId (..), TxId (..) )
import Cardano.Wallet.Primitive.AddressDerivation
( Depth (..), deserializeXPrv, serializeXPrv )
import Control.Concurrent.MVar
@@ -393,10 +393,13 @@ mkCheckpointEntity wid wal =
where
pending = [(W.txId @t tx, tx) | tx <- Set.toList (W.getPending wal)]
(ins, outs) = mkTxInputsOutputs pending
sl = W.currentTip wal
header = (W.currentTip wal)
sl = header ^. #slotId
parent = header ^. #prevBlockHash
cp = Checkpoint
{ checkpointTableWalletId = wid
, checkpointTableSlot = sl
, checkpointTableParent = BlockId parent
}
pendingTx tid = PendingTx
{ pendingTxTableWalletId = wid
@@ -417,8 +420,8 @@ checkpointFromEntity
-> [TxOut]
-> s
-> W.Wallet s t
checkpointFromEntity (Checkpoint _ tip) utxo ins outs =
W.unsafeInitWallet utxo' pending tip
checkpointFromEntity (Checkpoint _ slot (BlockId parentHeaderHash)) utxo ins outs =
W.unsafeInitWallet utxo' pending (W.BlockHeader slot parentHeaderHash)
where
utxo' = W.UTxO . Map.fromList $
[ (W.TxIn input ix, W.TxOut addr coin)
@@ -527,7 +530,7 @@ insertCheckpoint wid cp = do
dbChunked insertMany_ outs
dbChunked insertMany_ pendings
dbChunked insertMany_ utxo
insertState (wid, W.currentTip cp) (W.getState cp)
insertState (wid, (W.currentTip cp) ^. #slotId) (W.getState cp)

-- | Delete all checkpoints associated with a wallet.
deleteCheckpoints
@@ -645,15 +648,18 @@ selectLatestCheckpoint wid = fmap entityVal <$>
selectUTxO
:: Checkpoint
-> SqlPersistM [UTxO]
selectUTxO (Checkpoint wid sl) = fmap entityVal <$>
selectUTxO (Checkpoint wid sl _parent) = fmap entityVal <$>
selectList [UtxoTableWalletId ==. wid, UtxoTableCheckpointSlot ==. sl] []

selectPending
:: Checkpoint
-> SqlPersistM [TxId]
selectPending (Checkpoint wid sl) = fmap (pendingTxTableId2 . entityVal) <$>
selectList [ PendingTxTableWalletId ==. wid
, PendingTxTableCheckpointSlot ==. sl ] []
selectPending (Checkpoint wid sl _parent) =
fmap (pendingTxTableId2 . entityVal)
<$> selectList
[ PendingTxTableWalletId ==. wid
, PendingTxTableCheckpointSlot ==. sl
] []

selectTxs
:: [TxId]
@@ -24,7 +24,7 @@ module Cardano.Wallet.DB.Sqlite.TH where
import Prelude

import Cardano.Wallet.DB.Sqlite.Types
( AddressPoolXPub, TxId, sqlSettings' )
( AddressPoolXPub, BlockId, TxId, sqlSettings' )
import Data.Text
( Text )
import Data.Time.Clock
@@ -122,6 +122,7 @@ TxOut
Checkpoint
checkpointTableWalletId W.WalletId sql=wallet_id
checkpointTableSlot W.SlotId sql=slot
checkpointTableParent BlockId sql=parent

Primary checkpointTableWalletId checkpointTableSlot
Foreign Wallet fk_wallet_checkpoint checkpointTableWalletId
@@ -174,7 +174,7 @@ instance ToJSON TxId where
toJSON = String . toText . getTxId

instance FromJSON TxId where
parseJSON = fmap TxId . aesonFromText "WalletId"
parseJSON = fmap TxId . aesonFromText "TxId"

instance ToHttpApiData TxId where
toUrlPiece = toText . getTxId
@@ -186,6 +186,39 @@ instance PathPiece TxId where
toPathPiece = toText . getTxId
fromPathPiece = fmap TxId . fromTextMaybe

----------------------------------------------------------------------------
-- BlockId

-- Wraps Hash "BlockHeader" because the persistent dsl doesn't like it raw.
newtype BlockId = BlockId { getBlockId :: Hash "BlockHeader" }
deriving (Show, Eq, Ord, Generic)

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 "BlockId"

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

----------------------------------------------------------------------------
-- SlotId

@@ -22,7 +22,7 @@ module Cardano.Wallet.Network
import Prelude

import Cardano.Wallet.Primitive.Types
( Block (..), BlockHeader (..), Hash (..), SlotId (..), Tx, TxWitness )
( Block (..), BlockHeader (..), Tx, TxWitness )
import Control.Exception
( Exception, throwIO )
import Control.Monad.Trans.Except
@@ -34,15 +34,15 @@ import GHC.Generics
( Generic )

data NetworkLayer t m = NetworkLayer
{ nextBlocks :: SlotId -> ExceptT ErrNetworkUnreachable m [Block]
{ nextBlocks :: BlockHeader -> 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 BlockHeader
-- ^ Get the current network tip from the chain producer

, postTx
@@ -94,8 +94,8 @@ waitForConnection nw policy = do
Left (ErrNetworkTipNetworkUnreachable _) ->
return True

-- | A default 'RetryPolicy' with a constant delay, but no longer than 20
-- seconds.
-- | A default 'RetryPolicy' with a constant delay, but retries for no longer
-- than 20 seconds.
defaultRetryPolicy :: Monad m => RetryPolicyM m
defaultRetryPolicy =
limitRetriesByCumulativeDelay (20 * second) (constantDelay (1 * second))
@@ -54,10 +54,10 @@ import Cardano.Wallet.Primitive.AddressDiscovery
( IsOurs (..) )
import Cardano.Wallet.Primitive.Types
( Block (..)
, BlockHeader (..)
, Direction (..)
, Dom (..)
, Hash (..)
, SlotId (..)
, Tx (..)
, TxId (..)
, TxIn (..)
@@ -137,7 +137,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)
-> BlockHeader -- Header of the latest applied block (current tip)
-> s -- Address discovery state
-> Wallet s t

@@ -157,9 +157,11 @@ instance NFData (Wallet s t) where
-- | Create an empty wallet from an initial state
initWallet
:: (IsOurs s, NFData s, Show s, TxId t)
=> s
=> BlockHeader
-- ^ Very first 'BlockHeader'
-> s
-> Wallet s t
initWallet = Wallet mempty mempty (SlotId 0 0)
initWallet = Wallet mempty mempty

-- | Update the state of an existing Wallet model
updateState
@@ -190,7 +192,7 @@ applyBlock !b (Wallet !utxo !pending _ s) =
txs
in
( txs'
, Wallet utxo' pending' (b ^. #header . #slotId) s'
, Wallet utxo' pending' (b ^. #header) s'
)

-- | Helper to apply multiple blocks in sequence to an existing wallet. It's
@@ -223,8 +225,8 @@ unsafeInitWallet
-- ^ Unspent tx outputs belonging to this wallet
-> Set Tx
-- ^ Pending outgoing transactions
-> SlotId
-- ^ Latest applied block (current tip)
-> BlockHeader
-- ^ Header of the latest applied block (current tip)
-> s
-- ^Address discovery state
-> Wallet s t
@@ -235,7 +237,7 @@ unsafeInitWallet = Wallet
-------------------------------------------------------------------------------}

-- | Get the wallet current tip
currentTip :: Wallet s t -> SlotId
currentTip :: Wallet s t -> BlockHeader
currentTip (Wallet _ _ tip _) = tip

-- | Get the wallet current state
@@ -761,6 +761,18 @@ 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

0 comments on commit 869803f

Please sign in to comment.
You can’t perform that action at this time.