Skip to content

Commit

Permalink
Try #1763:
Browse files Browse the repository at this point in the history
  • Loading branch information
iohk-bors[bot] authored Jun 17, 2020
2 parents 9650f59 + e8e1d83 commit ab6a85c
Show file tree
Hide file tree
Showing 21 changed files with 558 additions and 80 deletions.
28 changes: 21 additions & 7 deletions lib/byron/src/Cardano/Wallet/Byron/Network.hs
Original file line number Diff line number Diff line change
Expand Up @@ -49,8 +49,10 @@ import Cardano.Wallet.Byron.Compatibility
)
import Cardano.Wallet.Network
( Cursor, ErrPostTx (..), NetworkLayer (..), mapCursor )
import Control.Concurrent
( ThreadId )
import Control.Concurrent.Async
( async, link )
( Async, async, asyncThreadId, cancel, link )
import Control.Exception
( IOException )
import Control.Monad
Expand Down Expand Up @@ -192,6 +194,7 @@ import qualified Data.Text.Encoding as T
-- | Network layer cursor for Byron. Mostly useless since the protocol itself is
-- stateful and the node's keep track of the associated connection's cursor.
data instance Cursor (m Byron) = Cursor
(Async ())
(Point ByronBlock)
(TQueue m (ChainSyncCmd ByronBlock m))

Expand Down Expand Up @@ -232,6 +235,7 @@ withNetworkLayer tr np addrInfo versionData action = do
{ currentNodeTip = liftIO $ _currentNodeTip nodeTipVar
, nextBlocks = _nextBlocks
, initCursor = _initCursor
, destroyCursor = _destroyCursor
, cursorSlotId = _cursorSlotId
, getProtocolParameters = atomically $ readTVar protocolParamsVar
, postTx = _postTx localTxSubmissionQ
Expand All @@ -248,8 +252,8 @@ withNetworkLayer tr np addrInfo versionData action = do
chainSyncQ <- atomically newTQueue
client <- mkWalletClient gp chainSyncQ
let handlers = failOnConnectionLost tr
link =<< async
(connectClient tr handlers client versionData addrInfo)
thread <- async (connectClient tr handlers client versionData addrInfo)
link thread
let points = reverse $ genesisPoint :
(toPoint getGenesisBlockHash getEpochLength <$> headers)
let findIt = chainSyncQ `send` CmdFindIntersection points
Expand All @@ -261,18 +265,22 @@ withNetworkLayer tr np addrInfo versionData action = do
$ MsgIntersectionFound
$ fromChainHash getGenesisBlockHash
$ pointHash intersection
pure $ Cursor intersection chainSyncQ
pure $ Cursor thread intersection chainSyncQ
_ -> fail $ unwords
[ "initCursor: intersection not found? This can't happen"
, "because we always give at least the genesis point."
, "Here are the points we gave: " <> show headers
]

_nextBlocks (Cursor _ chainSyncQ) = do
let toCursor point = Cursor point chainSyncQ
_destroyCursor (Cursor thread _ _) = do
liftIO $ traceWith tr $ MsgDestroyCursor (asyncThreadId thread)
cancel thread

_nextBlocks (Cursor thread _ chainSyncQ) = do
let toCursor point = Cursor thread point chainSyncQ
liftIO $ mapCursor toCursor <$> chainSyncQ `send` CmdNextBlocks

_cursorSlotId (Cursor point _) = do
_cursorSlotId (Cursor _ point _) = do
fromSlotNo getEpochLength $ fromWithOrigin (SlotNo 0) $ pointSlot point

_getAccountBalance _ =
Expand Down Expand Up @@ -572,6 +580,7 @@ data NetworkLayerLog
| MsgNodeTip W.BlockHeader
| MsgProtocolParameters W.ProtocolParameters
| MsgLocalStateQueryError String
| MsgDestroyCursor ThreadId

type HandshakeTrace = TraceSendRecv (Handshake NodeToClientVersion CBOR.Term)

Expand Down Expand Up @@ -617,6 +626,10 @@ instance ToText NetworkLayerLog where
[ "Error when querying local state parameters:"
, T.pack e
]
MsgDestroyCursor threadId -> T.unwords
[ "Destroying cursor connection at"
, T.pack (show threadId)
]

instance HasPrivacyAnnotation NetworkLayerLog
instance HasSeverityAnnotation NetworkLayerLog where
Expand All @@ -635,3 +648,4 @@ instance HasSeverityAnnotation NetworkLayerLog where
MsgNodeTip{} -> Debug
MsgProtocolParameters{} -> Info
MsgLocalStateQueryError{} -> Error
MsgDestroyCursor{} -> Notice
17 changes: 17 additions & 0 deletions lib/core/src/Cardano/Pool/DB.hs
Original file line number Diff line number Diff line change
Expand Up @@ -25,6 +25,7 @@ import Cardano.Wallet.Primitive.Types
, PoolId
, PoolRegistrationCertificate
, SlotId (..)
, StakePoolMetadataRef
)
import Control.Monad.Fail
( MonadFail )
Expand Down Expand Up @@ -116,6 +117,22 @@ data DBLayer m = forall stm. (MonadFail stm, MonadIO stm) => DBLayer
-- map we would get from 'readPoolProduction' because not all registered
-- pools have necessarily produced any block yet!

