diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,10 @@ The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.html). +## 0.16.0 +### Changed +- Add support for column families. + ## 0.15.0 ### Changed - Use new Haskell bindings for RocksDB. diff --git a/haskoin-node.cabal b/haskoin-node.cabal --- a/haskoin-node.cabal +++ b/haskoin-node.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 8910b7a1cab081e2bc9808f152235026188f3dccc612d569cfa102a5fe7fa709 +-- hash: b80c691ed899f492d1f0f3165f9f4a78f85253ba1a6bd61a3b4705075572ccae name: haskoin-node -version: 0.15.0 +version: 0.16.0 synopsis: P2P library for Bitcoin and Bitcoin Cash description: Please see the README on GitHub at category: Bitcoin, Finance, Network @@ -45,15 +45,15 @@ , containers , data-default , hashable - , haskoin-core >=0.14.1 + , haskoin-core >=0.15.0 , monad-logger , mtl , network , nqe >=0.6.3 , random , resourcet - , rocksdb-haskell-jprupp - , rocksdb-query >=0.3.1 + , rocksdb-haskell-jprupp >=2.1.2 + , rocksdb-query >=0.4.2 , string-conversions , text , time @@ -81,7 +81,7 @@ , containers , data-default , hashable - , haskoin-core >=0.14.1 + , haskoin-core >=0.15.0 , haskoin-node , hspec , monad-logger @@ -90,8 +90,8 @@ , nqe >=0.6.3 , random , resourcet - , rocksdb-haskell-jprupp - , rocksdb-query >=0.3.1 + , rocksdb-haskell-jprupp >=2.1.2 + , rocksdb-query >=0.4.2 , safe , string-conversions , text diff --git a/src/Haskoin/Node.hs b/src/Haskoin/Node.hs --- a/src/Haskoin/Node.hs +++ b/src/Haskoin/Node.hs @@ -19,7 +19,7 @@ runTCPClient) import Data.String.Conversions (cs) import Data.Time.Clock (NominalDiffTime) -import Database.RocksDB (DB) +import Database.RocksDB (ColumnFamily, DB) import Haskoin (Addr (..), BlockNode (..), Headers (..), Message (..), Network, NetworkAddress, Ping (..), Pong (..)) @@ -36,25 +36,27 @@ -- | General node configuration. data NodeConfig = NodeConfig - { nodeConfMaxPeers :: !Int + { nodeConfMaxPeers :: !Int -- ^ maximum number of connected peers allowed - , nodeConfDB :: !DB + , nodeConfDB :: !DB -- ^ database handler - , nodeConfPeers :: ![HostPort] + , nodeConfColumnFamily :: !(Maybe ColumnFamily) + -- ^ database column family + , nodeConfPeers :: ![HostPort] -- ^ static list of peers to connect to - , nodeConfDiscover :: !Bool + , nodeConfDiscover :: !Bool -- ^ activate peer discovery - , nodeConfNetAddr :: !NetworkAddress + , nodeConfNetAddr :: !NetworkAddress -- ^ network address for the local host - , nodeConfNet :: !Network + , nodeConfNet :: !Network -- ^ network constants - , nodeConfEvents :: !(Publisher NodeEvent) + , nodeConfEvents :: !(Publisher NodeEvent) -- ^ node events are sent to this publisher - , nodeConfTimeout :: !NominalDiffTime + , nodeConfTimeout :: !NominalDiffTime -- ^ timeout in seconds - , nodeConfPeerMaxLife :: !NominalDiffTime + , nodeConfPeerMaxLife :: !NominalDiffTime -- ^ peer disconnect after seconds - , nodeConfConnect :: !(SockAddr -> WithConnection) + , nodeConfConnect :: !(SockAddr -> WithConnection) } data Node = Node { nodeManager :: !PeerManager @@ -166,6 +168,7 @@ chain_config ch_pub = ChainConfig { chainConfDB = nodeConfDB cfg + , chainConfColumnFamily = nodeConfColumnFamily cfg , chainConfNetwork = nodeConfNet cfg , chainConfEvents = ch_pub , chainConfTimeout = nodeConfTimeout cfg diff --git a/src/Haskoin/Node/Chain.hs b/src/Haskoin/Node/Chain.hs --- a/src/Haskoin/Node/Chain.hs +++ b/src/Haskoin/Node/Chain.hs @@ -29,7 +29,7 @@ import Control.Monad.Except (runExceptT, throwError) import Control.Monad.Logger (MonadLoggerIO, logDebugS, logErrorS, logInfoS) -import Control.Monad.Reader (MonadReader, ReaderT, ask, asks, +import Control.Monad.Reader (MonadReader, ReaderT, asks, runReaderT) import Control.Monad.Trans (lift) import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) @@ -45,10 +45,11 @@ import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds) import Data.Word (Word32) -import Database.RocksDB (DB) +import Database.RocksDB (ColumnFamily, DB) import qualified Database.RocksDB as R -import Database.RocksDB.Query (Key, KeyValue, insert, insertOp, - retrieve, writeBatch) +import Database.RocksDB.Query (Key, KeyValue, insert, insertCF, + insertOp, insertOpCF, + retrieveCommon, writeBatch) import Haskoin (BlockHash, BlockHeader (..), BlockHeaders (..), BlockHeight, BlockNode (..), GetHeaders (..), @@ -77,13 +78,15 @@ -- | Configuration for chain syncing process. data ChainConfig = ChainConfig - { chainConfDB :: !DB + { chainConfDB :: !DB -- ^ database handle - , chainConfNetwork :: !Network + , chainConfColumnFamily :: !(Maybe ColumnFamily) + -- ^ column family + , chainConfNetwork :: !Network -- ^ network constants - , chainConfEvents :: !(Publisher ChainEvent) + , chainConfEvents :: !(Publisher ChainEvent) -- ^ send header chain events here - , chainConfTimeout :: !NominalDiffTime + , chainConfTimeout :: !NominalDiffTime -- ^ timeout in seconds } @@ -166,35 +169,43 @@ return BestBlockKey put BestBlockKey = putWord8 0x91 -instance (Monad m, MonadIO m, MonadReader DB m) => +instance (Monad m, MonadIO m, MonadReader ChainConfig m) => BlockHeaders m where addBlockHeader bn = do - db <- ask - insert db (BlockHeaderKey h) bn + db <- asks chainConfDB + asks chainConfColumnFamily >>= \case + Nothing -> insert db (BlockHeaderKey h) bn + Just cf -> insertCF db cf (BlockHeaderKey h) bn where h = headerHash (nodeHeader bn) getBlockHeader bh = do - db <- ask - retrieve db (BlockHeaderKey bh) + db <- asks chainConfDB + mcf <- asks chainConfColumnFamily + retrieveCommon db mcf (BlockHeaderKey bh) getBestBlockHeader = do - db <- ask - retrieve db BestBlockKey >>= \case + db <- asks chainConfDB + mcf <- asks chainConfColumnFamily + retrieveCommon db mcf BestBlockKey >>= \case Nothing -> error "Could not get best block from database" Just b -> return b setBestBlockHeader bn = do - db <- ask - insert db BestBlockKey bn + db <- asks chainConfDB + asks chainConfColumnFamily >>= \case + Nothing -> insert db BestBlockKey bn + Just cf -> insertCF db cf BestBlockKey bn addBlockHeaders bns = do - db <- ask - writeBatch db (map f bns) + db <- asks chainConfDB + mcf <- asks chainConfColumnFamily + writeBatch db (map (f mcf) bns) where h bn = headerHash (nodeHeader bn) - f bn = insertOp (BlockHeaderKey (h bn)) bn + f Nothing bn = insertOp (BlockHeaderKey (h bn)) bn + f (Just cf) bn = insertOpCF cf (BlockHeaderKey (h bn)) bn -withBlockHeaders :: MonadChain m => ReaderT DB m a -> m a +withBlockHeaders :: MonadChain m => ReaderT ChainConfig m a -> m a withBlockHeaders f = do - db <- asks (chainConfDB . myConfig) - runReaderT f db + cfg <- asks myConfig + runReaderT f cfg -- | Launch process to synchronize block headers in current thread. withChain :: @@ -365,11 +376,14 @@ initChainDB :: MonadChain m => m () initChainDB = do db <- asks (chainConfDB . myConfig) + mcf <- asks (chainConfColumnFamily . myConfig) net <- asks (chainConfNetwork . myConfig) - ver <- retrieve db ChainDataVersionKey + ver <- retrieveCommon db mcf ChainDataVersionKey when (ver /= Just dataVersion) $ purgeChainDB >>= writeBatch db - insert db ChainDataVersionKey dataVersion - retrieve db BestBlockKey >>= \b -> + case mcf of + Nothing -> insert db ChainDataVersionKey dataVersion + Just cf -> insertCF db cf ChainDataVersionKey dataVersion + retrieveCommon db mcf BestBlockKey >>= \b -> when (isNothing (b :: Maybe BlockNode)) $ withBlockHeaders $ do addBlockHeader (genesisNode net) @@ -380,17 +394,22 @@ purgeChainDB :: MonadChain m => m [R.BatchOp] purgeChainDB = do db <- asks (chainConfDB . myConfig) - R.withIter db $ \it -> do + mcf <- asks (chainConfColumnFamily . myConfig) + f db mcf $ \it -> do R.iterSeek it $ B.singleton 0x90 - recurse_delete it db + recurse_delete it db mcf where - recurse_delete it db = + f db Nothing = R.withIter db + f db (Just cf) = R.withIterCF db cf + recurse_delete it db mcf = R.iterKey it >>= \case Just k | B.head k == 0x90 || B.head k == 0x91 -> do - R.delete db k + case mcf of + Nothing -> R.delete db k + Just cf -> R.deleteCF db cf k R.iterNext it - (R.Del k :) <$> recurse_delete it db + (R.Del k :) <$> recurse_delete it db mcf _ -> return [] -- | Import a bunch of continuous headers. Returns 'True' if the number of @@ -576,12 +595,12 @@ chainGetBlock :: MonadIO m => BlockHash -> Chain -> m (Maybe BlockNode) chainGetBlock bh ch = - runReaderT (getBlockHeader bh) (chainConfDB (myConfig (chainReader ch))) + runReaderT (getBlockHeader bh) (myConfig (chainReader ch)) -- | Get best block header from chain process. chainGetBest :: MonadIO m => Chain -> m BlockNode chainGetBest ch = - runReaderT getBestBlockHeader (chainConfDB (myConfig (chainReader ch))) + runReaderT getBestBlockHeader (myConfig (chainReader ch)) -- | Get ancestor of 'BlockNode' at 'BlockHeight' from chain process. chainGetAncestor :: MonadIO m @@ -590,7 +609,7 @@ -> Chain -> m (Maybe BlockNode) chainGetAncestor h bn ch = - runReaderT (getAncestor h bn) (chainConfDB (myConfig (chainReader ch))) + runReaderT (getAncestor h bn) (myConfig (chainReader ch)) -- | Get parents of 'BlockNode' starting at 'BlockHeight' from chain process. chainGetParents :: MonadIO m @@ -616,7 +635,7 @@ -> Chain -> m BlockNode chainGetSplitBlock l r ch = - runReaderT (splitPoint l r) (chainConfDB (myConfig (chainReader ch))) + runReaderT (splitPoint l r) (myConfig (chainReader ch)) -- | Notify chain that a new peer is connected. chainPeerConnected :: MonadIO m diff --git a/test/Haskoin/NodeSpec.hs b/test/Haskoin/NodeSpec.hs --- a/test/Haskoin/NodeSpec.hs +++ b/test/Haskoin/NodeSpec.hs @@ -184,16 +184,17 @@ runNoLoggingT $ withSystemTempDirectory ("haskoin-node-test-" <> str <> "-") $ \w -> withPublisher $ \pub -> - R.withDB w def{R.createIfMissing = True, R.errorIfExists = True} $ \db -> do + R.withDBCF w cfg cols $ \db -> do let ad = NetworkAddress nodeNetwork (sockToHostAddress (SockAddrInet 0 0)) na = NetworkAddress 0 (sockToHostAddress (SockAddrInet 0 0)) - cfg = NodeConfig + cfg' = NodeConfig { nodeConfMaxPeers = 20 , nodeConfDB = db + , nodeConfColumnFamily = Just (head (R.columnFamilies db)) , nodeConfPeers = [("127.0.0.1", 17486)] , nodeConfDiscover = False , nodeConfNetAddr = na @@ -203,13 +204,16 @@ , nodeConfPeerMaxLife = 48 * 3600 , nodeConfConnect = dummyPeerConnect net ad } - withNode cfg $ \(Node mgr ch) -> + withNode cfg' $ \(Node mgr ch) -> withSubscription pub $ \sub -> lift $ f TestNode { testMgr = mgr , testChain = ch , nodeEvents = sub } + where + cfg = def{R.createIfMissing = True, R.errorIfExists = True} + cols = [("node", def)] allBlocks :: [Block] allBlocks =