, putPoolMetadataRef
:: PoolId
-> StakePoolMetadataRef
-> stm ()
-- ^ Store references to a stake pool metadata found on chain.

, deletePoolMetadataRef
:: PoolId
-> stm ()
-- ^ Remove pool metadata references from the database.

, peekPoolMetadataRef
:: stm (Maybe (PoolId, StakePoolMetadataRef))
-- ^ Peek at some pool metadata ref. Returns at most 'n' elements, where
-- 'n' is the first parameter.

, readSystemSeed
:: stm StdGen
-- ^ Read the seed assigned to this particular database. The seed is
Expand Down
12 changes: 12 additions & 0 deletions lib/core/src/Cardano/Pool/DB/MVar.hs
Original file line number Diff line number Diff line change
Expand Up @@ -24,7 +24,10 @@ import Cardano.Pool.DB.Model
, PoolErr (..)
, emptyPoolDatabase
, mCleanPoolProduction
, mDeletePoolMetadataRef
, mListRegisteredPools
, mPeekPoolMetadataRef
, mPutPoolMetadataRef
, mPutPoolProduction
, mPutPoolRegistration
, mPutStakeDistribution
Expand Down Expand Up @@ -84,6 +87,15 @@ newDBLayer = do
, listRegisteredPools =
modifyMVar db (pure . swap . mListRegisteredPools)

, putPoolMetadataRef = \a0 a1 ->
void $ alterPoolDB (const Nothing) db (mPutPoolMetadataRef a0 a1)

, deletePoolMetadataRef =
void . alterPoolDB (const Nothing) db . mDeletePoolMetadataRef

, peekPoolMetadataRef =
modifyMVar db (pure . swap . mPeekPoolMetadataRef)

, readSystemSeed =
modifyMVar db (fmap swap . mReadSystemSeed)

Expand Down
30 changes: 28 additions & 2 deletions lib/core/src/Cardano/Pool/DB/Model.hs
Original file line number Diff line number Diff line change
Expand Up @@ -41,6 +41,9 @@ module Cardano.Pool.DB.Model
, mPutPoolRegistration
, mReadPoolRegistration
, mListRegisteredPools
, mPutPoolMetadataRef
, mDeletePoolMetadataRef
, mPeekPoolMetadataRef
, mReadSystemSeed
, mRollbackTo
, mReadCursor
Expand All @@ -55,11 +58,14 @@ import Cardano.Wallet.Primitive.Types
, PoolOwner (..)
, PoolRegistrationCertificate (..)
, SlotId (..)
, StakePoolMetadataRef
)
import Data.Foldable
( fold )
import Data.Map.Strict
( Map )
import Data.Maybe
( listToMaybe )
import Data.Ord
( Down (..) )
import Data.Quantity
Expand Down Expand Up @@ -94,6 +100,9 @@ data PoolDatabase = PoolDatabase
, metadata :: !(Map (SlotId, PoolId) (Percentage, Quantity "lovelace" Word64))
-- ^ On-chain metadata associated with pools

, metadataRef :: [(PoolId, StakePoolMetadataRef)]
-- ^ On-chain metadata references needed to fetch metadata

, seed :: !SystemSeed
-- ^ Store an arbitrary random generator seed
} deriving (Generic, Show, Eq)
Expand All @@ -111,7 +120,7 @@ instance Eq SystemSeed where

-- | Produces an empty model pool production database.
emptyPoolDatabase :: PoolDatabase
emptyPoolDatabase = PoolDatabase mempty mempty mempty mempty NotSeededYet
emptyPoolDatabase = PoolDatabase mempty mempty mempty mempty mempty NotSeededYet

{-------------------------------------------------------------------------------
Model Operation Types
Expand Down Expand Up @@ -206,6 +215,22 @@ mListRegisteredPools :: PoolDatabase -> ([PoolId], PoolDatabase)
mListRegisteredPools db@PoolDatabase{metadata} =
( snd <$> Map.keys metadata, db )

mPutPoolMetadataRef :: PoolId -> StakePoolMetadataRef -> ModelPoolOp ()
mPutPoolMetadataRef pid ref db@PoolDatabase{metadataRef} =
( Right ()
, db { metadataRef = (pid, ref):metadataRef }
)

mDeletePoolMetadataRef :: PoolId -> ModelPoolOp ()
mDeletePoolMetadataRef pid db@PoolDatabase{metadataRef} =
( Right ()
, db { metadataRef = filter ((/= pid) . fst) metadataRef }
)

mPeekPoolMetadataRef :: PoolDatabase -> (Maybe (PoolId, StakePoolMetadataRef), PoolDatabase)
mPeekPoolMetadataRef db@PoolDatabase{metadataRef} =
( listToMaybe $ take 1 metadataRef, db )

mReadSystemSeed
:: PoolDatabase
-> IO (StdGen, PoolDatabase)
Expand All @@ -225,7 +250,7 @@ mReadCursor k db@PoolDatabase{pools} =
in (Right $ reverse $ limit $ sortDesc allHeaders, db)

mRollbackTo :: SlotId -> ModelPoolOp ()
mRollbackTo point PoolDatabase{pools, distributions, owners, metadata, seed} =
mRollbackTo point PoolDatabase{pools, distributions, owners, metadata, metadataRef, seed} =
let
metadata' = Map.mapMaybeWithKey (discardBy id . fst) metadata
owners' = Map.restrictKeys owners
Expand All @@ -238,6 +263,7 @@ mRollbackTo point PoolDatabase{pools, distributions, owners, metadata, seed} =
, distributions = Map.mapMaybeWithKey (discardBy epochNumber) distributions
, owners = owners'
, metadata = metadata'
, metadataRef
, seed
}
)
Expand Down
20 changes: 20 additions & 0 deletions lib/core/src/Cardano/Pool/DB/Sqlite.hs
Original file line number Diff line number Diff line change
Expand Up @@ -46,6 +46,7 @@ import Cardano.Wallet.Primitive.Types
, PoolId
, PoolRegistrationCertificate (..)
, SlotId (..)
, StakePoolMetadataRef (..)
)
import Cardano.Wallet.Unsafe
( unsafeMkPercentage )
Expand Down Expand Up @@ -74,6 +75,7 @@ import Database.Persist.Sql
, deleteWhere
, insertMany_
, insert_
, putMany
, selectFirst
, selectList
, (<.)
Expand Down Expand Up @@ -214,6 +216,15 @@ newDBLayer trace fp = do
fmap (poolRegistrationPoolId . entityVal) <$> selectList [ ]
[ Desc PoolRegistrationSlot ]

, putPoolMetadataRef = \poolId ref -> do
putMany [PoolMetadataQueue poolId (metadataURL ref) (metadataHash ref)]

, deletePoolMetadataRef = \poolId -> do
deleteWhere [PoolMetadataQueuePoolId ==. poolId]

, peekPoolMetadataRef = do
fmap (fromPoolMetadataQueue . entityVal) <$> selectFirst [] []

, rollbackTo = \point -> do
let (EpochNo epoch) = epochNumber point
deleteWhere [ PoolProductionSlot >. point ]
Expand All @@ -240,6 +251,8 @@ newDBLayer trace fp = do
deleteWhere ([] :: [Filter PoolOwner])
deleteWhere ([] :: [Filter PoolRegistration])
deleteWhere ([] :: [Filter StakeDistribution])
deleteWhere ([] :: [Filter PoolMetadata])
deleteWhere ([] :: [Filter PoolMetadataQueue])

, atomically = runQuery
})
Expand Down Expand Up @@ -326,3 +339,10 @@ fromStakeDistribution distribution =
( stakeDistributionPoolId distribution
, Quantity (stakeDistributionStake distribution)
)


fromPoolMetadataQueue
:: PoolMetadataQueue
-> (PoolId, StakePoolMetadataRef)
fromPoolMetadataQueue (PoolMetadataQueue poolId url hash) =
(poolId, StakePoolMetadataRef url hash)
26 changes: 26 additions & 0 deletions lib/core/src/Cardano/Pool/DB/Sqlite/TH.hs
Original file line number Diff line number Diff line change
Expand Up @@ -22,6 +22,10 @@ import Prelude

import Cardano.Wallet.DB.Sqlite.Types
( sqlSettings' )
import Data.ByteString
( ByteString )
import Data.Text
( Text )
import Data.Word
( Word32, Word64, Word8 )
import Database.Persist.Class
Expand Down Expand Up @@ -89,4 +93,26 @@ PoolRegistration sql=pool_registration

Primary poolRegistrationPoolId
deriving Show Generic

-- Temporary queue where metadata to fetch are stored.
PoolMetadataQueue sql=pool_metadata_queue
poolMetadataQueuePoolId W.PoolId sql=pool_id
poolMetadataQueueUrl Text sql=metadata_url
poolMetadataQueueHash ByteString sql=metadata_hash

Primary poolMetadataQueuePoolId
deriving Show Generic

-- Cached metadata after they've been fetched from a remote server.
PoolMetadata sql=pool_metadata
poolMetadataPoolId W.PoolId sql=pool_id
poolMetadataName Text sql=name
poolMetadataTicker W.StakePoolTicker sql=ticker
poolMetadataDescription Text Maybe sql=description
poolMetadataHomepage Text sql=homepage
poolMetadataPledge Word64 sql=pledge
poolMetadataOwner ByteString sql=owner

Primary poolMetadataPoolId
deriving Show Generic
|]
11 changes: 11 additions & 0 deletions lib/core/src/Cardano/Wallet/DB/Sqlite/Types.hs
Original file line number Diff line number Diff line change
Expand Up @@ -36,6 +36,7 @@ import Cardano.Wallet.Primitive.Types
, PoolOwner (..)
, SlotId (..)
, SlotNo (..)
, StakePoolTicker
, TxStatus (..)
, WalletId (..)
, flatSlot
Expand Down Expand Up @@ -454,3 +455,13 @@ instance PersistField PassphraseScheme where

instance PersistFieldSql PassphraseScheme where
sqlType _ = sqlType (Proxy @String)

----------------------------------------------------------------------------
-- StakePoolTicker

instance PersistField StakePoolTicker where
toPersistValue = toPersistValue . toText
fromPersistValue = fromPersistValueFromText

instance PersistFieldSql StakePoolTicker where
sqlType _ = sqlType (Proxy @Text)
Loading

0 comments on commit ab6a85c

Please sign in to comment.