diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,13 +4,38 @@ 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.20.0 +### Added +- Low version bounds for some dependencies. +- Compatibility with GHC 8.8. +- Faster retrieval of extended public key balances and transactions. + +### Removed +- In-memory RocksDB-based cache. + +### Changed +- Refactor codebase. + +## 0.19.6 +### Added +- Use a parallel strategy to compute key derivations. + +### Fixed +- Do not fail health check upon transaction timeout while syncing. + +### Changed +- Do not use conduits for xpub balance streams. +- Multiple minor refactorings. + ## 0.19.5 ### Changed - Minor refactor to block import code. + +### Fixed - Minor fix to transaction timeout check. ## 0.19.4 -### Changed +### Fixed - Clarify and correct health check algorithm. ## 0.19.3 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -32,4 +32,4 @@ ## API Documentation -* [Swagger API Documentation](https://btc.haskoin.com/). +* [Swagger API Documentation](https://api.haskoin.com/). diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,37 +1,39 @@ {-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} module Main where -import Conduit -import Control.Arrow -import Control.Exception () -import Control.Monad -import Control.Monad.Logger -import Data.Bits -import Data.List -import Data.Maybe -import Data.String.Conversions -import Data.Version -import Database.RocksDB as R -import Haskoin -import Haskoin.Node -import Haskoin.Store -import NQE -import Options.Applicative -import Paths_haskoin_store as P -import System.Exit -import System.FilePath -import System.IO.Unsafe -import Text.Read (readMaybe) -import UnliftIO -import UnliftIO.Directory +import Control.Arrow (second) +import Control.Monad (when) +import Control.Monad.Logger (LogLevel (..), filterLogger, logInfoS, + runStderrLoggingT) +import Data.List (intercalate) +import Data.Maybe (fromMaybe) +import Data.String.Conversions (cs) +import Data.Version (showVersion) +import Haskoin (Network (..), allNets, bch, + bchRegTest, bchTest, btc, btcRegTest, + btcTest) +import Haskoin.Node (Host, Port) +import Haskoin.Store (MaxLimits (..), StoreConfig (..), + Timeouts (..), WebConfig (..), + connectRocksDB, runWeb, withStore) +import NQE (PublisherMessage (..), sendSTM, + withPublisher) +import Options.Applicative (Parser, auto, eitherReader, + execParser, fullDesc, header, help, + helper, info, long, many, metavar, + option, progDesc, short, showDefault, + strOption, switch, value) +import Paths_haskoin_store as P +import System.Exit (die, exitSuccess) +import System.FilePath (()) +import System.IO.Unsafe (unsafePerformIO) +import Text.Read (readMaybe) +import UnliftIO (MonadUnliftIO, liftIO) +import UnliftIO.Directory (createDirectoryIfMissing, + getAppUserDataDirectory) data Config = Config { configDir :: !FilePath @@ -40,7 +42,6 @@ , configDiscover :: !Bool , configPeers :: ![(Host, Maybe Port)] , configVersion :: !Bool - , configCache :: !FilePath , configDebug :: !Bool , configReqLog :: !Bool , configMaxLimits :: !MaxLimits @@ -63,7 +64,6 @@ , maxLimitFull = 500 , maxLimitOffset = 50000 , maxLimitDefault = 100 - , maxLimitGap = 20 } defTimeouts :: Timeouts @@ -72,7 +72,7 @@ config :: Parser Config config = do configDir <- - option str $ + strOption $ metavar "WORKDIR" <> long "dir" <> short 'd' <> help "Data directory" <> showDefault <> value myDirectory @@ -92,11 +92,6 @@ many . option (eitherReader peerReader) $ metavar "HOST" <> long "peer" <> short 'p' <> help "Network peer (as many as required)" - configCache <- - option str $ - metavar "CACHEDIR" <> long "cache" <> short 'c' <> - help "RAM drive directory for acceleration" <> - value "" configVersion <- switch $ long "version" <> short 'v' <> help "Show version" configDebug <- switch $ long "debug" <> help "Show debug messages" configReqLog <- switch $ long "reqlog" <> help "HTTP request logging" @@ -114,19 +109,16 @@ value (maxLimitFull defMaxLimits) maxLimitOffset <- option auto $ - metavar "MAXOFFSET" <> long "maxoffset" <> help "Max offset (0 for no limit)" <> + metavar "MAXOFFSET" <> long "maxoffset" <> + help "Max offset (0 for no limit)" <> showDefault <> value (maxLimitOffset defMaxLimits) maxLimitDefault <- option auto $ - metavar "LIMITDEFAULT" <> long "deflimit" <> help "Default limit (0 for max)" <> + metavar "LIMITDEFAULT" <> long "deflimit" <> + help "Default limit (0 for max)" <> showDefault <> value (maxLimitDefault defMaxLimits) - maxLimitGap <- - option auto $ - metavar "GAP" <> long "gap" <> help "Extended public key gap" <> - showDefault <> - value (maxLimitGap defMaxLimits) blockTimeout <- option auto $ metavar "BLOCKSECONDS" <> long "blocktimeout" <> @@ -190,63 +182,22 @@ Options.Applicative.header ("haskoin-store version " <> showVersion P.version) -cacheDir :: Network -> FilePath -> Maybe FilePath -cacheDir _ "" = Nothing -cacheDir net ch = Just (ch getNetworkName net "cache") - run :: MonadUnliftIO m => Config -> m () run Config { configPort = port , configNetwork = net , configDiscover = disc , configPeers = peers - , configCache = cache_path , configDir = db_dir , configDebug = deb , configMaxLimits = limits , configReqLog = reqlog , configTimeouts = tos } = - runStderrLoggingT . filterLogger l . flip finally clear $ do + runStderrLoggingT . filterLogger l $ do $(logInfoS) "Main" $ "Creating working directory if not found: " <> cs wd createDirectoryIfMissing True wd - db <- - do dbh <- - open - (wd "db") - R.defaultOptions - { createIfMissing = True - , compression = SnappyCompression - , maxOpenFiles = -1 - , writeBufferSize = 2 `shift` 30 - } - return BlockDB {blockDB = dbh, blockDBopts = defaultReadOptions} - cdb <- - case cd of - Nothing -> return Nothing - Just ch -> do - $(logInfoS) "Main" $ "Deleting cache directory: " <> cs ch - removePathForcibly ch - $(logInfoS) "Main" $ "Creating cache directory: " <> cs ch - createDirectoryIfMissing True ch - dbh <- - open - ch - R.defaultOptions - { createIfMissing = True - , compression = SnappyCompression - , maxOpenFiles = -1 - , writeBufferSize = 2 `shift` 30 - } - return $ - Just - BlockDB - { blockDB = dbh - , blockDBopts = defaultReadOptions - } - $(logInfoS) "Main" "Populating cache (if active)..." - ldb <- newLayeredDB db cdb - $(logInfoS) "Main" "Finished populating cache" + db <- connectRocksDB (wd "db") withPublisher $ \pub -> let scfg = StoreConfig @@ -256,7 +207,7 @@ (second (fromMaybe (getDefaultPort net))) peers , storeConfDiscover = disc - , storeConfDB = ldb + , storeConfDB = db , storeConfNetwork = net , storeConfListen = (`sendSTM` pub) . Event } @@ -265,7 +216,7 @@ WebConfig { webPort = port , webNetwork = net - , webDB = ldb + , webDB = db , webPublisher = pub , webStore = st , webMaxLimits = limits @@ -277,14 +228,4 @@ l _ lvl | deb = True | otherwise = LevelInfo <= lvl - clear = - case cd of - Nothing -> return () - Just ch -> do - $(logInfoS) "Main" $ "Deleting cache directory: " <> cs ch - removePathForcibly ch wd = db_dir getNetworkName net - cd = - case cache_path of - "" -> Nothing - ch -> Just (ch getNetworkName net "cache") diff --git a/haskoin-store.cabal b/haskoin-store.cabal --- a/haskoin-store.cabal +++ b/haskoin-store.cabal @@ -4,17 +4,17 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 26faa85a93fdd1e9052201cb5f666112daf3c90e2d738cf1251cc8764cb03aa2 +-- hash: 186caec51745ecbf3bd414752a0c036b2ba3827eb0639af8f70fa09fac6bd10f name: haskoin-store -version: 0.19.5 +version: 0.20.0 synopsis: Storage and index for Bitcoin and Bitcoin Cash description: Store blocks, transactions, and balances for Bitcoin or Bitcoin Cash, and make that information via REST API. category: Bitcoin, Finance, Network homepage: http://github.com/haskoin/haskoin-store#readme bug-reports: http://github.com/haskoin/haskoin-store/issues author: Jean-Pierre Rupp -maintainer: xenog@protonmail.com +maintainer: jprupp@protonmail.ch license: PublicDomain license-file: UNLICENSE build-type: Simple @@ -32,30 +32,30 @@ Paths_haskoin_store other-modules: Network.Haskoin.Store.Block - Network.Haskoin.Store.Data - Network.Haskoin.Store.Data.Cached Network.Haskoin.Store.Data.ImportDB Network.Haskoin.Store.Data.KeyValue Network.Haskoin.Store.Data.Memory Network.Haskoin.Store.Data.RocksDB + Network.Haskoin.Store.Data.Types Network.Haskoin.Store.Logic - Network.Haskoin.Store.Messages Network.Haskoin.Store.Web autogen-modules: Paths_haskoin_store hs-source-dirs: src build-depends: - aeson + QuickCheck + , aeson , base >=4.9 && <5 , bytestring , cereal , conduit , containers , data-default + , deepseq , hashable - , haskoin-core >=0.9.7 - , haskoin-node + , haskoin-core >=0.10.1 + , haskoin-node >=0.9.16 , http-types , monad-logger , mtl @@ -64,7 +64,7 @@ , random , resourcet , rocksdb-haskell - , rocksdb-query >=0.3.0 + , rocksdb-query >=0.3.1 , scotty , string-conversions , text @@ -84,17 +84,19 @@ app ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: - aeson + QuickCheck + , aeson , base >=4.9 && <5 , bytestring , cereal , conduit , containers , data-default + , deepseq , filepath , hashable - , haskoin-core >=0.9.7 - , haskoin-node + , haskoin-core >=0.10.1 + , haskoin-node >=0.9.16 , haskoin-store , http-types , monad-logger @@ -105,7 +107,7 @@ , random , resourcet , rocksdb-haskell - , rocksdb-query >=0.3.0 + , rocksdb-query >=0.3.1 , scotty , string-conversions , text @@ -122,23 +124,34 @@ main-is: Spec.hs other-modules: Haskoin.StoreSpec - Network.Haskoin.Store.DataSpec + Network.Haskoin.Store.Data.TypesSpec + Haskoin.Store + Network.Haskoin.Store.Block + Network.Haskoin.Store.Data.ImportDB + Network.Haskoin.Store.Data.KeyValue + Network.Haskoin.Store.Data.Memory + Network.Haskoin.Store.Data.RocksDB + Network.Haskoin.Store.Data.Types + Network.Haskoin.Store.Logic + Network.Haskoin.Store.Web Paths_haskoin_store hs-source-dirs: test + src ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: - aeson + QuickCheck + , aeson , base >=4.9 && <5 , bytestring , cereal , conduit , containers , data-default + , deepseq , hashable - , haskoin-core >=0.9.7 - , haskoin-node - , haskoin-store + , haskoin-core >=0.10.1 + , haskoin-node >=0.9.16 , hspec , http-types , monad-logger @@ -148,7 +161,7 @@ , random , resourcet , rocksdb-haskell - , rocksdb-query >=0.3.0 + , rocksdb-query >=0.3.1 , scotty , string-conversions , text diff --git a/src/Haskoin/Store.hs b/src/Haskoin/Store.hs --- a/src/Haskoin/Store.hs +++ b/src/Haskoin/Store.hs @@ -1,21 +1,13 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} module Haskoin.Store ( Store(..) , BlockStore , StoreConfig(..) + , StoreRead(..) + , StoreWrite(..) + , StoreStream(..) , StoreEvent(..) , BlockData(..) , Transaction(..) - , Input(..) - , Output(..) , Spender(..) , BlockRef(..) , Unspent(..) @@ -35,31 +27,20 @@ , UnixTime , BlockPos , BlockDB(..) - , LayeredDB(..) , WebConfig(..) , MaxLimits(..) , Timeouts(..) , Offset , Limit - , newLayeredDB , withStore , runWeb , store - , getBestBlock - , getBlocksAtHeight - , getBlock , getTransaction - , getTxData - , getSpenders - , getSpender , fromTransaction , toTransaction - , getBalance - , getMempool - , getAddressUnspents + , transactionData , getAddressUnspentsLimit , getAddressesUnspentsLimit - , getAddressTxs , getAddressTxsFull , getAddressTxsLimit , getAddressesTxsFull @@ -70,42 +51,91 @@ , xpubUnspentLimit , xpubSummary , publishTx - , transactionData , isCoinbase , confirmed , cbAfterHeight , healthCheck , withBlockMem - , withLayeredDB + , withRocksDB + , connectRocksDB + , initRocksDB ) where -import Conduit -import Control.Monad -import qualified Control.Monad.Except as E -import Control.Monad.Logger -import Control.Monad.Trans.Maybe -import Data.Foldable -import Data.Function -import qualified Data.HashMap.Strict as H -import Data.List -import Data.Maybe +import Control.Monad (unless, when) +import Control.Monad.Logger (MonadLoggerIO) import Data.Serialize (decode) -import qualified Data.Text as T -import Data.Word (Word32) -import Database.RocksDB as R -import Haskoin -import Haskoin.Node -import Network.Haskoin.Store.Block -import Network.Haskoin.Store.Data -import Network.Haskoin.Store.Data.Cached -import Network.Haskoin.Store.Data.Memory -import Network.Haskoin.Store.Data.RocksDB -import Network.Haskoin.Store.Messages -import Network.Haskoin.Store.Web +import Haskoin (BlockHash (..), Inv (..), + InvType (..), + InvVector (..), + Message (..), + MessageCommand (..), + NetworkAddress (..), + NotFound (..), Pong (..), + Reject (..), TxHash (..), + VarString (..), + sockToHostAddress) +import Haskoin.Node (ChainEvent (..), + ChainMessage, + ManagerMessage, + NodeConfig (..), + NodeEvent (..), + PeerEvent (..), node) +import Network.Haskoin.Store.Block (blockStore) +import Network.Haskoin.Store.Data.Memory (withBlockMem) +import Network.Haskoin.Store.Data.RocksDB (connectRocksDB, + initRocksDB, withRocksDB) +import Network.Haskoin.Store.Data.Types (Balance (..), + BinSerial (..), + BlockConfig (..), + BlockDB (..), + BlockData (..), + BlockMessage (..), + BlockPos, BlockRef (..), + BlockStore, BlockTx (..), + Event (..), + HealthCheck (..), + JsonSerial (..), Limit, + Offset, + PeerInformation (..), + PubExcept (..), + Spender (..), Store (..), + StoreConfig (..), + StoreEvent (..), + StoreRead (..), + StoreStream (..), + StoreWrite (..), + Transaction (..), + TxAfterHeight (..), + TxId (..), UnixTime, + Unspent (..), XPubBal (..), + XPubUnspent (..), + confirmed, fromTransaction, + getTransaction, isCoinbase, + toTransaction, + transactionData) +import Network.Haskoin.Store.Web (Except (..), + MaxLimits (..), + Timeouts (..), + WebConfig (..), + cbAfterHeight, + getAddressTxsFull, + getAddressTxsLimit, + getAddressUnspentsLimit, + getAddressesTxsFull, + getAddressesTxsLimit, + getAddressesUnspentsLimit, + getPeersInformation, + healthCheck, publishTx, + runWeb, xpubBals, + xpubSummary, xpubUnspent, + xpubUnspentLimit) import Network.Socket (SockAddr (..)) -import NQE -import System.Random -import UnliftIO +import NQE (Inbox, Listen, + Process (..), + inboxToMailbox, newInbox, + sendSTM, withProcess) +import UnliftIO (MonadUnliftIO, link, + withAsync) withStore :: (MonadLoggerIO m, MonadUnliftIO m) @@ -137,11 +167,12 @@ let ncfg = NodeConfig { nodeConfMaxPeers = storeConfMaxPeers cfg - , nodeConfDB = blockDB . layeredDB $ storeConfDB cfg + , nodeConfDB = blockDB (storeConfDB cfg) , nodeConfPeers = storeConfInitPeers cfg , nodeConfDiscover = storeConfDiscover cfg , nodeConfEvents = storeDispatch b l - , nodeConfNetAddr = NetworkAddress 0 (SockAddrInet 0 0) + , nodeConfNetAddr = + NetworkAddress 0 (sockToHostAddress (SockAddrInet 0 0)) , nodeConfNet = storeConfNetwork cfg , nodeConfTimeout = 10 } diff --git a/src/Network/Haskoin/Store/Block.hs b/src/Network/Haskoin/Store/Block.hs --- a/src/Network/Haskoin/Store/Block.hs +++ b/src/Network/Haskoin/Store/Block.hs @@ -2,7 +2,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} @@ -10,25 +9,70 @@ ( blockStore ) where -import Conduit -import Control.Monad.Except -import Control.Monad.Logger -import Control.Monad.Reader -import Control.Monad.Trans.Maybe -import Data.Maybe -import Data.String -import Data.String.Conversions -import Data.Time.Clock.System -import Haskoin -import Haskoin.Node -import Network.Haskoin.Store.Data -import Network.Haskoin.Store.Data.ImportDB -import Network.Haskoin.Store.Logic -import Network.Haskoin.Store.Messages -import NQE -import System.Random -import UnliftIO -import UnliftIO.Concurrent +import Conduit (MonadResource, runConduit, + runResourceT, sinkList, + transPipe, (.|)) +import Control.Monad (forM, forever, guard, + mzero, unless, void, when) +import Control.Monad.Except (ExceptT, runExceptT) +import Control.Monad.Logger (MonadLoggerIO, logDebugS, + logErrorS, logInfoS, + logWarnS) +import Control.Monad.Reader (MonadReader, ReaderT (..), + asks) +import Control.Monad.Trans (lift) +import Control.Monad.Trans.Maybe (runMaybeT) +import Data.Maybe (catMaybes, isNothing) +import Data.String (fromString) +import Data.String.Conversions (cs) +import Data.Time.Clock.System (getSystemTime, + systemSeconds) +import Haskoin (Block (..), + BlockHash (..), + BlockHeight, + BlockNode (..), + GetData (..), + InvType (..), + InvVector (..), + Message (..), + Network (..), Tx, + TxHash (..), + blockHashToHex, + headerHash, txHash, + txHashToHex) +import Haskoin.Node (OnlinePeer (..), Peer, + PeerException (..), + chainBlockMain, + chainGetAncestor, + chainGetBest, + chainGetBlock, + chainGetParents, killPeer, + managerGetPeers, + sendMessage) +import Network.Haskoin.Store.Data.ImportDB (ImportDB, runImportDB) +import Network.Haskoin.Store.Data.Types (BlockConfig (..), BlockDB, + BlockMessage (..), + BlockStore, + StoreEvent (..), + StoreRead (..), + StoreStream (..), + StoreWrite (..), UnixTime) +import Network.Haskoin.Store.Logic (ImportException, + getOldOrphans, + importBlock, importOrphan, + initBest, newMempoolTx, + revertBlock) +import NQE (Inbox, Mailbox, + inboxToMailbox, query, + receive) +import System.Random (randomRIO) +import UnliftIO (Exception, MonadIO, + MonadUnliftIO, TVar, + atomically, liftIO, + newTVarIO, readTVarIO, + throwIO, withAsync, + writeTVar) +import UnliftIO.Concurrent (threadDelay) data BlockException = BlockNotInChain !BlockHash @@ -61,29 +105,34 @@ runImport f = ReaderT $ \r -> runExceptT (runImportDB (blockConfDB (myConfig r)) f) -runLayered :: ReaderT LayeredDB m a -> ReaderT BlockRead m a -runLayered f = ReaderT $ \r -> runReaderT f (blockConfDB (myConfig r)) +runRocksDB :: ReaderT BlockDB m a -> ReaderT BlockRead m a +runRocksDB f = + ReaderT $ \BlockRead {myConfig = BlockConfig {blockConfDB = db}} -> + runReaderT f db instance MonadIO m => StoreRead (ReaderT BlockRead m) where - isInitialized = runLayered isInitialized - getBestBlock = runLayered getBestBlock - getBlocksAtHeight = runLayered . getBlocksAtHeight - getBlock = runLayered . getBlock - getTxData = runLayered . getTxData - getSpender = runLayered . getSpender - getSpenders = runLayered . getSpenders - getOrphanTx = runLayered . getOrphanTx - getUnspent = runLayered . getUnspent - getBalance = runLayered . getBalance - getMempool = runLayered getMempool + getBestBlock = runRocksDB getBestBlock + getBlocksAtHeight = runRocksDB . getBlocksAtHeight + getBlock = runRocksDB . getBlock + getTxData = runRocksDB . getTxData + getSpender = runRocksDB . getSpender + getSpenders = runRocksDB . getSpenders + getOrphanTx = runRocksDB . getOrphanTx + getUnspent = runRocksDB . getUnspent + getBalance = runRocksDB . getBalance + getMempool = runRocksDB getMempool + getAddressesTxs addrs start limit = + runRocksDB (getAddressesTxs addrs start limit) + getAddressesUnspents addrs start limit = + runRocksDB (getAddressesUnspents addrs start limit) instance (MonadResource m, MonadUnliftIO m) => StoreStream (ReaderT BlockRead m) where - getOrphans = transPipe runLayered getOrphans - getAddressUnspents a x = transPipe runLayered $ getAddressUnspents a x - getAddressTxs a x = transPipe runLayered $ getAddressTxs a x - getAddressBalances = transPipe runLayered getAddressBalances - getUnspents = transPipe runLayered getUnspents + getOrphans = transPipe runRocksDB getOrphans + getAddressUnspents a x = transPipe runRocksDB $ getAddressUnspents a x + getAddressTxs a x = transPipe runRocksDB $ getAddressTxs a x + getAddressBalances = transPipe runRocksDB getAddressBalances + getUnspents = transPipe runRocksDB getUnspents -- | Run block store process. blockStore :: @@ -100,7 +149,7 @@ where ini = do net <- asks (blockConfNet . myConfig) - runImport (initDB net) >>= \case + runImport (initBest net) >>= \case Left e -> do $(logErrorS) "Block" $ "Could not initialize block store: " <> fromString (show e) @@ -154,14 +203,16 @@ upr net <- blockConfNet <$> asks myConfig lift (runImport (importBlock net b n)) >>= \case - Right () -> do + Right ths -> do l <- blockConfListener <$> asks myConfig $(logInfoS) "Block" $ "Best block indexed: " <> blockHashToHex (headerHash (blockHeader b)) <> " at height " <> cs (show (nodeHeight n)) - atomically $ l (StoreBestBlock (headerHash (blockHeader b))) + atomically $ do + mapM_ (l . StoreTxDeleted) ths + l (StoreBestBlock (headerHash (blockHeader b))) lift $ isSynced >>= \x -> when x (mempool p) Left e -> do $(logErrorS) "Block" $ @@ -207,10 +258,10 @@ -> [BlockHash] -> ReaderT BlockRead m () processNoBlocks p _bs = do - $(logErrorS) "Block" "We do not like peers that cannot find them blocks" - killPeer - (PeerMisbehaving "We do not like peers that cannot find them blocks") - p + $(logErrorS) "Block" (cs m) + killPeer (PeerMisbehaving m) p + where + m = "We do not like peers that cannot find them blocks" processTx :: (MonadUnliftIO m, MonadLoggerIO m) => Peer -> Tx -> BlockT m () processTx _p tx = @@ -227,12 +278,14 @@ $(logWarnS) "Block" $ "Error importing tx: " <> txHashToHex (txHash tx) <> ": " <> fromString (show e) - Right True -> do + Right (Just ths) -> do l <- blockConfListener <$> asks myConfig $(logDebugS) "Block" $ "Received mempool tx: " <> txHashToHex (txHash tx) - atomically $ l (StoreMempoolNew (txHash tx)) - Right False -> + atomically $ do + mapM_ (l . StoreTxDeleted) ths + l (StoreMempoolNew (txHash tx)) + Right Nothing -> $(logDebugS) "Block" $ "Not importing mempool tx: " <> txHashToHex (txHash tx) @@ -262,9 +315,23 @@ $(logDebugS) "Block" $ "Importing " <> cs (show (length orphans)) <> " orphan transactions" - forM_ orphans $ runImport . uncurry (importOrphan net) + ops <- + zip (map snd orphans) <$> + forM orphans (runImport . uncurry (importOrphan net)) + let tths = + [ (txHash tx, hs) + | (tx, emths) <- ops + , let Right (Just hs) = emths + ] + ihs = map fst tths + dhs = concatMap snd tths + l <- blockConfListener <$> asks myConfig + atomically $ do + mapM_ (l . StoreTxDeleted) dhs + mapM_ (l . StoreMempoolNew) ihs $(logDebugS) "Block" "Finished importing orphans" + processTxs :: (MonadUnliftIO m, MonadLoggerIO m) => Peer @@ -331,7 +398,13 @@ syncMe :: (MonadUnliftIO m, MonadLoggerIO m) => ReaderT BlockRead m () syncMe = void . runMaybeT $ do - rev + bths <- rev + l <- blockConfListener <$> asks myConfig + let dbs = map fst bths + ths = concatMap snd bths + atomically $ do + mapM_ (l . StoreTxDeleted) ths + mapM_ (l . StoreBlockReverted) dbs p <- gpr >>= \case Nothing -> do @@ -422,8 +495,9 @@ rev = do d <- headerHash . nodeHeader <$> dbn ch <- blockConfChain <$> asks myConfig - chainBlockMain d ch >>= \m -> - unless m $ do + chainBlockMain d ch >>= \case + True -> return [] + False -> do $(logErrorS) "Block" $ "Reverting best block " <> blockHashToHex d <> " as it is not in main chain..." @@ -435,7 +509,7 @@ "Could not revert best block: " <> fromString (show e) throwIO e - Right () -> rev + Right ths -> ((d, ths) :) <$> rev resetPeer :: (MonadLoggerIO m, MonadReader BlockRead m) => m () resetPeer = do diff --git a/src/Network/Haskoin/Store/Data.hs b/src/Network/Haskoin/Store/Data.hs deleted file mode 100644 --- a/src/Network/Haskoin/Store/Data.hs +++ /dev/null @@ -1,1192 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} - -module Network.Haskoin.Store.Data where - -import Conduit -import Control.Applicative -import Control.Arrow (first) -import Control.Monad -import Control.Monad.Trans.Maybe -import Data.Aeson as A -import qualified Data.Aeson.Encoding as A -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import Data.ByteString.Short (ShortByteString) -import qualified Data.ByteString.Short as B.Short -import Data.Default -import Data.Hashable -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as M -import qualified Data.IntMap as I -import Data.IntMap.Strict (IntMap) -import Data.Maybe -import Data.Serialize as S -import Data.String.Conversions -import qualified Data.Text.Encoding as T -import Data.Word -import Database.RocksDB (DB, ReadOptions) -import GHC.Generics -import Haskoin as H -import Network.Socket (SockAddr) -import Paths_haskoin_store as P -import UnliftIO - -encodeShort :: Serialize a => a -> ShortByteString -encodeShort = B.Short.toShort . S.encode - -decodeShort :: Serialize a => ShortByteString -> a -decodeShort bs = case S.decode (B.Short.fromShort bs) of - Left e -> error e - Right a -> a - -data BlockDB = - BlockDB - { blockDB :: !DB - , blockDBopts :: !ReadOptions - } - -data LayeredDB = - LayeredDB - { layeredDB :: !BlockDB - , layeredCache :: !(Maybe BlockDB) - } - -type UnixTime = Word64 -type BlockPos = Word32 - -newtype InitException = IncorrectVersion Word32 - deriving (Show, Read, Eq, Ord, Exception) - -class StoreRead m where - isInitialized :: m (Either InitException Bool) - getBestBlock :: m (Maybe BlockHash) - getBlocksAtHeight :: BlockHeight -> m [BlockHash] - getBlock :: BlockHash -> m (Maybe BlockData) - getTxData :: TxHash -> m (Maybe TxData) - getOrphanTx :: TxHash -> m (Maybe (UnixTime, Tx)) - getSpenders :: TxHash -> m (IntMap Spender) - getSpender :: OutPoint -> m (Maybe Spender) - getBalance :: Address -> m (Maybe Balance) - getUnspent :: OutPoint -> m (Maybe Unspent) - getMempool :: m [(UnixTime, TxHash)] - -class StoreWrite m where - setInit :: m () - setBest :: BlockHash -> m () - insertBlock :: BlockData -> m () - setBlocksAtHeight :: [BlockHash] -> BlockHeight -> m () - insertTx :: TxData -> m () - insertSpender :: OutPoint -> Spender -> m () - deleteSpender :: OutPoint -> m () - insertAddrTx :: Address -> BlockTx -> m () - deleteAddrTx :: Address -> BlockTx -> m () - insertAddrUnspent :: Address -> Unspent -> m () - deleteAddrUnspent :: Address -> Unspent -> m () - setMempool :: [(UnixTime, TxHash)] -> m () - insertOrphanTx :: Tx -> UnixTime -> m () - deleteOrphanTx :: TxHash -> m () - setBalance :: Balance -> m () - insertUnspent :: Unspent -> m () - deleteUnspent :: OutPoint -> m () - -getTransaction :: - (Monad m, StoreRead m) => TxHash -> m (Maybe Transaction) -getTransaction h = runMaybeT $ do - d <- MaybeT $ getTxData h - sm <- lift $ getSpenders h - return $ toTransaction d sm - -blockAtOrBefore :: (Monad m, StoreRead m) => UnixTime -> m (Maybe BlockData) -blockAtOrBefore q = runMaybeT $ do - a <- g 0 - b <- MaybeT getBestBlock >>= MaybeT . getBlock - f a b - where - f a b - | t b <= q = return b - | t a > q = mzero - | h b - h a == 1 = return a - | otherwise = do - let x = h a + (h b - h a) `div` 2 - m <- g x - if t m > q then f a m else f m b - g x = MaybeT (listToMaybe <$> getBlocksAtHeight x) >>= MaybeT . getBlock - h = blockDataHeight - t = fromIntegral . blockTimestamp . blockDataHeader - -class StoreStream m where - getOrphans :: ConduitT i (UnixTime, Tx) m () - getAddressUnspents :: Address -> Maybe BlockRef -> ConduitT i Unspent m () - getAddressTxs :: Address -> Maybe BlockRef -> ConduitT i BlockTx m () - getAddressBalances :: ConduitT i Balance m () - getUnspents :: ConduitT i Unspent m () - --- | Serialize such that ordering is inverted. -putUnixTime :: Word64 -> Put -putUnixTime w = putWord64be $ maxBound - w - -getUnixTime :: Get Word64 -getUnixTime = (maxBound -) <$> getWord64be - -class JsonSerial a where - jsonSerial :: Network -> a -> Encoding - jsonValue :: Network -> a -> Value - -instance JsonSerial a => JsonSerial [a] where - jsonSerial net = A.list (jsonSerial net) - jsonValue net = toJSON . map (jsonValue net) - -instance JsonSerial TxHash where - jsonSerial _ = toEncoding - jsonValue _ = toJSON - -instance BinSerial TxHash where - binSerial _ = put - binDeserial _ = get - -instance BinSerial Address where - binSerial net a = - case addrToString net a of - Nothing -> put B.empty - Just x -> put $ T.encodeUtf8 x - - binDeserial net = do - bs <- get - guard (not (B.null bs)) - t <- case T.decodeUtf8' bs of - Left _ -> mzero - Right v -> return v - case stringToAddr net t of - Nothing -> mzero - Just x -> return x - -class BinSerial a where - binSerial :: Network -> Putter a - binDeserial :: Network -> Get a - -instance BinSerial a => BinSerial [a] where - binSerial net = putListOf (binSerial net) - binDeserial net = getListOf (binDeserial net) - --- | Reference to a block where a transaction is stored. -data BlockRef - = BlockRef { blockRefHeight :: !BlockHeight - -- ^ block height in the chain - , blockRefPos :: !Word32 - -- ^ position of transaction within the block - } - | MemRef { memRefTime :: !UnixTime } - deriving (Show, Read, Eq, Ord, Generic, Hashable) - --- | Serialized entities will sort in reverse order. -instance Serialize BlockRef where - put MemRef {memRefTime = t} = do - putWord8 0x00 - putUnixTime t - put BlockRef {blockRefHeight = h, blockRefPos = p} = do - putWord8 0x01 - putWord32be (maxBound - h) - putWord32be (maxBound - p) - get = getmemref <|> getblockref - where - getmemref = do - guard . (== 0x00) =<< getWord8 - MemRef <$> getUnixTime - getblockref = do - guard . (== 0x01) =<< getWord8 - h <- (maxBound -) <$> getWord32be - p <- (maxBound -) <$> getWord32be - return BlockRef {blockRefHeight = h, blockRefPos = p} - -instance BinSerial BlockRef where - binSerial _ BlockRef {blockRefHeight = h, blockRefPos = p} = do - putWord8 0x00 - putWord32be h - putWord32be p - binSerial _ MemRef {memRefTime = t} = do - putWord8 0x01 - putWord64be t - - binDeserial _ = getWord8 >>= - \case - 0x00 -> BlockRef <$> getWord32be <*> getWord32be - 0x01 -> MemRef <$> getUnixTime - _ -> fail "Expected fst byte to be 0x00 or 0x01" - --- | JSON serialization for 'BlockRef'. -blockRefPairs :: A.KeyValue kv => BlockRef -> [kv] -blockRefPairs BlockRef {blockRefHeight = h, blockRefPos = p} = - ["height" .= h, "position" .= p] -blockRefPairs MemRef {memRefTime = t} = ["mempool" .= t] - -confirmed :: BlockRef -> Bool -confirmed BlockRef {} = True -confirmed MemRef {} = False - -instance ToJSON BlockRef where - toJSON = object . blockRefPairs - toEncoding = pairs . mconcat . blockRefPairs - --- | Transaction in relation to an address. -data BlockTx = BlockTx - { blockTxBlock :: !BlockRef - -- ^ block information - , blockTxHash :: !TxHash - -- ^ transaction hash - } deriving (Show, Eq, Ord, Generic, Serialize, Hashable) - --- | JSON serialization for 'AddressTx'. -blockTxPairs :: A.KeyValue kv => BlockTx -> [kv] -blockTxPairs btx = - [ "txid" .= blockTxHash btx - , "block" .= blockTxBlock btx - ] - -instance ToJSON BlockTx where - toJSON = object . blockTxPairs - toEncoding = pairs . mconcat . blockTxPairs - -instance JsonSerial BlockTx where - jsonSerial _ = toEncoding - jsonValue _ = toJSON - -instance BinSerial BlockTx where - binSerial net BlockTx { blockTxBlock = b, blockTxHash = h } = do - binSerial net b - binSerial net h - - binDeserial net = BlockTx <$> binDeserial net <*> binDeserial net - --- | Address balance information. -data Balance = Balance - { balanceAddress :: !Address - -- ^ address balance - , balanceAmount :: !Word64 - -- ^ confirmed balance - , balanceZero :: !Word64 - -- ^ unconfirmed balance - , balanceUnspentCount :: !Word64 - -- ^ number of unspent outputs - , balanceTxCount :: !Word64 - -- ^ number of transactions - , balanceTotalReceived :: !Word64 - -- ^ total amount from all outputs in this address - } deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable) - --- | JSON serialization for 'Balance'. -balancePairs :: A.KeyValue kv => Network -> Balance -> [kv] -balancePairs net ab = - [ "address" .= addrToJSON net (balanceAddress ab) - , "confirmed" .= balanceAmount ab - , "unconfirmed" .= balanceZero ab - , "utxo" .= balanceUnspentCount ab - , "txs" .= balanceTxCount ab - , "received" .= balanceTotalReceived ab - ] - -balanceToJSON :: Network -> Balance -> Value -balanceToJSON net = object . balancePairs net - -balanceToEncoding :: Network -> Balance -> Encoding -balanceToEncoding net = pairs . mconcat . balancePairs net - -instance JsonSerial Balance where - jsonSerial = balanceToEncoding - jsonValue = balanceToJSON - -instance BinSerial Balance where - binSerial net Balance { balanceAddress = a - , balanceAmount = v - , balanceZero = z - , balanceUnspentCount = u - , balanceTxCount = c - , balanceTotalReceived = t - } = do - binSerial net a - putWord64be v - putWord64be z - putWord64be u - putWord64be c - putWord64be t - - binDeserial net = - Balance <$> binDeserial net - <*> getWord64be - <*> getWord64be - <*> getWord64be - <*> getWord64be - <*> getWord64be - - --- | Unspent output. -data Unspent = Unspent - { unspentBlock :: !BlockRef - -- ^ block information for output - , unspentPoint :: !OutPoint - -- ^ txid and index where output located - , unspentAmount :: !Word64 - -- ^ value of output in satoshi - , unspentScript :: !ShortByteString - -- ^ pubkey (output) script - } deriving (Show, Eq, Ord, Generic, Hashable) - -instance Serialize Unspent where - put u = do - put $ unspentBlock u - put $ unspentPoint u - put $ unspentAmount u - put $ B.Short.length (unspentScript u) - putShortByteString $ unspentScript u - get = - Unspent <$> get <*> get <*> get <*> (getShortByteString =<< get) - -unspentPairs :: A.KeyValue kv => Network -> Unspent -> [kv] -unspentPairs net u = - [ "address" .= - eitherToMaybe - (addrToJSON net <$> - scriptToAddressBS (B.Short.fromShort (unspentScript u))) - , "block" .= unspentBlock u - , "txid" .= outPointHash (unspentPoint u) - , "index" .= outPointIndex (unspentPoint u) - , "pkscript" .= String (encodeHex (B.Short.fromShort (unspentScript u))) - , "value" .= unspentAmount u - ] - -unspentToJSON :: Network -> Unspent -> Value -unspentToJSON net = object . unspentPairs net - -unspentToEncoding :: Network -> Unspent -> Encoding -unspentToEncoding net = pairs . mconcat . unspentPairs net - -instance JsonSerial Unspent where - jsonSerial = unspentToEncoding - jsonValue = unspentToJSON - -instance BinSerial Unspent where - binSerial net Unspent { unspentBlock = b - , unspentPoint = p - , unspentAmount = v - , unspentScript = s - } = do - binSerial net b - put p - putWord64be v - put s - - binDeserial net = - Unspent - <$> binDeserial net - <*> get - <*> getWord64be - <*> get - --- | Database value for a block entry. -data BlockData = BlockData - { blockDataHeight :: !BlockHeight - -- ^ height of the block in the chain - , blockDataMainChain :: !Bool - -- ^ is this block in the main chain? - , blockDataWork :: !BlockWork - -- ^ accumulated work in that block - , blockDataHeader :: !BlockHeader - -- ^ block header - , blockDataSize :: !Word32 - -- ^ size of the block including witnesses - , blockDataWeight :: !Word32 - -- ^ weight of this block (for segwit networks) - , blockDataTxs :: ![TxHash] - -- ^ block transactions - , blockDataOutputs :: !Word64 - -- ^ sum of all transaction outputs - , blockDataFees :: !Word64 - -- ^ sum of all transaction fees - , blockDataSubsidy :: !Word64 - -- ^ block subsidy - } deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable) - --- | JSON serialization for 'BlockData'. -blockDataPairs :: A.KeyValue kv => Network -> BlockData -> [kv] -blockDataPairs net bv = - [ "hash" .= headerHash (blockDataHeader bv) - , "height" .= blockDataHeight bv - , "mainchain" .= blockDataMainChain bv - , "previous" .= prevBlock (blockDataHeader bv) - , "time" .= blockTimestamp (blockDataHeader bv) - , "version" .= blockVersion (blockDataHeader bv) - , "bits" .= blockBits (blockDataHeader bv) - , "nonce" .= bhNonce (blockDataHeader bv) - , "size" .= blockDataSize bv - , "tx" .= blockDataTxs bv - , "merkle" .= TxHash (merkleRoot (blockDataHeader bv)) - , "subsidy" .= blockDataSubsidy bv - , "fees" .= blockDataFees bv - , "outputs" .= blockDataOutputs bv - ] ++ ["weight" .= blockDataWeight bv | getSegWit net] - -blockDataToJSON :: Network -> BlockData -> Value -blockDataToJSON net = object . blockDataPairs net - -blockDataToEncoding :: Network -> BlockData -> Encoding -blockDataToEncoding net = pairs . mconcat . blockDataPairs net - -instance JsonSerial BlockData where - jsonSerial = blockDataToEncoding - jsonValue = blockDataToJSON - -instance BinSerial BlockData where - binSerial _ BlockData { blockDataHeight = e - , blockDataMainChain = m - , blockDataWork = w - , blockDataHeader = h - , blockDataSize = z - , blockDataWeight = g - , blockDataTxs = t - , blockDataOutputs = o - , blockDataFees = f - , blockDataSubsidy = y - } = do - put m - putWord32be e - put h - put w - putWord32be z - putWord32be g - putWord64be o - putWord64be f - putWord64be y - put t - - binDeserial _ = do - m <- get - e <- getWord32be - h <- get - w <- get - z <- getWord32be - g <- getWord32be - o <- getWord64be - f <- getWord64be - y <- getWord64be - t <- get - return $ BlockData e m w h z g t o f y - --- | Input information. -data StoreInput - = StoreCoinbase { inputPoint :: !OutPoint - -- ^ output being spent (should be null) - , inputSequence :: !Word32 - -- ^ sequence - , inputSigScript :: !ByteString - -- ^ input script data (not valid script) - , inputWitness :: !(Maybe WitnessStack) - -- ^ witness data for this input (only segwit) - } - -- ^ coinbase details - | StoreInput { inputPoint :: !OutPoint - -- ^ output being spent - , inputSequence :: !Word32 - -- ^ sequence - , inputSigScript :: !ByteString - -- ^ signature (input) script - , inputPkScript :: !ByteString - -- ^ pubkey (output) script from previous tx - , inputAmount :: !Word64 - -- ^ amount in satoshi being spent spent - , inputWitness :: !(Maybe WitnessStack) - -- ^ witness data for this input (only segwit) - } - -- ^ input details - deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable) - -isCoinbase :: StoreInput -> Bool -isCoinbase StoreCoinbase {} = True -isCoinbase StoreInput {} = False - -inputPairs :: A.KeyValue kv => Network -> StoreInput -> [kv] -inputPairs net StoreInput { inputPoint = OutPoint oph opi - , inputSequence = sq - , inputSigScript = ss - , inputPkScript = ps - , inputAmount = val - , inputWitness = wit - } = - [ "coinbase" .= False - , "txid" .= oph - , "output" .= opi - , "sigscript" .= String (encodeHex ss) - , "sequence" .= sq - , "pkscript" .= String (encodeHex ps) - , "value" .= val - , "address" .= eitherToMaybe (addrToJSON net <$> scriptToAddressBS ps) - ] ++ - ["witness" .= fmap (map encodeHex) wit | getSegWit net] - -inputPairs net StoreCoinbase { inputPoint = OutPoint oph opi - , inputSequence = sq - , inputSigScript = ss - , inputWitness = wit - } = - [ "coinbase" .= True - , "txid" .= oph - , "output" .= opi - , "sigscript" .= String (encodeHex ss) - , "sequence" .= sq - , "pkscript" .= Null - , "value" .= Null - , "address" .= Null - ] ++ - ["witness" .= fmap (map encodeHex) wit | getSegWit net] - -inputToJSON :: Network -> StoreInput -> Value -inputToJSON net = object . inputPairs net - -inputToEncoding :: Network -> StoreInput -> Encoding -inputToEncoding net = pairs . mconcat . inputPairs net - --- | Information about input spending output. -data Spender = Spender - { spenderHash :: !TxHash - -- ^ input transaction hash - , spenderIndex :: !Word32 - -- ^ input position in transaction - } deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable) - --- | JSON serialization for 'Spender'. -spenderPairs :: A.KeyValue kv => Spender -> [kv] -spenderPairs n = - ["txid" .= spenderHash n, "input" .= spenderIndex n] - -instance ToJSON Spender where - toJSON = object . spenderPairs - toEncoding = pairs . mconcat . spenderPairs - --- | Output information. -data StoreOutput = StoreOutput - { outputAmount :: !Word64 - -- ^ amount in satoshi - , outputScript :: !ByteString - -- ^ pubkey (output) script - , outputSpender :: !(Maybe Spender) - -- ^ input spending this transaction - } deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable) - -outputPairs :: A.KeyValue kv => Network -> StoreOutput -> [kv] -outputPairs net d = - [ "address" .= - eitherToMaybe (addrToJSON net <$> scriptToAddressBS (outputScript d)) - , "pkscript" .= String (encodeHex (outputScript d)) - , "value" .= outputAmount d - , "spent" .= isJust (outputSpender d) - ] ++ - ["spender" .= outputSpender d | isJust (outputSpender d)] - -outputToJSON :: Network -> StoreOutput -> Value -outputToJSON net = object . outputPairs net - -outputToEncoding :: Network -> StoreOutput -> Encoding -outputToEncoding net = pairs . mconcat . outputPairs net - -data Prev = Prev - { prevScript :: !ByteString - , prevAmount :: !Word64 - } deriving (Show, Eq, Ord, Generic, Hashable, Serialize) - -toInput :: TxIn -> Maybe Prev -> Maybe WitnessStack -> StoreInput -toInput i Nothing w = - StoreCoinbase - { inputPoint = prevOutput i - , inputSequence = txInSequence i - , inputSigScript = scriptInput i - , inputWitness = w - } -toInput i (Just p) w = - StoreInput - { inputPoint = prevOutput i - , inputSequence = txInSequence i - , inputSigScript = scriptInput i - , inputPkScript = prevScript p - , inputAmount = prevAmount p - , inputWitness = w - } - -toOutput :: TxOut -> Maybe Spender -> StoreOutput -toOutput o s = - StoreOutput - { outputAmount = outValue o - , outputScript = scriptOutput o - , outputSpender = s - } - -data TxData = TxData - { txDataBlock :: !BlockRef - , txData :: !Tx - , txDataPrevs :: !(IntMap Prev) - , txDataDeleted :: !Bool - , txDataRBF :: !Bool - , txDataTime :: !Word64 - } deriving (Show, Eq, Ord, Generic, Serialize) - -instance BinSerial TxData where - binSerial _ TxData - { txDataBlock = br - , txData = tx - , txDataPrevs = dp - , txDataDeleted = dd - , txDataRBF = dr - , txDataTime = t - } = do - put br - put tx - put dp - put dd - put dr - putWord64be t - - binDeserial _ = do br <- get - tx <- get - dp <- get - dd <- get - dr <- get - TxData br tx dp dd dr <$> getWord64be - -instance Serialize a => BinSerial (IntMap a) where - binSerial _ = put - binDeserial _ = get - -toTransaction :: TxData -> IntMap Spender -> Transaction -toTransaction t sm = - Transaction - { transactionBlock = txDataBlock t - , transactionVersion = txVersion (txData t) - , transactionLockTime = txLockTime (txData t) - , transactionInputs = ins - , transactionOutputs = outs - , transactionDeleted = txDataDeleted t - , transactionRBF = txDataRBF t - , transactionTime = txDataTime t - } - where - ws = - take (length (txIn (txData t))) $ - map Just (txWitness (txData t)) <> repeat Nothing - f n i = toInput i (I.lookup n (txDataPrevs t)) (ws !! n) - ins = zipWith f [0 ..] (txIn (txData t)) - g n o = toOutput o (I.lookup n sm) - outs = zipWith g [0 ..] (txOut (txData t)) - -fromTransaction :: Transaction -> (TxData, IntMap Spender) -fromTransaction t = (d, sm) - where - d = - TxData - { txDataBlock = transactionBlock t - , txData = transactionData t - , txDataPrevs = ps - , txDataDeleted = transactionDeleted t - , txDataRBF = transactionRBF t - , txDataTime = transactionTime t - } - f _ StoreCoinbase {} = Nothing - f n StoreInput {inputPkScript = s, inputAmount = v} = - Just (n, Prev {prevScript = s, prevAmount = v}) - ps = I.fromList . catMaybes $ zipWith f [0 ..] (transactionInputs t) - g _ StoreOutput {outputSpender = Nothing} = Nothing - g n StoreOutput {outputSpender = Just s} = Just (n, s) - sm = I.fromList . catMaybes $ zipWith g [0 ..] (transactionOutputs t) - --- | Detailed transaction information. -data Transaction = Transaction - { transactionBlock :: !BlockRef - -- ^ block information for this transaction - , transactionVersion :: !Word32 - -- ^ transaction version - , transactionLockTime :: !Word32 - -- ^ lock time - , transactionInputs :: ![StoreInput] - -- ^ transaction inputs - , transactionOutputs :: ![StoreOutput] - -- ^ transaction outputs - , transactionDeleted :: !Bool - -- ^ this transaction has been deleted and is no longer valid - , transactionRBF :: !Bool - -- ^ this transaction can be replaced in the mempool - , transactionTime :: !Word64 - -- ^ time the transaction was first seen or time of block - } deriving (Show, Eq, Ord, Generic, Hashable, Serialize) - -transactionData :: Transaction -> Tx -transactionData t = - Tx - { txVersion = transactionVersion t - , txIn = map i (transactionInputs t) - , txOut = map o (transactionOutputs t) - , txWitness = mapMaybe inputWitness (transactionInputs t) - , txLockTime = transactionLockTime t - } - where - i StoreCoinbase {inputPoint = p, inputSequence = q, inputSigScript = s} = - TxIn {prevOutput = p, scriptInput = s, txInSequence = q} - i StoreInput {inputPoint = p, inputSequence = q, inputSigScript = s} = - TxIn {prevOutput = p, scriptInput = s, txInSequence = q} - o StoreOutput {outputAmount = v, outputScript = s} = - TxOut {outValue = v, scriptOutput = s} - --- | JSON serialization for 'Transaction'. -transactionPairs :: A.KeyValue kv => Network -> Transaction -> [kv] -transactionPairs net dtx = - [ "txid" .= txHash (transactionData dtx) - , "size" .= B.length (S.encode (transactionData dtx)) - , "version" .= transactionVersion dtx - , "locktime" .= transactionLockTime dtx - , "fee" .= - if all isCoinbase (transactionInputs dtx) - then 0 - else sum (map inputAmount (transactionInputs dtx)) - - sum (map outputAmount (transactionOutputs dtx)) - , "inputs" .= map (object . inputPairs net) (transactionInputs dtx) - , "outputs" .= map (object . outputPairs net) (transactionOutputs dtx) - , "block" .= transactionBlock dtx - , "deleted" .= transactionDeleted dtx - , "time" .= transactionTime dtx - ] ++ - ["rbf" .= transactionRBF dtx | getReplaceByFee net] ++ - ["weight" .= w | getSegWit net] - where - w = let b = B.length $ S.encode (transactionData dtx) {txWitness = []} - x = B.length $ S.encode (transactionData dtx) - in b * 3 + x - -transactionToJSON :: Network -> Transaction -> Value -transactionToJSON net = object . transactionPairs net - -transactionToEncoding :: Network -> Transaction -> Encoding -transactionToEncoding net = pairs . mconcat . transactionPairs net - -instance JsonSerial Transaction where - jsonSerial = transactionToEncoding - jsonValue = transactionToJSON - -instance BinSerial Transaction where - binSerial net tx = do - let (txd, sp) = fromTransaction tx - binSerial net txd - binSerial net sp - - binDeserial net = do - txd <- binDeserial net - sp <- binDeserial net - return $ toTransaction txd sp - -instance JsonSerial Tx where - jsonSerial _ = toEncoding - jsonValue _ = toJSON - -instance BinSerial Tx where - binSerial _ = put - binDeserial _ = get - -instance JsonSerial Block where - jsonSerial _ = toEncoding - jsonValue _ = toJSON - -instance BinSerial Block where - binSerial _ = put - binDeserial _ = get - --- | Information about a connected peer. -data PeerInformation - = PeerInformation { peerUserAgent :: !ByteString - -- ^ user agent string - , peerAddress :: !SockAddr - -- ^ network address - , peerVersion :: !Word32 - -- ^ version number - , peerServices :: !Word64 - -- ^ services field - , peerRelay :: !Bool - -- ^ will relay transactions - } - deriving (Show, Eq, Ord, Generic) - --- | JSON serialization for 'PeerInformation'. -peerInformationPairs :: A.KeyValue kv => PeerInformation -> [kv] -peerInformationPairs p = - [ "useragent" .= String (cs (peerUserAgent p)) - , "address" .= String (cs (show (peerAddress p))) - , "version" .= peerVersion p - , "services" .= String (encodeHex (S.encode (peerServices p))) - , "relay" .= peerRelay p - ] - -instance ToJSON PeerInformation where - toJSON = object . peerInformationPairs - toEncoding = pairs . mconcat . peerInformationPairs - -instance JsonSerial PeerInformation where - jsonSerial _ = toEncoding - jsonValue _ = toJSON - -instance BinSerial PeerInformation where - binSerial _ PeerInformation { peerUserAgent = u - , peerAddress = a - , peerVersion = v - , peerServices = s - , peerRelay = b - } = do - putWord32be v - put b - put u - put $ NetworkAddress s a - - binDeserial _ = do - v <- getWord32be - b <- get - u <- get - NetworkAddress { naServices = s, naAddress = a } <- get - return $ PeerInformation u a v s b - --- | Address balances for an extended public key. -data XPubBal = XPubBal - { xPubBalPath :: ![KeyIndex] - , xPubBal :: !Balance - } deriving (Show, Eq, Generic) - --- | JSON serialization for 'XPubBal'. -xPubBalPairs :: A.KeyValue kv => Network -> XPubBal -> [kv] -xPubBalPairs net XPubBal {xPubBalPath = p, xPubBal = b} = - [ "path" .= p - , "balance" .= balanceToJSON net b - ] - -xPubBalToJSON :: Network -> XPubBal -> Value -xPubBalToJSON net = object . xPubBalPairs net - -xPubBalToEncoding :: Network -> XPubBal -> Encoding -xPubBalToEncoding net = pairs . mconcat . xPubBalPairs net - -instance JsonSerial XPubBal where - jsonSerial = xPubBalToEncoding - jsonValue = xPubBalToJSON - -instance BinSerial XPubBal where - binSerial net XPubBal {xPubBalPath = p, xPubBal = b} = do - put p - binSerial net b - binDeserial net = do - p <- get - b <- binDeserial net - return $ XPubBal p b - --- | Unspent transaction for extended public key. -data XPubUnspent = XPubUnspent - { xPubUnspentPath :: ![KeyIndex] - , xPubUnspent :: !Unspent - } deriving (Show, Eq, Generic) - --- | JSON serialization for 'XPubUnspent'. -xPubUnspentPairs :: A.KeyValue kv => Network -> XPubUnspent -> [kv] -xPubUnspentPairs net XPubUnspent { xPubUnspentPath = p - , xPubUnspent = u - } = - [ "path" .= p - , "unspent" .= unspentToJSON net u - ] - -xPubUnspentToJSON :: Network -> XPubUnspent -> Value -xPubUnspentToJSON net = object . xPubUnspentPairs net - -xPubUnspentToEncoding :: Network -> XPubUnspent -> Encoding -xPubUnspentToEncoding net = pairs . mconcat . xPubUnspentPairs net - -instance JsonSerial XPubUnspent where - jsonSerial = xPubUnspentToEncoding - jsonValue = xPubUnspentToJSON - -instance BinSerial XPubUnspent where - binSerial net XPubUnspent {xPubUnspentPath = p, xPubUnspent = u} = do - put p - binSerial net u - - binDeserial net = do - p <- get - u <- binDeserial net - return $ XPubUnspent p u - -data XPubSummary = - XPubSummary - { xPubSummaryConfirmed :: !Word64 - , xPubSummaryZero :: !Word64 - , xPubSummaryReceived :: !Word64 - , xPubUnspentCount :: !Word64 - , xPubExternalIndex :: !Word32 - , xPubChangeIndex :: !Word32 - , xPubSummaryPaths :: !(HashMap Address [KeyIndex]) - } - deriving (Eq, Show, Generic) - -xPubSummaryPairs :: A.KeyValue kv => Network -> XPubSummary -> [kv] -xPubSummaryPairs net XPubSummary { xPubSummaryConfirmed = c - , xPubSummaryZero = z - , xPubSummaryReceived = r - , xPubUnspentCount = u - , xPubSummaryPaths = ps - , xPubExternalIndex = ext - , xPubChangeIndex = ch - } = - [ "balance" .= - object - [ "confirmed" .= c - , "unconfirmed" .= z - , "received" .= r - , "utxo" .= u - ] - , "indices" .= object ["change" .= ch, "external" .= ext] - , "paths" .= object (mapMaybe (uncurry f) (M.toList ps)) - ] - where - f a p = (.= p) <$> addrToString net a - -xPubSummaryToJSON :: Network -> XPubSummary -> Value -xPubSummaryToJSON net = object . xPubSummaryPairs net - -xPubSummaryToEncoding :: Network -> XPubSummary -> Encoding -xPubSummaryToEncoding net = pairs . mconcat . xPubSummaryPairs net - -instance JsonSerial XPubSummary where - jsonSerial = xPubSummaryToEncoding - jsonValue = xPubSummaryToJSON - -instance BinSerial XPubSummary where - binSerial net XPubSummary { xPubSummaryConfirmed = c - , xPubSummaryZero = z - , xPubSummaryReceived = r - , xPubUnspentCount = u - , xPubExternalIndex = ext - , xPubChangeIndex = ch - , xPubSummaryPaths = ps - } = do - put c - put z - put r - put u - put ext - put ch - put (map (first (runPut . binSerial net)) (M.toList ps)) - binDeserial net = do - c <- get - z <- get - r <- get - u <- get - ext <- get - ch <- get - ps <- get - let xs = map (first (runGet (binDeserial net))) ps - ys <- - forM xs $ \(k, v) -> - case k of - Right a -> return (a, v) - Left _ -> mzero - return $ XPubSummary c z r u ext ch (M.fromList ys) - -data HealthCheck = - HealthCheck - { healthHeaderBest :: !(Maybe BlockHash) - , healthHeaderHeight :: !(Maybe BlockHeight) - , healthBlockBest :: !(Maybe BlockHash) - , healthBlockHeight :: !(Maybe BlockHeight) - , healthPeers :: !(Maybe Int) - , healthNetwork :: !String - , healthOK :: !Bool - , healthSynced :: !Bool - , healthLastBlock :: !(Maybe Word64) - , healthLastTx :: !(Maybe Word64) - } - deriving (Show, Eq, Generic, Serialize) - -healthCheckPairs :: A.KeyValue kv => HealthCheck -> [kv] -healthCheckPairs h = - [ "headers" .= - object ["hash" .= healthHeaderBest h, "height" .= healthHeaderHeight h] - , "blocks" .= - object ["hash" .= healthBlockBest h, "height" .= healthBlockHeight h] - , "peers" .= healthPeers h - , "net" .= healthNetwork h - , "ok" .= healthOK h - , "synced" .= healthSynced h - , "version" .= P.version - , "lastblock" .= healthLastBlock h - , "lasttx" .= healthLastTx h - ] - -instance ToJSON HealthCheck where - toJSON = object . healthCheckPairs - toEncoding = pairs . mconcat . healthCheckPairs - -instance JsonSerial HealthCheck where - jsonSerial _ = toEncoding - jsonValue _ = toJSON - -instance BinSerial HealthCheck where - binSerial _ HealthCheck { healthHeaderBest = hbest - , healthHeaderHeight = hheight - , healthBlockBest = bbest - , healthBlockHeight = bheight - , healthPeers = peers - , healthNetwork = net - , healthOK = ok - , healthSynced = synced - , healthLastBlock = lbk - , healthLastTx = ltx - } = do - put hbest - put hheight - put bbest - put bheight - put peers - put net - put ok - put synced - put lbk - put ltx - binDeserial _ = - HealthCheck <$> get <*> get <*> get <*> get <*> get <*> get <*> get <*> - get <*> - get <*> - get - -data Event - = EventBlock BlockHash - | EventTx TxHash - deriving (Show, Eq, Generic) - -instance ToJSON Event where - toJSON (EventTx h) = object ["type" .= String "tx", "id" .= h] - toJSON (EventBlock h) = object ["type" .= String "block", "id" .= h] - -instance JsonSerial Event where - jsonSerial _ = toEncoding - jsonValue _ = toJSON - -instance BinSerial Event where - binSerial _ (EventBlock bh) = putWord8 0x00 >> put bh - binSerial _ (EventTx th) = putWord8 0x01 >> put th - - binDeserial _ = getWord8 >>= - \case - 0x00-> EventBlock <$> get - 0x01 -> EventTx <$> get - _ -> fail "Expected fst byte to be 0x00 or 0x01" - - -newtype TxAfterHeight = TxAfterHeight - { txAfterHeight :: Maybe Bool - } deriving (Show, Eq, Generic) - -instance ToJSON TxAfterHeight where - toJSON (TxAfterHeight b) = object ["result" .= b] - -instance JsonSerial TxAfterHeight where - jsonSerial _ = toEncoding - jsonValue _ = toJSON - -instance BinSerial TxAfterHeight where - binSerial _ TxAfterHeight {txAfterHeight = a} = put a - binDeserial _ = TxAfterHeight <$> get - -newtype TxId = TxId TxHash deriving (Show, Eq, Generic) - -instance ToJSON TxId where - toJSON (TxId h) = object ["txid" .= h] - -instance JsonSerial TxId where - jsonSerial _ = toEncoding - jsonValue _ = toJSON - -instance BinSerial TxId where - binSerial _ (TxId th) = put th - binDeserial _ = TxId <$> get - -data BalVal = BalVal - { balValAmount :: !Word64 - , balValZero :: !Word64 - , balValUnspentCount :: !Word64 - , balValTxCount :: !Word64 - , balValTotalReceived :: !Word64 - } deriving (Show, Read, Eq, Ord, Generic, Hashable, Serialize) - -balValToBalance :: Address -> BalVal -> Balance -balValToBalance a BalVal { balValAmount = v - , balValZero = z - , balValUnspentCount = u - , balValTxCount = t - , balValTotalReceived = r - } = - Balance - { balanceAddress = a - , balanceAmount = v - , balanceZero = z - , balanceUnspentCount = u - , balanceTxCount = t - , balanceTotalReceived = r - } - -balanceToBalVal :: Balance -> (Address, BalVal) -balanceToBalVal Balance { balanceAddress = a - , balanceAmount = v - , balanceZero = z - , balanceUnspentCount = u - , balanceTxCount = t - , balanceTotalReceived = r - } = - ( a - , BalVal - { balValAmount = v - , balValZero = z - , balValUnspentCount = u - , balValTxCount = t - , balValTotalReceived = r - }) - --- | Default balance for an address. -instance Default BalVal where - def = - BalVal - { balValAmount = 0 - , balValZero = 0 - , balValUnspentCount = 0 - , balValTxCount = 0 - , balValTotalReceived = 0 - } - -data UnspentVal = UnspentVal - { unspentValBlock :: !BlockRef - , unspentValAmount :: !Word64 - , unspentValScript :: !ShortByteString - } deriving (Show, Read, Eq, Ord, Generic, Hashable, Serialize) - -unspentToUnspentVal :: Unspent -> (OutPoint, UnspentVal) -unspentToUnspentVal Unspent { unspentBlock = b - , unspentPoint = p - , unspentAmount = v - , unspentScript = s - } = - ( p - , UnspentVal - {unspentValBlock = b, unspentValAmount = v, unspentValScript = s}) - -unspentValToUnspent :: OutPoint -> UnspentVal -> Unspent -unspentValToUnspent p UnspentVal { unspentValBlock = b - , unspentValAmount = v - , unspentValScript = s - } = - Unspent - { unspentBlock = b - , unspentPoint = p - , unspentAmount = v - , unspentScript = s - } diff --git a/src/Network/Haskoin/Store/Data/Cached.hs b/src/Network/Haskoin/Store/Data/Cached.hs deleted file mode 100644 --- a/src/Network/Haskoin/Store/Data/Cached.hs +++ /dev/null @@ -1,189 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -module Network.Haskoin.Store.Data.Cached where - -import Conduit -import Control.Monad.Reader (ReaderT) -import qualified Control.Monad.Reader as R -import qualified Data.ByteString as B -import Data.IntMap.Strict (IntMap) -import Data.Serialize (Serialize, encode) -import Database.RocksDB as R -import Haskoin -import Network.Haskoin.Store.Data -import Network.Haskoin.Store.Data.KeyValue -import Network.Haskoin.Store.Data.RocksDB -import UnliftIO - -newLayeredDB :: MonadUnliftIO m => BlockDB -> Maybe BlockDB -> m LayeredDB -newLayeredDB blocks Nothing = - return LayeredDB {layeredDB = blocks, layeredCache = Nothing} -newLayeredDB blocks (Just cache) = do - bulkCopy opts db cdb BalKeyS - bulkCopy opts db cdb UnspentKeyB - bulkCopy opts db cdb MemKey - bulkCopy opts db cdb AddrTxKeyS - return LayeredDB {layeredDB = blocks, layeredCache = Just cache} - where - BlockDB {blockDBopts = opts, blockDB = db} = blocks - BlockDB {blockDB = cdb} = cache - -withLayeredDB :: LayeredDB -> ReaderT LayeredDB m a -> m a -withLayeredDB = flip R.runReaderT - -isInitializedC :: MonadIO m => LayeredDB -> m (Either InitException Bool) -isInitializedC LayeredDB {layeredDB = db} = isInitializedDB db - -getBestBlockC :: MonadIO m => LayeredDB -> m (Maybe BlockHash) -getBestBlockC LayeredDB {layeredDB = db} = getBestBlockDB db - -getBlocksAtHeightC :: MonadIO m => BlockHeight -> LayeredDB -> m [BlockHash] -getBlocksAtHeightC h LayeredDB {layeredDB = db} = getBlocksAtHeightDB h db - -getBlockC :: MonadIO m => BlockHash -> LayeredDB -> m (Maybe BlockData) -getBlockC bh LayeredDB {layeredDB = db} = getBlockDB bh db - -getTxDataC :: MonadIO m => TxHash -> LayeredDB -> m (Maybe TxData) -getTxDataC th LayeredDB {layeredDB = db} = getTxDataDB th db - -getOrphanTxC :: MonadIO m => TxHash -> LayeredDB -> m (Maybe (UnixTime, Tx)) -getOrphanTxC h LayeredDB {layeredDB = db} = getOrphanTxDB h db - -getSpenderC :: MonadIO m => OutPoint -> LayeredDB -> m (Maybe Spender) -getSpenderC p LayeredDB {layeredDB = db} = getSpenderDB p db - -getSpendersC :: MonadIO m => TxHash -> LayeredDB -> m (IntMap Spender) -getSpendersC t LayeredDB {layeredDB = db} = getSpendersDB t db - -getBalanceC :: MonadIO m => Address -> LayeredDB -> m (Maybe Balance) -getBalanceC a LayeredDB {layeredCache = Just db} = getBalanceDB a db -getBalanceC a LayeredDB {layeredDB = db} = getBalanceDB a db - -getUnspentC :: MonadIO m => OutPoint -> LayeredDB -> m (Maybe Unspent) -getUnspentC op LayeredDB {layeredCache = Just db} = getUnspentDB op db -getUnspentC op LayeredDB {layeredDB = db} = getUnspentDB op db - -getUnspentsC :: - (MonadResource m, MonadIO m) => LayeredDB -> ConduitT i Unspent m () -getUnspentsC LayeredDB {layeredDB = db} = getUnspentsDB db - -getMempoolC :: MonadIO m => LayeredDB -> m [(UnixTime, TxHash)] -getMempoolC LayeredDB {layeredCache = Just db} = getMempoolDB db -getMempoolC LayeredDB {layeredDB = db} = getMempoolDB db - -getOrphansC :: - (MonadUnliftIO m, MonadResource m) - => LayeredDB - -> ConduitT i (UnixTime, Tx) m () -getOrphansC LayeredDB {layeredDB = db} = getOrphansDB db - -getAddressBalancesC :: - (MonadUnliftIO m, MonadResource m) - => LayeredDB - -> ConduitT i Balance m () -getAddressBalancesC LayeredDB {layeredDB = db} = getAddressBalancesDB db - -getAddressUnspentsC :: - (MonadUnliftIO m, MonadResource m) - => Address - -> Maybe BlockRef - -> LayeredDB - -> ConduitT i Unspent m () -getAddressUnspentsC addr mbr LayeredDB {layeredDB = db} = - getAddressUnspentsDB addr mbr db - -getAddressTxsC :: - (MonadUnliftIO m, MonadResource m) - => Address - -> Maybe BlockRef - -> LayeredDB - -> ConduitT i BlockTx m () -getAddressTxsC addr mbr LayeredDB {layeredCache = Just db} = - getAddressTxsDB addr mbr db -getAddressTxsC addr mbr LayeredDB {layeredDB = db} = - getAddressTxsDB addr mbr db - -bulkCopy :: - (Serialize k, MonadUnliftIO m) => ReadOptions -> DB -> DB -> k -> m () -bulkCopy opts db cdb b = - runResourceT $ do - ch <- newTBQueueIO 1000000 - withAsync (iter ch) $ \_ -> write_batch ch [] (0 :: Int) - where - iter ch = - withIterator db opts $ \it -> do - iterSeek it (encode b) - recurse it ch - write_batch ch acc l - | l >= 10000 = do - write cdb defaultWriteOptions acc - write_batch ch [] 0 - | otherwise = - atomically (readTBQueue ch) >>= \case - Just (k, v) -> write_batch ch (Put k v : acc) (l + 1) - Nothing -> write cdb defaultWriteOptions acc - recurse it ch = - iterEntry it >>= \case - Nothing -> atomically $ writeTBQueue ch Nothing - Just (k, v) -> - let pfx = B.take (B.length (encode b)) k - in if pfx == encode b - then do - atomically . writeTBQueue ch $ Just (k, v) - iterNext it - recurse it ch - else atomically $ writeTBQueue ch Nothing - -instance (MonadUnliftIO m, MonadResource m) => - StoreStream (ReaderT LayeredDB m) where - getOrphans = do - c <- R.ask - getOrphansC c - getAddressUnspents a x = do - c <- R.ask - getAddressUnspentsC a x c - getAddressTxs a x = do - c <- R.ask - getAddressTxsC a x c - getAddressBalances = do - c <- R.ask - getAddressBalancesC c - getUnspents = do - c <- R.ask - getUnspentsC c - -instance MonadIO m => StoreRead (ReaderT LayeredDB m) where - isInitialized = do - c <- R.ask - isInitializedC c - getBestBlock = do - c <- R.ask - getBestBlockC c - getBlocksAtHeight h = do - c <- R.ask - getBlocksAtHeightC h c - getBlock b = do - c <- R.ask - getBlockC b c - getTxData t = do - c <- R.ask - getTxDataC t c - getSpender p = do - c <- R.ask - getSpenderC p c - getSpenders t = do - c <- R.ask - getSpendersC t c - getOrphanTx h = do - c <- R.ask - getOrphanTxC h c - getUnspent a = do - c <- R.ask - getUnspentC a c - getBalance a = do - c <- R.ask - getBalanceC a c - getMempool = do - c <- R.ask - getMempoolC c diff --git a/src/Network/Haskoin/Store/Data/ImportDB.hs b/src/Network/Haskoin/Store/Data/ImportDB.hs --- a/src/Network/Haskoin/Store/Data/ImportDB.hs +++ b/src/Network/Haskoin/Store/Data/ImportDB.hs @@ -3,61 +3,72 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} module Network.Haskoin.Store.Data.ImportDB where -import Conduit -import Control.Applicative -import Control.Monad.Except -import Control.Monad.Logger +import Control.Applicative ((<|>)) +import Control.Monad (join) +import Control.Monad.Except (MonadError) +import Control.Monad.Logger (MonadLoggerIO, logDebugS) import Control.Monad.Reader (ReaderT) import qualified Control.Monad.Reader as R -import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as M import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as I -import Data.List -import Data.Maybe -import Database.RocksDB as R -import Database.RocksDB.Query as R -import Haskoin -import Network.Haskoin.Store.Data -import Network.Haskoin.Store.Data.Cached -import Network.Haskoin.Store.Data.KeyValue -import Network.Haskoin.Store.Data.Memory -import Network.Haskoin.Store.Data.RocksDB -import UnliftIO +import Data.List (nub) +import Data.Maybe (fromJust, isJust, + maybeToList) +import Database.RocksDB (BatchOp) +import Database.RocksDB.Query (deleteOp, insertOp, + writeBatch) +import Haskoin (Address, BlockHash, + BlockHeight, + OutPoint (..), Tx, TxHash) +import Network.Haskoin.Store.Data.KeyValue (AddrOutKey (..), + AddrTxKey (..), + BalKey (..), BestKey (..), + BlockKey (..), + HeightKey (..), + MemKey (..), + OrphanKey (..), OutVal, + SpenderKey (..), + TxKey (..), + UnspentKey (..)) +import Network.Haskoin.Store.Data.Memory (BlockMem (..), + emptyBlockMem, + getMempoolH, getOrphanTxH, + getSpenderH, getSpendersH, + getUnspentH, withBlockMem) +import Network.Haskoin.Store.Data.RocksDB (withRocksDB) +import Network.Haskoin.Store.Data.Types (BalVal, Balance, + BlockDB (..), BlockData, + BlockRef, BlockTx (..), + Spender, StoreRead (..), + StoreWrite (..), TxData, + UnixTime, Unspent, + UnspentVal) +import UnliftIO (MonadIO, TVar, newTVarIO, + readTVarIO) data ImportDB = ImportDB - { importLayeredDB :: !LayeredDB - , importHashMap :: !(TVar BlockMem) + { importDB :: !BlockDB + , importHashMap :: !(TVar BlockMem) } runImportDB :: (MonadError e m, MonadLoggerIO m) - => LayeredDB + => BlockDB -> ReaderT ImportDB m a -> m a -runImportDB ldb f = do +runImportDB bdb@BlockDB {blockDB = db} f = do hm <- newTVarIO emptyBlockMem - x <- R.runReaderT f ImportDB {importLayeredDB = ldb, importHashMap = hm} + x <- R.runReaderT f ImportDB {importDB = bdb, importHashMap = hm} ops <- hashMapOps <$> readTVarIO hm - $(logDebugS) "ImportDB" "Committing changes to database and cache..." - case cache of - Just BlockDB {blockDB = cdb} -> do - cops <- cacheMapOps <$> readTVarIO hm - let del Put {} = False - del Del {} = True - (delcops, addcops) = partition del cops - writeBatch cdb delcops - writeBatch db ops - writeBatch cdb addcops - Nothing -> writeBatch db ops - $(logDebugS) "ImportDB" "Finished committing changes to database and cache" + $(logDebugS) "ImportDB" "Committing changes to database" + writeBatch db ops + $(logDebugS) "ImportDB" "Finished committing changes to database" return x - where - LayeredDB {layeredDB = BlockDB {blockDB = db}, layeredCache = cache} = ldb hashMapOps :: BlockMem -> [BatchOp] hashMapOps db = @@ -168,17 +179,6 @@ g h i (Just u) = insertOp (UnspentKey (OutPoint h (fromIntegral i))) u g h i Nothing = deleteOp (UnspentKey (OutPoint h (fromIntegral i))) -isInitializedI :: MonadIO m => ImportDB -> m (Either InitException Bool) -isInitializedI ImportDB {importLayeredDB = ldb} = - withLayeredDB ldb isInitialized - -setInitI :: MonadIO m => ImportDB -> m () -setInitI ImportDB { importLayeredDB = LayeredDB {layeredDB = BlockDB {blockDB = db}} - , importHashMap = hm - } = do - withBlockMem hm setInit - setInitDB db - setBestI :: MonadIO m => BlockHash -> ImportDB -> m () setBestI bh ImportDB {importHashMap = hm} = withBlockMem hm $ setBest bh @@ -231,70 +231,70 @@ withBlockMem hm $ deleteOrphanTx t getBestBlockI :: MonadIO m => ImportDB -> m (Maybe BlockHash) -getBestBlockI ImportDB {importHashMap = hm, importLayeredDB = db} = +getBestBlockI ImportDB {importHashMap = hm, importDB = db} = runMaybeT $ MaybeT f <|> MaybeT g where f = withBlockMem hm getBestBlock - g = withLayeredDB db getBestBlock + g = withRocksDB db getBestBlock getBlocksAtHeightI :: MonadIO m => BlockHeight -> ImportDB -> m [BlockHash] -getBlocksAtHeightI bh ImportDB {importHashMap = hm, importLayeredDB = db} = do +getBlocksAtHeightI bh ImportDB {importHashMap = hm, importDB = db} = do xs <- withBlockMem hm $ getBlocksAtHeight bh - ys <- withLayeredDB db $ getBlocksAtHeight bh + ys <- withRocksDB db $ getBlocksAtHeight bh return . nub $ xs <> ys getBlockI :: MonadIO m => BlockHash -> ImportDB -> m (Maybe BlockData) -getBlockI bh ImportDB {importLayeredDB = db, importHashMap = hm} = +getBlockI bh ImportDB {importDB = db, importHashMap = hm} = runMaybeT $ MaybeT f <|> MaybeT g where f = withBlockMem hm $ getBlock bh - g = withLayeredDB db $ getBlock bh + g = withRocksDB db $ getBlock bh getTxDataI :: MonadIO m => TxHash -> ImportDB -> m (Maybe TxData) -getTxDataI th ImportDB {importLayeredDB = db, importHashMap = hm} = +getTxDataI th ImportDB {importDB = db, importHashMap = hm} = runMaybeT $ MaybeT f <|> MaybeT g where f = withBlockMem hm $ getTxData th - g = withLayeredDB db $ getTxData th + g = withRocksDB db $ getTxData th getOrphanTxI :: MonadIO m => TxHash -> ImportDB -> m (Maybe (UnixTime, Tx)) -getOrphanTxI h ImportDB {importLayeredDB = db, importHashMap = hm} = +getOrphanTxI h ImportDB {importDB = db, importHashMap = hm} = fmap join . runMaybeT $ MaybeT f <|> MaybeT g where f = getOrphanTxH h <$> readTVarIO hm - g = Just <$> withLayeredDB db (getOrphanTx h) + g = Just <$> withRocksDB db (getOrphanTx h) getSpenderI :: MonadIO m => OutPoint -> ImportDB -> m (Maybe Spender) -getSpenderI op ImportDB {importLayeredDB = db, importHashMap = hm} = +getSpenderI op ImportDB {importDB = db, importHashMap = hm} = fmap join . runMaybeT $ MaybeT f <|> MaybeT g where f = getSpenderH op <$> readTVarIO hm - g = Just <$> withLayeredDB db (getSpender op) + g = Just <$> withRocksDB db (getSpender op) getSpendersI :: MonadIO m => TxHash -> ImportDB -> m (IntMap Spender) -getSpendersI t ImportDB {importLayeredDB = db, importHashMap = hm} = do +getSpendersI t ImportDB {importDB = db, importHashMap = hm} = do hsm <- getSpendersH t <$> readTVarIO hm - dsm <- I.map Just <$> withLayeredDB db (getSpenders t) + dsm <- I.map Just <$> withRocksDB db (getSpenders t) return . I.map fromJust . I.filter isJust $ hsm <> dsm getBalanceI :: MonadIO m => Address -> ImportDB -> m (Maybe Balance) -getBalanceI a ImportDB {importLayeredDB = db, importHashMap = hm} = +getBalanceI a ImportDB {importDB = db, importHashMap = hm} = runMaybeT $ MaybeT f <|> MaybeT g where f = withBlockMem hm $ getBalance a - g = withLayeredDB db $ getBalance a + g = withRocksDB db $ getBalance a setBalanceI :: MonadIO m => Balance -> ImportDB -> m () setBalanceI b ImportDB {importHashMap = hm} = withBlockMem hm $ setBalance b getUnspentI :: MonadIO m => OutPoint -> ImportDB -> m (Maybe Unspent) -getUnspentI op ImportDB {importLayeredDB = db, importHashMap = hm} = +getUnspentI op ImportDB {importDB = db, importHashMap = hm} = fmap join . runMaybeT $ MaybeT f <|> MaybeT g where f = getUnspentH op <$> readTVarIO hm - g = Just <$> withLayeredDB db (getUnspent op) + g = Just <$> withRocksDB db (getUnspent op) insertUnspentI :: MonadIO m => Unspent -> ImportDB -> m () insertUnspentI u ImportDB {importHashMap = hm} = @@ -308,13 +308,12 @@ MonadIO m => ImportDB -> m [(UnixTime, TxHash)] -getMempoolI ImportDB {importHashMap = hm, importLayeredDB = db} = +getMempoolI ImportDB {importHashMap = hm, importDB = db} = getMempoolH <$> readTVarIO hm >>= \case - Just xs -> return xs - Nothing -> withLayeredDB db getMempool + Just xs -> return xs + Nothing -> withRocksDB db getMempool instance MonadIO m => StoreRead (ReaderT ImportDB m) where - isInitialized = R.ask >>= isInitializedI getBestBlock = R.ask >>= getBestBlockI getBlocksAtHeight h = R.ask >>= getBlocksAtHeightI h getBlock b = R.ask >>= getBlockI b @@ -325,9 +324,10 @@ getUnspent a = R.ask >>= getUnspentI a getBalance a = R.ask >>= getBalanceI a getMempool = R.ask >>= getMempoolI + getAddressesTxs = undefined + getAddressesUnspents = undefined instance MonadIO m => StoreWrite (ReaderT ImportDB m) where - setInit = R.ask >>= setInitI setBest h = R.ask >>= setBestI h insertBlock b = R.ask >>= insertBlockI b setBlocksAtHeight hs g = R.ask >>= setBlocksAtHeightI hs g @@ -344,10 +344,3 @@ insertUnspent u = R.ask >>= insertUnspentI u deleteUnspent p = R.ask >>= deleteUnspentI p setBalance b = R.ask >>= setBalanceI b - -instance MonadIO m => StoreStream (ReaderT ImportDB m) where - getOrphans = undefined - getAddressUnspents _ _ = undefined - getAddressTxs _ _ = undefined - getAddressBalances = undefined - getUnspents = undefined diff --git a/src/Network/Haskoin/Store/Data/KeyValue.hs b/src/Network/Haskoin/Store/Data/KeyValue.hs --- a/src/Network/Haskoin/Store/Data/KeyValue.hs +++ b/src/Network/Haskoin/Store/Data/KeyValue.hs @@ -4,16 +4,24 @@ {-# LANGUAGE MultiParamTypeClasses #-} module Network.Haskoin.Store.Data.KeyValue where -import Control.Monad.Reader -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import Data.Hashable -import Data.Serialize as S -import Data.Word -import qualified Database.RocksDB.Query as R -import GHC.Generics -import Haskoin -import Network.Haskoin.Store.Data +import Control.Monad (guard) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import qualified Data.ByteString.Short as B.Short +import Data.Hashable (Hashable) +import Data.Serialize (Serialize (..), getBytes, + getWord8, putWord8) +import Data.Word (Word32, Word64) +import qualified Database.RocksDB.Query as R +import GHC.Generics (Generic) +import Haskoin (Address, BlockHash, + BlockHeight, OutPoint (..), + Tx, TxHash) +import Network.Haskoin.Store.Data.Types (BalVal, BlockData, BlockRef, + BlockTx (..), Spender, + TxData, UnixTime, + Unspent (..), UnspentVal, + getUnixTime, putUnixTime) -- | Database key for an address transaction. data AddrTxKey @@ -183,6 +191,18 @@ instance R.Key UnspentKey instance R.KeyValue UnspentKey UnspentVal + +toUnspent :: AddrOutKey -> OutVal -> Unspent +toUnspent AddrOutKey {addrOutKeyB = b, addrOutKeyP = p} OutVal { outValAmount = v + , outValScript = s + } = + Unspent + { unspentBlock = b + , unspentAmount = v + , unspentScript = B.Short.toShort s + , unspentPoint = p + } +toUnspent _ _ = undefined -- | Mempool transaction database key. data MemKey = diff --git a/src/Network/Haskoin/Store/Data/Memory.hs b/src/Network/Haskoin/Store/Data/Memory.hs --- a/src/Network/Haskoin/Store/Data/Memory.hs +++ b/src/Network/Haskoin/Store/Data/Memory.hs @@ -1,26 +1,38 @@ -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TupleSections #-} -{-# OPTIONS_GHC -Wno-orphans #-} module Network.Haskoin.Store.Data.Memory where -import Conduit -import Control.Monad -import Control.Monad.Reader (MonadReader, ReaderT) +import Conduit (ConduitT, mapC, yieldMany, + (.|)) +import Control.Monad (join) +import Control.Monad.Reader (ReaderT) import qualified Control.Monad.Reader as R import qualified Data.ByteString.Short as B.Short -import Data.Function +import Data.Function (on) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as M import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as I -import Data.List -import Data.Maybe -import Data.Tuple (swap) -import Haskoin -import Network.Haskoin.Store.Data -import Network.Haskoin.Store.Data.KeyValue -import Network.Haskoin.Store.Messages +import Data.List (nub, sortBy) +import Data.Maybe (catMaybes, fromJust, + fromMaybe, isJust, + maybeToList) +import Haskoin (Address, BlockHash, + BlockHeight, + OutPoint (..), Tx, TxHash, + headerHash, txHash) +import Network.Haskoin.Store.Data.KeyValue (OutVal (..)) +import Network.Haskoin.Store.Data.Types (BalVal, Balance, + BlockData (..), BlockRef, + BlockTx (..), Limit, + Spender, StoreRead (..), + StoreStream (..), + StoreWrite (..), + TxData (..), UnixTime, + Unspent (..), UnspentVal, + balanceToVal, + unspentToVal, + valToBalance, + valToUnspent) import UnliftIO withBlockMem :: MonadIO m => TVar BlockMem -> ReaderT (TVar BlockMem) m a -> m a @@ -38,7 +50,6 @@ , hAddrOut :: !(HashMap Address (HashMap BlockRef (HashMap OutPoint (Maybe OutVal)))) , hMempool :: !(Maybe [(UnixTime, TxHash)]) , hOrphans :: !(HashMap TxHash (Maybe (UnixTime, Tx))) - , hInit :: !Bool } deriving (Eq, Show) emptyBlockMem :: BlockMem @@ -55,12 +66,8 @@ , hAddrOut = M.empty , hMempool = Nothing , hOrphans = M.empty - , hInit = False } -isInitializedH :: BlockMem -> Either InitException Bool -isInitializedH = Right . hInit - getBestBlockH :: BlockMem -> Maybe BlockHash getBestBlockH = hBest @@ -82,7 +89,7 @@ getSpendersH t = M.lookupDefault I.empty t . hSpender getBalanceH :: Address -> BlockMem -> Maybe Balance -getBalanceH a = fmap (balValToBalance a) . M.lookup a . hBalance +getBalanceH a = fmap (valToBalance a) . M.lookup a . hBalance getMempoolH :: BlockMem -> Maybe [(UnixTime, TxHash)] getMempoolH = hMempool @@ -101,9 +108,20 @@ , (i, mv) <- I.toList m , v <- maybeToList mv , let p = OutPoint h (fromIntegral i) - , let u = unspentValToUnspent p v + , let u = valToUnspent p v ] +getAddressesTxsH :: + [Address] -> Maybe BlockRef -> Maybe Limit -> BlockMem -> [BlockTx] +getAddressesTxsH addrs start limit db = + case limit of + Nothing -> g + Just l -> take (fromIntegral l) g + where + g = + nub . sortBy (flip compare `on` blockTxBlock) . concat $ + map (\a -> getAddressTxsH a start db) addrs + getAddressTxsH :: Address -> Maybe BlockRef -> BlockMem -> [BlockTx] getAddressTxsH a mbr db = dropWhile h . @@ -123,8 +141,19 @@ getAddressBalancesH :: Monad m => BlockMem -> ConduitT i Balance m () getAddressBalancesH BlockMem {hBalance = bm} = - yieldMany (M.toList bm) .| mapC (uncurry balValToBalance) + yieldMany (M.toList bm) .| mapC (uncurry valToBalance) +getAddressesUnspentsH :: + [Address] -> Maybe BlockRef -> Maybe Limit -> BlockMem -> [Unspent] +getAddressesUnspentsH addrs start limit db = + case limit of + Nothing -> g + Just l -> take (fromIntegral l) g + where + g = + nub . sortBy (flip compare `on` unspentBlock) . concat $ + map (\a -> getAddressUnspentsH a start db) addrs + getAddressUnspentsH :: Address -> Maybe BlockRef -> BlockMem -> [Unspent] getAddressUnspentsH a mbr db = @@ -147,9 +176,6 @@ Nothing -> False Just br -> b > br -setInitH :: BlockMem -> BlockMem -setInitH db = db {hInit = True} - setBestH :: BlockHash -> BlockMem -> BlockMem setBestH h db = db {hBest = Just h} @@ -188,7 +214,7 @@ setBalanceH :: Balance -> BlockMem -> BlockMem setBalanceH bal db = db {hBalance = M.insert a b (hBalance db)} where - (a, b) = balanceToBalVal bal + (a, b) = balanceToVal bal insertAddrTxH :: Address -> BlockTx -> BlockMem -> BlockMem insertAddrTxH a btx db = @@ -248,7 +274,7 @@ getUnspentH :: OutPoint -> BlockMem -> Maybe (Maybe Unspent) getUnspentH op db = do m <- M.lookup (outPointHash op) (hUnspent db) - fmap (unspentValToUnspent op) <$> I.lookup (fromIntegral (outPointIndex op)) m + fmap (valToUnspent op) <$> I.lookup (fromIntegral (outPointIndex op)) m insertUnspentH :: Unspent -> BlockMem -> BlockMem insertUnspentH u db = @@ -259,7 +285,7 @@ (outPointHash (unspentPoint u)) (I.singleton (fromIntegral (outPointIndex (unspentPoint u))) - (Just (snd (unspentToUnspentVal u)))) + (Just (snd (unspentToVal u)))) (hUnspent db) } @@ -275,9 +301,6 @@ } instance MonadIO m => StoreRead (ReaderT (TVar BlockMem) m) where - isInitialized = do - v <- R.ask >>= readTVarIO - return $ isInitializedH v getBestBlock = do v <- R.ask >>= readTVarIO return $ getBestBlockH v @@ -308,6 +331,12 @@ getMempool = do v <- R.ask >>= readTVarIO return . fromMaybe [] $ getMempoolH v + getAddressesTxs addr start limit = do + v <- R.ask >>= readTVarIO + return $ getAddressesTxsH addr start limit v + getAddressesUnspents addr start limit = do + v <- R.ask >>= readTVarIO + return $ getAddressesUnspentsH addr start limit v instance MonadIO m => StoreStream (ReaderT (TVar BlockMem) m) where getOrphans = do @@ -327,9 +356,6 @@ getUnspentsH v instance (MonadIO m) => StoreWrite (ReaderT (TVar BlockMem) m) where - setInit = do - v <- R.ask - atomically $ modifyTVar v setInitH setBest h = do v <- R.ask atomically $ modifyTVar v (setBestH h) diff --git a/src/Network/Haskoin/Store/Data/RocksDB.hs b/src/Network/Haskoin/Store/Data/RocksDB.hs --- a/src/Network/Haskoin/Store/Data/RocksDB.hs +++ b/src/Network/Haskoin/Store/Data/RocksDB.hs @@ -1,45 +1,98 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -Wno-orphans #-} module Network.Haskoin.Store.Data.RocksDB where -import Conduit -import Control.Monad.Reader (MonadReader, ReaderT) -import qualified Control.Monad.Reader as R -import qualified Data.ByteString.Short as B.Short +import Conduit (ConduitT, MonadResource, + mapC, runConduit, + runResourceT, sinkList, + (.|)) +import Control.Monad (forM_) +import Control.Monad.Except (runExceptT, throwError) +import Control.Monad.Reader (ReaderT, ask, runReaderT) +import Data.Function (on) import Data.IntMap (IntMap) import qualified Data.IntMap.Strict as I +import Data.List (nub, sortBy) import Data.Maybe (fromMaybe) -import Data.Word -import Database.RocksDB (DB, ReadOptions) -import Database.RocksDB.Query -import Haskoin -import Network.Haskoin.Store.Data -import Network.Haskoin.Store.Data.KeyValue -import UnliftIO +import Data.Word (Word32) +import Database.RocksDB (Compression (..), DB, + Options (..), + defaultOptions, + defaultReadOptions, open) +import Database.RocksDB.Query (insert, matching, + matchingAsList, + matchingSkip, retrieve) +import Haskoin (Address, BlockHash, + BlockHeight, + OutPoint (..), Tx, TxHash) +import Network.Haskoin.Store.Data.KeyValue (AddrOutKey (..), + AddrTxKey (..), + BalKey (..), BestKey (..), + BlockKey (..), + HeightKey (..), + MemKey (..), + OldMemKey (..), + OrphanKey (..), + SpenderKey (..), + TxKey (..), + UnspentKey (..), + VersionKey (..), + toUnspent) +import Network.Haskoin.Store.Data.Types (Balance, BlockDB (..), + BlockData, BlockRef, + BlockTx (..), Limit, + Spender, StoreRead (..), + StoreStream (..), TxData, + UnixTime, Unspent (..), + UnspentVal (..), + applyLimit, valToBalance, + valToUnspent) +import UnliftIO (MonadIO, liftIO) dataVersion :: Word32 dataVersion = 16 -isInitializedDB :: MonadIO m => BlockDB -> m (Either InitException Bool) -isInitializedDB bdb@BlockDB {blockDBopts = opts, blockDB = db} = - retrieve db opts VersionKey >>= \case - Just v - | v == dataVersion -> return (Right True) - | v == 15 -> migrate15to16 bdb - | otherwise -> return (Left (IncorrectVersion v)) - Nothing -> return (Right False) +connectRocksDB :: MonadIO m => FilePath -> m BlockDB +connectRocksDB dir = do + bdb <- open + dir + defaultOptions + { createIfMissing = True + , compression = SnappyCompression + , maxOpenFiles = -1 + , writeBufferSize = 2 ^ (30 :: Integer) + } >>= \db -> + return BlockDB {blockDBopts = defaultReadOptions, blockDB = db} + initRocksDB bdb + return bdb -migrate15to16 :: MonadIO m => BlockDB -> m (Either InitException Bool) -migrate15to16 bdb@BlockDB {blockDBopts = opts, blockDB = db} = do +withRocksDB :: MonadIO m => BlockDB -> ReaderT BlockDB m a -> m a +withRocksDB = flip runReaderT + +initRocksDB :: MonadIO m => BlockDB -> m () +initRocksDB bdb@BlockDB {blockDBopts = opts, blockDB = db} = do + e <- + runExceptT $ + retrieve db opts VersionKey >>= \case + Just v + | v == dataVersion -> return () + | v == 15 -> migrate15to16 bdb >> initRocksDB bdb + | otherwise -> throwError "Incorrect RocksDB database version" + Nothing -> setInitRocksDB db + case e of + Left s -> error s + Right () -> return () + +migrate15to16 :: MonadIO m => BlockDB -> m () +migrate15to16 BlockDB {blockDBopts = opts, blockDB = db} = do xs <- liftIO $ matchingAsList db opts OldMemKeyS let ys = map (\(OldMemKey t h, ()) -> (t, h)) xs insert db MemKey ys insert db VersionKey (16 :: Word32) - isInitializedDB bdb -setInitDB :: MonadIO m => DB -> m () -setInitDB db = insert db VersionKey dataVersion +setInitRocksDB :: MonadIO m => DB -> m () +setInitRocksDB db = insert db VersionKey dataVersion getBestBlockDB :: MonadIO m => BlockDB -> m (Maybe BlockHash) getBestBlockDB BlockDB {blockDBopts = opts, blockDB = db} = @@ -74,7 +127,7 @@ getBalanceDB :: MonadIO m => Address -> BlockDB -> m (Maybe Balance) getBalanceDB a BlockDB {blockDBopts = opts, blockDB = db} = - fmap (balValToBalance a) <$> retrieve db opts (BalKey a) + fmap (valToBalance a) <$> retrieve db opts (BalKey a) getMempoolDB :: MonadIO m => BlockDB -> m [(UnixTime, TxHash)] getMempoolDB BlockDB {blockDBopts = opts, blockDB = db} = @@ -91,6 +144,25 @@ getOrphanTxDB h BlockDB {blockDBopts = opts, blockDB = db} = retrieve db opts (OrphanKey h) +getAddressesTxsDB :: + MonadIO m + => [Address] + -> Maybe BlockRef + -> Maybe Limit + -> BlockDB + -> m [BlockTx] +getAddressesTxsDB addrs start limit db = + liftIO . runResourceT $ do + ts <- + runConduit $ + forM_ addrs (\a -> getAddressTxsDB a start db .| applyLimit limit) .| + sinkList + let ts' = nub $ sortBy (flip compare `on` blockTxBlock) ts + return $ + case limit of + Just l -> take (fromIntegral l) ts' + Nothing -> ts' + getAddressTxsDB :: (MonadIO m, MonadResource m) => Address @@ -112,7 +184,7 @@ => BlockDB -> ConduitT i Balance m () getAddressBalancesDB BlockDB {blockDBopts = opts, blockDB = db} = - matching db opts BalKeyS .| mapC (\(BalKey a, b) -> balValToBalance a b) + matching db opts BalKeyS .| mapC (\(BalKey a, b) -> valToBalance a b) getUnspentsDB :: (MonadIO m, MonadResource m) @@ -124,8 +196,29 @@ getUnspentDB :: MonadIO m => OutPoint -> BlockDB -> m (Maybe Unspent) getUnspentDB p BlockDB {blockDBopts = opts, blockDB = db} = - fmap (unspentValToUnspent p) <$> retrieve db opts (UnspentKey p) + fmap (valToUnspent p) <$> retrieve db opts (UnspentKey p) +getAddressesUnspentsDB :: + MonadIO m + => [Address] + -> Maybe BlockRef + -> Maybe Limit + -> BlockDB + -> m [Unspent] +getAddressesUnspentsDB addrs start limit bdb = + liftIO . runResourceT $ do + us <- + runConduit $ + forM_ + addrs + (\a -> getAddressUnspentsDB a start bdb .| applyLimit limit) .| + sinkList + let us' = nub $ sortBy (flip compare `on` unspentBlock) us + return $ + case limit of + Just l -> take (fromIntegral l) us' + Nothing -> us' + getAddressUnspentsDB :: (MonadIO m, MonadResource m) => Address @@ -133,22 +226,12 @@ -> BlockDB -> ConduitT i Unspent m () getAddressUnspentsDB a mbr BlockDB {blockDBopts = opts, blockDB = db} = - x .| mapC (uncurry f) + x .| mapC (uncurry toUnspent) where x = case mbr of Nothing -> matching db opts (AddrOutKeyA a) Just br -> matchingSkip db opts (AddrOutKeyA a) (AddrOutKeyB a br) - f AddrOutKey {addrOutKeyB = b, addrOutKeyP = p} OutVal { outValAmount = v - , outValScript = s - } = - Unspent - { unspentBlock = b - , unspentAmount = v - , unspentScript = B.Short.toShort s - , unspentPoint = p - } - f _ _ = undefined unspentFromDB :: OutPoint -> UnspentVal -> Unspent unspentFromDB p UnspentVal { unspentValBlock = b @@ -161,3 +244,26 @@ , unspentPoint = p , unspentScript = s } + +instance MonadIO m => StoreRead (ReaderT BlockDB m) where + getBestBlock = ask >>= getBestBlockDB + getBlocksAtHeight h = ask >>= getBlocksAtHeightDB h + getBlock b = ask >>= getBlockDB b + getTxData t = ask >>= getTxDataDB t + getSpender p = ask >>= getSpenderDB p + getSpenders t = ask >>= getSpendersDB t + getOrphanTx h = ask >>= getOrphanTxDB h + getUnspent a = ask >>= getUnspentDB a + getBalance a = ask >>= getBalanceDB a + getMempool = ask >>= getMempoolDB + getAddressesTxs addrs start limit = + ask >>= getAddressesTxsDB addrs start limit + getAddressesUnspents addrs start limit = + ask >>= getAddressesUnspentsDB addrs start limit + +instance (MonadResource m, MonadIO m) => StoreStream (ReaderT BlockDB m) where + getOrphans = ask >>= getOrphansDB + getAddressUnspents a b = ask >>= getAddressUnspentsDB a b + getAddressTxs a b = ask >>= getAddressTxsDB a b + getAddressBalances = ask >>= getAddressBalancesDB + getUnspents = ask >>= getUnspentsDB diff --git a/src/Network/Haskoin/Store/Data/Types.hs b/src/Network/Haskoin/Store/Data/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/Haskoin/Store/Data/Types.hs @@ -0,0 +1,1341 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +module Network.Haskoin.Store.Data.Types where + +import Conduit (ConduitT, dropC, mapC, takeC) +import Control.Applicative ((<|>)) +import Control.Arrow (first) +import Control.DeepSeq (NFData) +import Control.Exception (Exception) +import Control.Monad (forM, guard, mzero) +import Control.Monad.Trans (lift) +import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) +import Data.Aeson (Encoding, ToJSON (..), Value (..), + object, pairs, (.=)) +import qualified Data.Aeson as A +import qualified Data.Aeson.Encoding as A +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.ByteString.Short (ShortByteString) +import qualified Data.ByteString.Short as B.Short +import Data.Default (Default (..)) +import Data.Hashable (Hashable) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as M +import qualified Data.IntMap as I +import Data.IntMap.Strict (IntMap) +import Data.Maybe (catMaybes, isJust, listToMaybe, + mapMaybe) +import Data.Serialize as S +import Data.String.Conversions (cs) +import qualified Data.Text.Encoding as T +import Data.Word (Word32, Word64) +import Database.RocksDB (DB, ReadOptions) +import GHC.Generics (Generic) +import Haskoin (Address, Block, BlockHash, + BlockHeader (..), BlockHeight, + BlockNode, BlockWork, HostAddress, + KeyIndex, Network (..), + NetworkAddress (..), OutPoint (..), + RejectCode (..), Tx (..), + TxHash (..), TxIn (..), TxOut (..), + WitnessStack, addrToJSON, + addrToString, eitherToMaybe, + encodeHex, headerHash, + hostToSockAddr, scriptToAddressBS, + stringToAddr, txHash) +import Haskoin.Node (Chain, HostPort, Manager, Peer) +import Network.Socket (SockAddr) +import NQE (Listen, Mailbox) +import qualified Paths_haskoin_store as P + +encodeShort :: Serialize a => a -> ShortByteString +encodeShort = B.Short.toShort . S.encode + +decodeShort :: Serialize a => ShortByteString -> a +decodeShort bs = case S.decode (B.Short.fromShort bs) of + Left e -> error e + Right a -> a + +-- | Mailbox for block store. +type BlockStore = Mailbox BlockMessage + +-- | Store mailboxes. +data Store = + Store + { storeManager :: !Manager + -- ^ peer manager mailbox + , storeChain :: !Chain + -- ^ chain header process mailbox + , storeBlock :: !BlockStore + -- ^ block storage mailbox + } + +-- | Configuration for a 'Store'. +data StoreConfig = + StoreConfig + { storeConfMaxPeers :: !Int + -- ^ max peers to connect to + , storeConfInitPeers :: ![HostPort] + -- ^ static set of peers to connect to + , storeConfDiscover :: !Bool + -- ^ discover new peers? + , storeConfDB :: !BlockDB + -- ^ RocksDB database handler + , storeConfNetwork :: !Network + -- ^ network constants + , storeConfListen :: !(Listen StoreEvent) + -- ^ listen to store events + } + +-- | Configuration for a block store. +data BlockConfig = + BlockConfig + { blockConfManager :: !Manager + -- ^ peer manager from running node + , blockConfChain :: !Chain + -- ^ chain from a running node + , blockConfListener :: !(Listen StoreEvent) + -- ^ listener for store events + , blockConfDB :: !BlockDB + -- ^ RocksDB database handle + , blockConfNet :: !Network + -- ^ network constants + } + +data BlockDB = + BlockDB + { blockDB :: !DB + , blockDBopts :: !ReadOptions + } + +type UnixTime = Word64 +type BlockPos = Word32 + +type Offset = Word32 +type Limit = Word32 + +class Monad m => + StoreRead m + where + getBestBlock :: m (Maybe BlockHash) + getBlocksAtHeight :: BlockHeight -> m [BlockHash] + getBlock :: BlockHash -> m (Maybe BlockData) + getTxData :: TxHash -> m (Maybe TxData) + getOrphanTx :: TxHash -> m (Maybe (UnixTime, Tx)) + getSpenders :: TxHash -> m (IntMap Spender) + getSpender :: OutPoint -> m (Maybe Spender) + getBalance :: Address -> m (Maybe Balance) + getBalance a = head <$> getBalances [a] + getBalances :: [Address] -> m [(Maybe Balance)] + getBalances as = mapM getBalance as + getAddressesTxs :: [Address] -> Maybe BlockRef -> Maybe Limit -> m [BlockTx] + getUnspent :: OutPoint -> m (Maybe Unspent) + getAddressesUnspents :: + [Address] -> Maybe BlockRef -> Maybe Limit -> m [Unspent] + getMempool :: m [(UnixTime, TxHash)] + +class StoreWrite m where + setBest :: BlockHash -> m () + insertBlock :: BlockData -> m () + setBlocksAtHeight :: [BlockHash] -> BlockHeight -> m () + insertTx :: TxData -> m () + insertSpender :: OutPoint -> Spender -> m () + deleteSpender :: OutPoint -> m () + insertAddrTx :: Address -> BlockTx -> m () + deleteAddrTx :: Address -> BlockTx -> m () + insertAddrUnspent :: Address -> Unspent -> m () + deleteAddrUnspent :: Address -> Unspent -> m () + setMempool :: [(UnixTime, TxHash)] -> m () + insertOrphanTx :: Tx -> UnixTime -> m () + deleteOrphanTx :: TxHash -> m () + setBalance :: Balance -> m () + insertUnspent :: Unspent -> m () + deleteUnspent :: OutPoint -> m () + +class StoreStream m where + getOrphans :: ConduitT i (UnixTime, Tx) m () + getAddressUnspents :: Address -> Maybe BlockRef -> ConduitT i Unspent m () + getAddressTxs :: Address -> Maybe BlockRef -> ConduitT i BlockTx m () + getAddressBalances :: ConduitT i Balance m () + getUnspents :: ConduitT i Unspent m () + +getTransaction :: + (Monad m, StoreRead m) => TxHash -> m (Maybe Transaction) +getTransaction h = runMaybeT $ do + d <- MaybeT $ getTxData h + sm <- lift $ getSpenders h + return $ toTransaction d sm + +blockAtOrBefore :: (Monad m, StoreRead m) => UnixTime -> m (Maybe BlockData) +blockAtOrBefore q = runMaybeT $ do + a <- g 0 + b <- MaybeT getBestBlock >>= MaybeT . getBlock + f a b + where + f a b + | t b <= q = return b + | t a > q = mzero + | h b - h a == 1 = return a + | otherwise = do + let x = h a + (h b - h a) `div` 2 + m <- g x + if t m > q then f a m else f m b + g x = MaybeT (listToMaybe <$> getBlocksAtHeight x) >>= MaybeT . getBlock + h = blockDataHeight + t = fromIntegral . blockTimestamp . blockDataHeader + +-- | Serialize such that ordering is inverted. +putUnixTime :: Word64 -> Put +putUnixTime w = putWord64be $ maxBound - w + +getUnixTime :: Get Word64 +getUnixTime = (maxBound -) <$> getWord64be + +class JsonSerial a where + jsonSerial :: Network -> a -> Encoding + jsonValue :: Network -> a -> Value + +instance JsonSerial a => JsonSerial [a] where + jsonSerial net = A.list (jsonSerial net) + jsonValue net = toJSON . (jsonValue net) + +instance JsonSerial TxHash where + jsonSerial _ = toEncoding + jsonValue _ = toJSON + +instance BinSerial TxHash where + binSerial _ = put + binDeserial _ = get + +instance BinSerial Address where + binSerial net a = + case addrToString net a of + Nothing -> put B.empty + Just x -> put $ T.encodeUtf8 x + + binDeserial net = do + bs <- get + guard (not (B.null bs)) + t <- case T.decodeUtf8' bs of + Left _ -> mzero + Right v -> return v + case stringToAddr net t of + Nothing -> mzero + Just x -> return x + +class BinSerial a where + binSerial :: Network -> Putter a + binDeserial :: Network -> Get a + +instance BinSerial a => BinSerial [a] where + binSerial net = putListOf (binSerial net) + binDeserial net = getListOf (binDeserial net) + +-- | Reference to a block where a transaction is stored. +data BlockRef + = BlockRef { blockRefHeight :: !BlockHeight + -- ^ block height in the chain + , blockRefPos :: !Word32 + -- ^ position of transaction within the block + } + | MemRef { memRefTime :: !UnixTime } + deriving (Show, Read, Eq, Ord, Generic, Hashable, NFData) + +-- | Serialized entities will sort in reverse order. +instance Serialize BlockRef where + put MemRef {memRefTime = t} = do + putWord8 0x00 + putUnixTime t + put BlockRef {blockRefHeight = h, blockRefPos = p} = do + putWord8 0x01 + putWord32be (maxBound - h) + putWord32be (maxBound - p) + get = getmemref <|> getblockref + where + getmemref = do + guard . (== 0x00) =<< getWord8 + MemRef <$> getUnixTime + getblockref = do + guard . (== 0x01) =<< getWord8 + h <- (maxBound -) <$> getWord32be + p <- (maxBound -) <$> getWord32be + return BlockRef {blockRefHeight = h, blockRefPos = p} + +instance BinSerial BlockRef where + binSerial _ BlockRef {blockRefHeight = h, blockRefPos = p} = do + putWord8 0x00 + putWord32be h + putWord32be p + binSerial _ MemRef {memRefTime = t} = do + putWord8 0x01 + putWord64be t + + binDeserial _ = getWord8 >>= + \case + 0x00 -> BlockRef <$> getWord32be <*> getWord32be + 0x01 -> MemRef <$> getUnixTime + _ -> fail "Expected fst byte to be 0x00 or 0x01" + +-- | JSON serialization for 'BlockRef'. +blockRefPairs :: A.KeyValue kv => BlockRef -> [kv] +blockRefPairs BlockRef {blockRefHeight = h, blockRefPos = p} = + ["height" .= h, "position" .= p] +blockRefPairs MemRef {memRefTime = t} = ["mempool" .= t] + +confirmed :: BlockRef -> Bool +confirmed BlockRef {} = True +confirmed MemRef {} = False + +instance ToJSON BlockRef where + toJSON = object . blockRefPairs + toEncoding = pairs . mconcat . blockRefPairs + +-- | Transaction in relation to an address. +data BlockTx = BlockTx + { blockTxBlock :: !BlockRef + -- ^ block information + , blockTxHash :: !TxHash + -- ^ transaction hash + } deriving (Show, Eq, Ord, Generic, Serialize, Hashable, NFData) + +-- | JSON serialization for 'AddressTx'. +blockTxPairs :: A.KeyValue kv => BlockTx -> [kv] +blockTxPairs btx = + [ "txid" .= blockTxHash btx + , "block" .= blockTxBlock btx + ] + +instance ToJSON BlockTx where + toJSON = object . blockTxPairs + toEncoding = pairs . mconcat . blockTxPairs + +instance JsonSerial BlockTx where + jsonSerial _ = toEncoding + jsonValue _ = toJSON + +instance BinSerial BlockTx where + binSerial net BlockTx { blockTxBlock = b, blockTxHash = h } = do + binSerial net b + binSerial net h + + binDeserial net = BlockTx <$> binDeserial net <*> binDeserial net + +-- | Address balance information. +data Balance = Balance + { balanceAddress :: !Address + -- ^ address balance + , balanceAmount :: !Word64 + -- ^ confirmed balance + , balanceZero :: !Word64 + -- ^ unconfirmed balance + , balanceUnspentCount :: !Word64 + -- ^ number of unspent outputs + , balanceTxCount :: !Word64 + -- ^ number of transactions + , balanceTotalReceived :: !Word64 + -- ^ total amount from all outputs in this address + } deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable, NFData) + +zeroBalance :: Address -> Balance +zeroBalance a = + Balance + { balanceAddress = a + , balanceAmount = 0 + , balanceUnspentCount = 0 + , balanceZero = 0 + , balanceTxCount = 0 + , balanceTotalReceived = 0 + } + +-- | JSON serialization for 'Balance'. +balancePairs :: A.KeyValue kv => Network -> Balance -> [kv] +balancePairs net ab = + [ "address" .= addrToJSON net (balanceAddress ab) + , "confirmed" .= balanceAmount ab + , "unconfirmed" .= balanceZero ab + , "utxo" .= balanceUnspentCount ab + , "txs" .= balanceTxCount ab + , "received" .= balanceTotalReceived ab + ] + +balanceToJSON :: Network -> Balance -> Value +balanceToJSON net = object . balancePairs net + +balanceToEncoding :: Network -> Balance -> Encoding +balanceToEncoding net = pairs . mconcat . balancePairs net + +instance JsonSerial Balance where + jsonSerial = balanceToEncoding + jsonValue = balanceToJSON + +instance BinSerial Balance where + binSerial net Balance { balanceAddress = a + , balanceAmount = v + , balanceZero = z + , balanceUnspentCount = u + , balanceTxCount = c + , balanceTotalReceived = t + } = do + binSerial net a + putWord64be v + putWord64be z + putWord64be u + putWord64be c + putWord64be t + + binDeserial net = + Balance <$> binDeserial net + <*> getWord64be + <*> getWord64be + <*> getWord64be + <*> getWord64be + <*> getWord64be + + +-- | Unspent output. +data Unspent = Unspent + { unspentBlock :: !BlockRef + -- ^ block information for output + , unspentPoint :: !OutPoint + -- ^ txid and index where output located + , unspentAmount :: !Word64 + -- ^ value of output in satoshi + , unspentScript :: !ShortByteString + -- ^ pubkey (output) script + } deriving (Show, Eq, Ord, Generic, Hashable, NFData) + +instance Serialize Unspent where + put u = do + put $ unspentBlock u + put $ unspentPoint u + put $ unspentAmount u + put $ B.Short.length (unspentScript u) + putShortByteString $ unspentScript u + get = + Unspent <$> get <*> get <*> get <*> (getShortByteString =<< get) + +unspentPairs :: A.KeyValue kv => Network -> Unspent -> [kv] +unspentPairs net u = + [ "address" .= + eitherToMaybe + (addrToJSON net <$> + scriptToAddressBS (B.Short.fromShort (unspentScript u))) + , "block" .= unspentBlock u + , "txid" .= outPointHash (unspentPoint u) + , "index" .= outPointIndex (unspentPoint u) + , "pkscript" .= String (encodeHex (B.Short.fromShort (unspentScript u))) + , "value" .= unspentAmount u + ] + +unspentToJSON :: Network -> Unspent -> Value +unspentToJSON net = object . unspentPairs net + +unspentToEncoding :: Network -> Unspent -> Encoding +unspentToEncoding net = pairs . mconcat . unspentPairs net + +instance JsonSerial Unspent where + jsonSerial = unspentToEncoding + jsonValue = unspentToJSON + +instance BinSerial Unspent where + binSerial net Unspent { unspentBlock = b + , unspentPoint = p + , unspentAmount = v + , unspentScript = s + } = do + binSerial net b + put p + putWord64be v + put s + + binDeserial net = + Unspent + <$> binDeserial net + <*> get + <*> getWord64be + <*> get + +-- | Database value for a block entry. +data BlockData = BlockData + { blockDataHeight :: !BlockHeight + -- ^ height of the block in the chain + , blockDataMainChain :: !Bool + -- ^ is this block in the main chain? + , blockDataWork :: !BlockWork + -- ^ accumulated work in that block + , blockDataHeader :: !BlockHeader + -- ^ block header + , blockDataSize :: !Word32 + -- ^ size of the block including witnesses + , blockDataWeight :: !Word32 + -- ^ weight of this block (for segwit networks) + , blockDataTxs :: ![TxHash] + -- ^ block transactions + , blockDataOutputs :: !Word64 + -- ^ sum of all transaction outputs + , blockDataFees :: !Word64 + -- ^ sum of all transaction fees + , blockDataSubsidy :: !Word64 + -- ^ block subsidy + } deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable, NFData) + +-- | JSON serialization for 'BlockData'. +blockDataPairs :: A.KeyValue kv => Network -> BlockData -> [kv] +blockDataPairs net bv = + [ "hash" .= headerHash (blockDataHeader bv) + , "height" .= blockDataHeight bv + , "mainchain" .= blockDataMainChain bv + , "previous" .= prevBlock (blockDataHeader bv) + , "time" .= blockTimestamp (blockDataHeader bv) + , "version" .= blockVersion (blockDataHeader bv) + , "bits" .= blockBits (blockDataHeader bv) + , "nonce" .= bhNonce (blockDataHeader bv) + , "size" .= blockDataSize bv + , "tx" .= blockDataTxs bv + , "merkle" .= TxHash (merkleRoot (blockDataHeader bv)) + , "subsidy" .= blockDataSubsidy bv + , "fees" .= blockDataFees bv + , "outputs" .= blockDataOutputs bv + ] ++ ["weight" .= blockDataWeight bv | getSegWit net] + +blockDataToJSON :: Network -> BlockData -> Value +blockDataToJSON net = object . blockDataPairs net + +blockDataToEncoding :: Network -> BlockData -> Encoding +blockDataToEncoding net = pairs . mconcat . blockDataPairs net + +instance JsonSerial BlockData where + jsonSerial = blockDataToEncoding + jsonValue = blockDataToJSON + +instance BinSerial BlockData where + binSerial _ BlockData { blockDataHeight = e + , blockDataMainChain = m + , blockDataWork = w + , blockDataHeader = h + , blockDataSize = z + , blockDataWeight = g + , blockDataTxs = t + , blockDataOutputs = o + , blockDataFees = f + , blockDataSubsidy = y + } = do + put m + putWord32be e + put h + put w + putWord32be z + putWord32be g + putWord64be o + putWord64be f + putWord64be y + put t + + binDeserial _ = do + m <- get + e <- getWord32be + h <- get + w <- get + z <- getWord32be + g <- getWord32be + o <- getWord64be + f <- getWord64be + y <- getWord64be + t <- get + return $ BlockData e m w h z g t o f y + +-- | Input information. +data StoreInput + = StoreCoinbase { inputPoint :: !OutPoint + -- ^ output being spent (should be null) + , inputSequence :: !Word32 + -- ^ sequence + , inputSigScript :: !ByteString + -- ^ input script data (not valid script) + , inputWitness :: !(Maybe WitnessStack) + -- ^ witness data for this input (only segwit) + } + -- ^ coinbase details + | StoreInput { inputPoint :: !OutPoint + -- ^ output being spent + , inputSequence :: !Word32 + -- ^ sequence + , inputSigScript :: !ByteString + -- ^ signature (input) script + , inputPkScript :: !ByteString + -- ^ pubkey (output) script from previous tx + , inputAmount :: !Word64 + -- ^ amount in satoshi being spent spent + , inputWitness :: !(Maybe WitnessStack) + -- ^ witness data for this input (only segwit) + } + -- ^ input details + deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable, NFData) + +isCoinbase :: StoreInput -> Bool +isCoinbase StoreCoinbase {} = True +isCoinbase StoreInput {} = False + +inputPairs :: A.KeyValue kv => Network -> StoreInput -> [kv] +inputPairs net StoreInput { inputPoint = OutPoint oph opi + , inputSequence = sq + , inputSigScript = ss + , inputPkScript = ps + , inputAmount = val + , inputWitness = wit + } = + [ "coinbase" .= False + , "txid" .= oph + , "output" .= opi + , "sigscript" .= String (encodeHex ss) + , "sequence" .= sq + , "pkscript" .= String (encodeHex ps) + , "value" .= val + , "address" .= eitherToMaybe (addrToJSON net <$> scriptToAddressBS ps) + ] ++ + ["witness" .= fmap (map encodeHex) wit | getSegWit net] + +inputPairs net StoreCoinbase { inputPoint = OutPoint oph opi + , inputSequence = sq + , inputSigScript = ss + , inputWitness = wit + } = + [ "coinbase" .= True + , "txid" .= oph + , "output" .= opi + , "sigscript" .= String (encodeHex ss) + , "sequence" .= sq + , "pkscript" .= Null + , "value" .= Null + , "address" .= Null + ] ++ + ["witness" .= fmap (map encodeHex) wit | getSegWit net] + +inputToJSON :: Network -> StoreInput -> Value +inputToJSON net = object . inputPairs net + +inputToEncoding :: Network -> StoreInput -> Encoding +inputToEncoding net = pairs . mconcat . inputPairs net + +-- | Information about input spending output. +data Spender = Spender + { spenderHash :: !TxHash + -- ^ input transaction hash + , spenderIndex :: !Word32 + -- ^ input position in transaction + } deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable, NFData) + +-- | JSON serialization for 'Spender'. +spenderPairs :: A.KeyValue kv => Spender -> [kv] +spenderPairs n = + ["txid" .= spenderHash n, "input" .= spenderIndex n] + +instance ToJSON Spender where + toJSON = object . spenderPairs + toEncoding = pairs . mconcat . spenderPairs + +-- | Output information. +data StoreOutput = StoreOutput + { outputAmount :: !Word64 + -- ^ amount in satoshi + , outputScript :: !ByteString + -- ^ pubkey (output) script + , outputSpender :: !(Maybe Spender) + -- ^ input spending this transaction + } deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable, NFData) + +outputPairs :: A.KeyValue kv => Network -> StoreOutput -> [kv] +outputPairs net d = + [ "address" .= + eitherToMaybe (addrToJSON net <$> scriptToAddressBS (outputScript d)) + , "pkscript" .= String (encodeHex (outputScript d)) + , "value" .= outputAmount d + , "spent" .= isJust (outputSpender d) + ] ++ + ["spender" .= outputSpender d | isJust (outputSpender d)] + +outputToJSON :: Network -> StoreOutput -> Value +outputToJSON net = object . outputPairs net + +outputToEncoding :: Network -> StoreOutput -> Encoding +outputToEncoding net = pairs . mconcat . outputPairs net + +data Prev = Prev + { prevScript :: !ByteString + , prevAmount :: !Word64 + } deriving (Show, Eq, Ord, Generic, Hashable, Serialize, NFData) + +toInput :: TxIn -> Maybe Prev -> Maybe WitnessStack -> StoreInput +toInput i Nothing w = + StoreCoinbase + { inputPoint = prevOutput i + , inputSequence = txInSequence i + , inputSigScript = scriptInput i + , inputWitness = w + } +toInput i (Just p) w = + StoreInput + { inputPoint = prevOutput i + , inputSequence = txInSequence i + , inputSigScript = scriptInput i + , inputPkScript = prevScript p + , inputAmount = prevAmount p + , inputWitness = w + } + +toOutput :: TxOut -> Maybe Spender -> StoreOutput +toOutput o s = + StoreOutput + { outputAmount = outValue o + , outputScript = scriptOutput o + , outputSpender = s + } + +data TxData = TxData + { txDataBlock :: !BlockRef + , txData :: !Tx + , txDataPrevs :: !(IntMap Prev) + , txDataDeleted :: !Bool + , txDataRBF :: !Bool + , txDataTime :: !Word64 + } deriving (Show, Eq, Ord, Generic, Serialize, NFData) + +instance BinSerial TxData where + binSerial _ TxData + { txDataBlock = br + , txData = tx + , txDataPrevs = dp + , txDataDeleted = dd + , txDataRBF = dr + , txDataTime = t + } = do + put br + put tx + put dp + put dd + put dr + putWord64be t + + binDeserial _ = do br <- get + tx <- get + dp <- get + dd <- get + dr <- get + TxData br tx dp dd dr <$> getWord64be + +instance Serialize a => BinSerial (IntMap a) where + binSerial _ = put + binDeserial _ = get + +toTransaction :: TxData -> IntMap Spender -> Transaction +toTransaction t sm = + Transaction + { transactionBlock = txDataBlock t + , transactionVersion = txVersion (txData t) + , transactionLockTime = txLockTime (txData t) + , transactionInputs = ins + , transactionOutputs = outs + , transactionDeleted = txDataDeleted t + , transactionRBF = txDataRBF t + , transactionTime = txDataTime t + } + where + ws = + take (length (txIn (txData t))) $ + map Just (txWitness (txData t)) <> repeat Nothing + f n i = toInput i (I.lookup n (txDataPrevs t)) (ws !! n) + ins = zipWith f [0 ..] (txIn (txData t)) + g n o = toOutput o (I.lookup n sm) + outs = zipWith g [0 ..] (txOut (txData t)) + +fromTransaction :: Transaction -> (TxData, IntMap Spender) +fromTransaction t = (d, sm) + where + d = + TxData + { txDataBlock = transactionBlock t + , txData = transactionData t + , txDataPrevs = ps + , txDataDeleted = transactionDeleted t + , txDataRBF = transactionRBF t + , txDataTime = transactionTime t + } + f _ StoreCoinbase {} = Nothing + f n StoreInput {inputPkScript = s, inputAmount = v} = + Just (n, Prev {prevScript = s, prevAmount = v}) + ps = I.fromList . catMaybes $ zipWith f [0 ..] (transactionInputs t) + g _ StoreOutput {outputSpender = Nothing} = Nothing + g n StoreOutput {outputSpender = Just s} = Just (n, s) + sm = I.fromList . catMaybes $ zipWith g [0 ..] (transactionOutputs t) + +-- | Detailed transaction information. +data Transaction = Transaction + { transactionBlock :: !BlockRef + -- ^ block information for this transaction + , transactionVersion :: !Word32 + -- ^ transaction version + , transactionLockTime :: !Word32 + -- ^ lock time + , transactionInputs :: ![StoreInput] + -- ^ transaction inputs + , transactionOutputs :: ![StoreOutput] + -- ^ transaction outputs + , transactionDeleted :: !Bool + -- ^ this transaction has been deleted and is no longer valid + , transactionRBF :: !Bool + -- ^ this transaction can be replaced in the mempool + , transactionTime :: !Word64 + -- ^ time the transaction was first seen or time of block + } deriving (Show, Eq, Ord, Generic, Hashable, Serialize, NFData) + +transactionData :: Transaction -> Tx +transactionData t = + Tx + { txVersion = transactionVersion t + , txIn = map i (transactionInputs t) + , txOut = map o (transactionOutputs t) + , txWitness = mapMaybe inputWitness (transactionInputs t) + , txLockTime = transactionLockTime t + } + where + i StoreCoinbase {inputPoint = p, inputSequence = q, inputSigScript = s} = + TxIn {prevOutput = p, scriptInput = s, txInSequence = q} + i StoreInput {inputPoint = p, inputSequence = q, inputSigScript = s} = + TxIn {prevOutput = p, scriptInput = s, txInSequence = q} + o StoreOutput {outputAmount = v, outputScript = s} = + TxOut {outValue = v, scriptOutput = s} + +-- | JSON serialization for 'Transaction'. +transactionPairs :: A.KeyValue kv => Network -> Transaction -> [kv] +transactionPairs net dtx = + [ "txid" .= txHash (transactionData dtx) + , "size" .= B.length (S.encode (transactionData dtx)) + , "version" .= transactionVersion dtx + , "locktime" .= transactionLockTime dtx + , "fee" .= + if all isCoinbase (transactionInputs dtx) + then 0 + else sum (map inputAmount (transactionInputs dtx)) - + sum (map outputAmount (transactionOutputs dtx)) + , "inputs" .= map (object . inputPairs net) (transactionInputs dtx) + , "outputs" .= map (object . outputPairs net) (transactionOutputs dtx) + , "block" .= transactionBlock dtx + , "deleted" .= transactionDeleted dtx + , "time" .= transactionTime dtx + ] ++ + ["rbf" .= transactionRBF dtx | getReplaceByFee net] ++ + ["weight" .= w | getSegWit net] + where + w = let b = B.length $ S.encode (transactionData dtx) {txWitness = []} + x = B.length $ S.encode (transactionData dtx) + in b * 3 + x + +transactionToJSON :: Network -> Transaction -> Value +transactionToJSON net = object . transactionPairs net + +transactionToEncoding :: Network -> Transaction -> Encoding +transactionToEncoding net = pairs . mconcat . transactionPairs net + +instance JsonSerial Transaction where + jsonSerial = transactionToEncoding + jsonValue = transactionToJSON + +instance BinSerial Transaction where + binSerial net tx = do + let (txd, sp) = fromTransaction tx + binSerial net txd + binSerial net sp + + binDeserial net = do + txd <- binDeserial net + sp <- binDeserial net + return $ toTransaction txd sp + +instance JsonSerial Tx where + jsonSerial _ = toEncoding + jsonValue _ = toJSON + +instance BinSerial Tx where + binSerial _ = put + binDeserial _ = get + +instance JsonSerial Block where + jsonSerial _ = toEncoding + jsonValue _ = toJSON + +instance BinSerial Block where + binSerial _ = put + binDeserial _ = get + +-- | Information about a connected peer. +data PeerInformation + = PeerInformation { peerUserAgent :: !ByteString + -- ^ user agent string + , peerAddress :: !HostAddress + -- ^ network address + , peerVersion :: !Word32 + -- ^ version number + , peerServices :: !Word64 + -- ^ services field + , peerRelay :: !Bool + -- ^ will relay transactions + } + deriving (Show, Eq, Ord, Generic, NFData) + +-- | JSON serialization for 'PeerInformation'. +peerInformationPairs :: A.KeyValue kv => PeerInformation -> [kv] +peerInformationPairs p = + [ "useragent" .= String (cs (peerUserAgent p)) + , "address" .= String (cs (show (hostToSockAddr (peerAddress p)))) + , "version" .= peerVersion p + , "services" .= String (encodeHex (S.encode (peerServices p))) + , "relay" .= peerRelay p + ] + +instance ToJSON PeerInformation where + toJSON = object . peerInformationPairs + toEncoding = pairs . mconcat . peerInformationPairs + +instance JsonSerial PeerInformation where + jsonSerial _ = toEncoding + jsonValue _ = toJSON + +instance BinSerial PeerInformation where + binSerial _ PeerInformation { peerUserAgent = u + , peerAddress = a + , peerVersion = v + , peerServices = s + , peerRelay = b + } = do + putWord32be v + put b + put u + put $ NetworkAddress s a + + binDeserial _ = do + v <- getWord32be + b <- get + u <- get + NetworkAddress { naServices = s, naAddress = a } <- get + return $ PeerInformation u a v s b + +-- | Address balances for an extended public key. +data XPubBal = XPubBal + { xPubBalPath :: ![KeyIndex] + , xPubBal :: !Balance + } deriving (Show, Eq, Generic, NFData) + +-- | JSON serialization for 'XPubBal'. +xPubBalPairs :: A.KeyValue kv => Network -> XPubBal -> [kv] +xPubBalPairs net XPubBal {xPubBalPath = p, xPubBal = b} = + [ "path" .= p + , "balance" .= balanceToJSON net b + ] + +xPubBalToJSON :: Network -> XPubBal -> Value +xPubBalToJSON net = object . xPubBalPairs net + +xPubBalToEncoding :: Network -> XPubBal -> Encoding +xPubBalToEncoding net = pairs . mconcat . xPubBalPairs net + +instance JsonSerial XPubBal where + jsonSerial = xPubBalToEncoding + jsonValue = xPubBalToJSON + +instance BinSerial XPubBal where + binSerial net XPubBal {xPubBalPath = p, xPubBal = b} = do + put p + binSerial net b + binDeserial net = do + p <- get + b <- binDeserial net + return $ XPubBal p b + +-- | Unspent transaction for extended public key. +data XPubUnspent = XPubUnspent + { xPubUnspentPath :: ![KeyIndex] + , xPubUnspent :: !Unspent + } deriving (Show, Eq, Generic, NFData) + +-- | JSON serialization for 'XPubUnspent'. +xPubUnspentPairs :: A.KeyValue kv => Network -> XPubUnspent -> [kv] +xPubUnspentPairs net XPubUnspent { xPubUnspentPath = p + , xPubUnspent = u + } = + [ "path" .= p + , "unspent" .= unspentToJSON net u + ] + +xPubUnspentToJSON :: Network -> XPubUnspent -> Value +xPubUnspentToJSON net = object . xPubUnspentPairs net + +xPubUnspentToEncoding :: Network -> XPubUnspent -> Encoding +xPubUnspentToEncoding net = pairs . mconcat . xPubUnspentPairs net + +instance JsonSerial XPubUnspent where + jsonSerial = xPubUnspentToEncoding + jsonValue = xPubUnspentToJSON + +instance BinSerial XPubUnspent where + binSerial net XPubUnspent {xPubUnspentPath = p, xPubUnspent = u} = do + put p + binSerial net u + + binDeserial net = do + p <- get + u <- binDeserial net + return $ XPubUnspent p u + +data XPubSummary = + XPubSummary + { xPubSummaryConfirmed :: !Word64 + , xPubSummaryZero :: !Word64 + , xPubSummaryReceived :: !Word64 + , xPubUnspentCount :: !Word64 + , xPubExternalIndex :: !Word32 + , xPubChangeIndex :: !Word32 + , xPubSummaryPaths :: !(HashMap Address [KeyIndex]) + } + deriving (Eq, Show, Generic, NFData) + +xPubSummaryPairs :: A.KeyValue kv => Network -> XPubSummary -> [kv] +xPubSummaryPairs net XPubSummary { xPubSummaryConfirmed = c + , xPubSummaryZero = z + , xPubSummaryReceived = r + , xPubUnspentCount = u + , xPubSummaryPaths = ps + , xPubExternalIndex = ext + , xPubChangeIndex = ch + } = + [ "balance" .= + object + [ "confirmed" .= c + , "unconfirmed" .= z + , "received" .= r + , "utxo" .= u + ] + , "indices" .= object ["change" .= ch, "external" .= ext] + , "paths" .= object (mapMaybe (uncurry f) (M.toList ps)) + ] + where + f a p = (.= p) <$> addrToString net a + +xPubSummaryToJSON :: Network -> XPubSummary -> Value +xPubSummaryToJSON net = object . xPubSummaryPairs net + +xPubSummaryToEncoding :: Network -> XPubSummary -> Encoding +xPubSummaryToEncoding net = pairs . mconcat . xPubSummaryPairs net + +instance JsonSerial XPubSummary where + jsonSerial = xPubSummaryToEncoding + jsonValue = xPubSummaryToJSON + +instance BinSerial XPubSummary where + binSerial net XPubSummary { xPubSummaryConfirmed = c + , xPubSummaryZero = z + , xPubSummaryReceived = r + , xPubUnspentCount = u + , xPubExternalIndex = ext + , xPubChangeIndex = ch + , xPubSummaryPaths = ps + } = do + put c + put z + put r + put u + put ext + put ch + put (map (first (runPut . binSerial net)) (M.toList ps)) + binDeserial net = do + c <- get + z <- get + r <- get + u <- get + ext <- get + ch <- get + ps <- get + let xs = map (first (runGet (binDeserial net))) ps + ys <- + forM xs $ \(k, v) -> + case k of + Right a -> return (a, v) + Left _ -> mzero + return $ XPubSummary c z r u ext ch (M.fromList ys) + +data HealthCheck = + HealthCheck + { healthHeaderBest :: !(Maybe BlockHash) + , healthHeaderHeight :: !(Maybe BlockHeight) + , healthBlockBest :: !(Maybe BlockHash) + , healthBlockHeight :: !(Maybe BlockHeight) + , healthPeers :: !(Maybe Int) + , healthNetwork :: !String + , healthOK :: !Bool + , healthSynced :: !Bool + , healthLastBlock :: !(Maybe Word64) + , healthLastTx :: !(Maybe Word64) + } + deriving (Show, Eq, Generic, Serialize, NFData) + +healthCheckPairs :: A.KeyValue kv => HealthCheck -> [kv] +healthCheckPairs h = + [ "headers" .= + object ["hash" .= healthHeaderBest h, "height" .= healthHeaderHeight h] + , "blocks" .= + object ["hash" .= healthBlockBest h, "height" .= healthBlockHeight h] + , "peers" .= healthPeers h + , "net" .= healthNetwork h + , "ok" .= healthOK h + , "synced" .= healthSynced h + , "version" .= P.version + , "lastblock" .= healthLastBlock h + , "lasttx" .= healthLastTx h + ] + +instance ToJSON HealthCheck where + toJSON = object . healthCheckPairs + toEncoding = pairs . mconcat . healthCheckPairs + +instance JsonSerial HealthCheck where + jsonSerial _ = toEncoding + jsonValue _ = toJSON + +instance BinSerial HealthCheck where + binSerial _ HealthCheck { healthHeaderBest = hbest + , healthHeaderHeight = hheight + , healthBlockBest = bbest + , healthBlockHeight = bheight + , healthPeers = peers + , healthNetwork = net + , healthOK = ok + , healthSynced = synced + , healthLastBlock = lbk + , healthLastTx = ltx + } = do + put hbest + put hheight + put bbest + put bheight + put peers + put net + put ok + put synced + put lbk + put ltx + binDeserial _ = + HealthCheck <$> get <*> get <*> get <*> get <*> get <*> get <*> get <*> + get <*> + get <*> + get + +data Event + = EventBlock BlockHash + | EventTx TxHash + deriving (Show, Eq, Generic) + +instance ToJSON Event where + toJSON (EventTx h) = object ["type" .= String "tx", "id" .= h] + toJSON (EventBlock h) = object ["type" .= String "block", "id" .= h] + +instance JsonSerial Event where + jsonSerial _ = toEncoding + jsonValue _ = toJSON + +instance BinSerial Event where + binSerial _ (EventBlock bh) = putWord8 0x00 >> put bh + binSerial _ (EventTx th) = putWord8 0x01 >> put th + + binDeserial _ = getWord8 >>= + \case + 0x00-> EventBlock <$> get + 0x01 -> EventTx <$> get + _ -> fail "Expected fst byte to be 0x00 or 0x01" + + +newtype TxAfterHeight = TxAfterHeight + { txAfterHeight :: Maybe Bool + } deriving (Show, Eq, Generic, NFData) + +instance ToJSON TxAfterHeight where + toJSON (TxAfterHeight b) = object ["result" .= b] + +instance JsonSerial TxAfterHeight where + jsonSerial _ = toEncoding + jsonValue _ = toJSON + +instance BinSerial TxAfterHeight where + binSerial _ TxAfterHeight {txAfterHeight = a} = put a + binDeserial _ = TxAfterHeight <$> get + +newtype TxId = TxId TxHash deriving (Show, Eq, Generic, NFData) + +instance ToJSON TxId where + toJSON (TxId h) = object ["txid" .= h] + +instance JsonSerial TxId where + jsonSerial _ = toEncoding + jsonValue _ = toJSON + +instance BinSerial TxId where + binSerial _ (TxId th) = put th + binDeserial _ = TxId <$> get + +data BalVal = BalVal + { balValAmount :: !Word64 + , balValZero :: !Word64 + , balValUnspentCount :: !Word64 + , balValTxCount :: !Word64 + , balValTotalReceived :: !Word64 + } deriving (Show, Read, Eq, Ord, Generic, Hashable, Serialize, NFData) + +valToBalance :: Address -> BalVal -> Balance +valToBalance a BalVal { balValAmount = v + , balValZero = z + , balValUnspentCount = u + , balValTxCount = t + , balValTotalReceived = r + } = + Balance + { balanceAddress = a + , balanceAmount = v + , balanceZero = z + , balanceUnspentCount = u + , balanceTxCount = t + , balanceTotalReceived = r + } + +balanceToVal :: Balance -> (Address, BalVal) +balanceToVal Balance { balanceAddress = a + , balanceAmount = v + , balanceZero = z + , balanceUnspentCount = u + , balanceTxCount = t + , balanceTotalReceived = r + } = + ( a + , BalVal + { balValAmount = v + , balValZero = z + , balValUnspentCount = u + , balValTxCount = t + , balValTotalReceived = r + }) + +-- | Default balance for an address. +instance Default BalVal where + def = + BalVal + { balValAmount = 0 + , balValZero = 0 + , balValUnspentCount = 0 + , balValTxCount = 0 + , balValTotalReceived = 0 + } + +data UnspentVal = UnspentVal + { unspentValBlock :: !BlockRef + , unspentValAmount :: !Word64 + , unspentValScript :: !ShortByteString + } deriving (Show, Read, Eq, Ord, Generic, Hashable, Serialize, NFData) + +unspentToVal :: Unspent -> (OutPoint, UnspentVal) +unspentToVal Unspent { unspentBlock = b + , unspentPoint = p + , unspentAmount = v + , unspentScript = s + } = + ( p + , UnspentVal + {unspentValBlock = b, unspentValAmount = v, unspentValScript = s}) + +valToUnspent :: OutPoint -> UnspentVal -> Unspent +valToUnspent p UnspentVal { unspentValBlock = b + , unspentValAmount = v + , unspentValScript = s + } = + Unspent + { unspentBlock = b + , unspentPoint = p + , unspentAmount = v + , unspentScript = s + } + +-- | Messages that a 'BlockStore' can accept. +data BlockMessage + = BlockNewBest !BlockNode + -- ^ new block header in chain + | BlockPeerConnect !Peer !SockAddr + -- ^ new peer connected + | BlockPeerDisconnect !Peer !SockAddr + -- ^ peer disconnected + | BlockReceived !Peer !Block + -- ^ new block received from a peer + | BlockNotFound !Peer ![BlockHash] + -- ^ block not found + | BlockTxReceived !Peer !Tx + -- ^ transaction received from peer + | BlockTxAvailable !Peer ![TxHash] + -- ^ peer has transactions available + | BlockPing !(Listen ()) + -- ^ internal housekeeping ping + | PurgeMempool + -- ^ purge mempool transactions + +-- | Events that the store can generate. +data StoreEvent + = StoreBestBlock !BlockHash + -- ^ new best block + | StoreMempoolNew !TxHash + -- ^ new mempool transaction + | StorePeerConnected !Peer !SockAddr + -- ^ new peer connected + | StorePeerDisconnected !Peer !SockAddr + -- ^ peer has disconnected + | StorePeerPong !Peer !Word64 + -- ^ peer responded 'Ping' + | StoreTxAvailable !Peer ![TxHash] + -- ^ peer inv transactions + | StoreTxReject !Peer !TxHash !RejectCode !ByteString + -- ^ peer rejected transaction + | StoreTxDeleted !TxHash + -- ^ transaction deleted from store + | StoreBlockReverted !BlockHash + -- ^ block no longer head of main chain + +data PubExcept + = PubNoPeers + | PubReject RejectCode + | PubTimeout + | PubPeerDisconnected + deriving Eq + +instance Show PubExcept where + show PubNoPeers = "no peers" + show (PubReject c) = + "rejected: " <> + case c of + RejectMalformed -> "malformed" + RejectInvalid -> "invalid" + RejectObsolete -> "obsolete" + RejectDuplicate -> "duplicate" + RejectNonStandard -> "not standard" + RejectDust -> "dust" + RejectInsufficientFee -> "insufficient fee" + RejectCheckpoint -> "checkpoint" + show PubTimeout = "peer timeout or silent rejection" + show PubPeerDisconnected = "peer disconnected" + +instance Exception PubExcept + +applyOffsetLimit :: Monad m => Offset -> Maybe Limit -> ConduitT i i m () +applyOffsetLimit offset limit = applyOffset offset >> applyLimit limit + +applyOffset :: Monad m => Offset -> ConduitT i i m () +applyOffset = dropC . fromIntegral + +applyLimit :: Monad m => Maybe Limit -> ConduitT i i m () +applyLimit Nothing = mapC id +applyLimit (Just l) = takeC (fromIntegral l) diff --git a/src/Network/Haskoin/Store/Logic.hs b/src/Network/Haskoin/Store/Logic.hs --- a/src/Network/Haskoin/Store/Logic.hs +++ b/src/Network/Haskoin/Store/Logic.hs @@ -1,30 +1,58 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} module Network.Haskoin.Store.Logic where -import Conduit -import Control.Monad -import Control.Monad.Except -import Control.Monad.Logger -import qualified Data.ByteString as B -import qualified Data.ByteString.Short as B.Short -import Data.Either (rights) -import qualified Data.IntMap.Strict as I -import Data.List -import Data.Maybe -import Data.Serialize -import Data.String -import Data.String.Conversions (cs) -import Data.Text (Text) -import Data.Word -import Haskoin -import Network.Haskoin.Block.Headers (computeSubsidy) -import Network.Haskoin.Store.Data -import UnliftIO +import Conduit (ConduitT, filterC, mapC, + (.|)) +import Control.Monad (forM, forM_, unless, void, + when, zipWithM_) +import Control.Monad.Except (MonadError, catchError, + throwError) +import Control.Monad.Logger (MonadLogger, logDebugS, + logErrorS, logInfoS, + logWarnS) +import qualified Data.ByteString as B +import qualified Data.ByteString.Short as B.Short +import Data.Either (rights) +import qualified Data.IntMap.Strict as I +import Data.List (nub, partition, sortBy) +import Data.Maybe (fromMaybe, isNothing, + mapMaybe) +import Data.Serialize (encode) +import Data.String (fromString) +import Data.String.Conversions (cs) +import Data.Text (Text) +import Data.Word (Word32, Word64) +import Haskoin (Address, Block (..), + BlockHash, BlockHeader (..), + BlockNode (..), Network (..), + OutPoint (..), Tx (..), + TxHash, TxIn (..), + TxOut (..), addrToString, + blockHashToHex, genesisBlock, + genesisNode, headerHash, + isGenesis, nullOutPoint, + scriptToAddressBS, txHash, + txHashToHex) +import Network.Haskoin.Block.Headers (computeSubsidy) +import Network.Haskoin.Store.Data.Types (Balance (..), BlockData (..), + BlockRef (..), BlockTx (..), + Prev (..), Spender (..), + StoreInput (..), + StoreOutput (..), + StoreRead (..), + StoreStream (..), + StoreWrite (..), + Transaction (..), + TxData (..), UnixTime, + Unspent (..), confirmed, + fromTransaction, isCoinbase, + toTransaction, + transactionData) +import UnliftIO (Exception) data ImportException = PrevBlockNotBest !Text @@ -46,34 +74,22 @@ | InsufficientZeroBalance !Text | InsufficientOutputs !Text | InsufficientFunds !Text - | InitException !InitException | DuplicatePrevOutput !Text deriving (Show, Read, Eq, Ord, Exception) -initDB :: +initBest :: ( StoreRead m , StoreWrite m - , StoreStream m , MonadLogger m , MonadError ImportException m ) => Network -> m () -initDB net = - isInitialized >>= \case - Left e -> do - $(logErrorS) "BlockLogic" $ - "Initialization exception: " <> fromString (show e) - throwError (InitException e) - Right True -> do - $(logDebugS) "BlockLogic" "Database is already initialized" - return () - Right False -> do - $(logDebugS) - "BlockLogic" - "Initializing database by importing genesis block" - importBlock net (genesisBlock net) (genesisNode net) - setInit +initBest net = do + m <- getBestBlock + when + (isNothing m) + (void (importBlock net (genesisBlock net) (genesisNode net))) getOldOrphans :: (Monad m, StoreStream m) => UnixTime -> ConduitT () TxHash m () getOldOrphans now = @@ -88,31 +104,37 @@ => Network -> UnixTime -> Tx - -> m () + -> m (Maybe [TxHash]) -- ^ deleted transactions or nothing if import failed importOrphan net t tx = do $(logDebugS) "Block" $ "Attempting to import orphan tx " <> txHashToHex (txHash tx) go `catchError` ex where go = do - newMempoolTx net tx t >>= \case - True -> - $(logDebugS) "BlockLogic" $ - "Succesfully imported orphan transaction: " <> - txHashToHex (txHash tx) - False -> - $(logDebugS) "BlockLogic" $ - "Orphan transaction already imported: " <> - txHashToHex (txHash tx) + ret <- + newMempoolTx net tx t >>= \case + Just ths -> do + $(logDebugS) "BlockLogic" $ + "Succesfully imported orphan transaction: " <> + txHashToHex (txHash tx) + return (Just ths) + Nothing -> do + $(logDebugS) "BlockLogic" $ + "Orphan transaction already imported: " <> + txHashToHex (txHash tx) + return Nothing deleteOrphanTx (txHash tx) - ex (OrphanTx _) = + return ret + ex (OrphanTx _) = do $(logDebugS) "BlockLogic" $ "Transaction still orphan: " <> txHashToHex (txHash tx) + return Nothing ex e = do $(logErrorS) "BlockLogic" $ "Error importing orphan tx: " <> txHashToHex (txHash tx) <> ": " <> cs (show e) deleteOrphanTx (txHash tx) + return Nothing newMempoolTx :: ( StoreRead m @@ -123,7 +145,7 @@ => Network -> Tx -> UnixTime - -> m Bool + -> m (Maybe [TxHash]) -- ^ deleted transactions or nothing if import failed newMempoolTx net tx w = do $(logInfoS) "BlockLogic" $ "Adding transaction to mempool: " <> txHashToHex (txHash tx) @@ -133,7 +155,7 @@ $(logWarnS) "BlockLogic" $ "Transaction already exists: " <> txHashToHex (txHash tx) - return False + return Nothing _ -> go where go = do @@ -155,8 +177,8 @@ let ds = map spenderHash (mapMaybe outputSpender us) if null ds then do - importTx net (MemRef w) w tx - return True + ths <- importTx net (MemRef w) w tx + return (Just ths) else g ds g ds = do $(logWarnS) "BlockLogic" $ @@ -171,15 +193,15 @@ r ds = do $(logWarnS) "BlockLogic" $ "Replacting RBF transaction with: " <> txHashToHex (txHash tx) - forM_ ds (deleteTx net True) - importTx net (MemRef w) w tx - return True + ths <- concat <$> forM ds (deleteTx net True) + dts <- importTx net (MemRef w) w tx + return (Just (nub (ths <> dts))) n = do $(logWarnS) "BlockLogic" $ "Inserting transaction with deleted flag: " <> txHashToHex (txHash tx) insertDeletedMempoolTx tx w - return False + return Nothing isrbf th = transactionRBF <$> getImportTx th revertBlock :: @@ -190,7 +212,7 @@ ) => Network -> BlockHash - -> m () + -> m [TxHash] revertBlock net bh = do bd <- getBestBlock >>= \case @@ -211,15 +233,15 @@ throwError (BlockNotBest (blockHashToHex bh)) txs <- mapM (fmap transactionData . getImportTx) (blockDataTxs bd) - mapM_ + ths <- nub . concat <$> mapM (deleteTx net False . txHash . snd) (reverse (sortTxs txs)) setBest (prevBlock (blockDataHeader bd)) insertBlock bd {blockDataMainChain = False} + return ths importBlock :: ( StoreRead m - , StoreStream m , StoreWrite m , MonadLogger m , MonadError ImportException m @@ -227,7 +249,7 @@ => Network -> Block -> BlockNode - -> m () + -> m [TxHash] -- ^ deleted transactions importBlock net b n = do mp <- filter (`elem` bths) . map snd <$> getMempool getBestBlock >>= \case @@ -269,16 +291,19 @@ setBlocksAtHeight (nub (headerHash (nodeHeader n) : bs)) (nodeHeight n) setBest (headerHash (nodeHeader n)) $(logDebugS) "Block" "Importing or confirming block transactions..." - mapM_ (uncurry (import_or_confirm mp)) (sortTxs (blockTxns b)) + ths <- + nub . concat <$> + mapM (uncurry (import_or_confirm mp)) (sortTxs (blockTxns b)) $(logDebugS) "Block" $ "Done importing transactions for block " <> blockHashToHex (headerHash (nodeHeader n)) + return ths where bths = map txHash (blockTxns b) import_or_confirm mp x tx = if txHash tx `elem` mp then getTxData (txHash tx) >>= \case - Just td -> confirmTx net td (br x) tx + Just td -> confirmTx net td (br x) tx >> return [] Nothing -> do $(logErrorS) "Block" @@ -327,7 +352,7 @@ -> BlockRef -> Word64 -- ^ unix time -> Tx - -> m () + -> m [TxHash] -- ^ deleted transactions importTx net br tt tx = do when (length (nub (map prevOutput (txIn tx))) < length (txIn tx)) $ do $(logErrorS) "BlockLogic" $ @@ -338,10 +363,12 @@ "Attempting to import coinbase to the mempool: " <> txHashToHex (txHash tx) throwError (UnconfirmedCoinbase (txHashToHex (txHash tx))) - us <- + us' <- if iscb then return [] else forM (txIn tx) $ \TxIn {prevOutput = op} -> uns op + let us = map fst us' + ths = nub (concatMap snd us') when (not (confirmed br) && sum (map unspentAmount us) < sum (map outValue (txOut tx))) $ do @@ -372,10 +399,11 @@ insertTx d updateAddressCounts net (txAddresses t) (+ 1) unless (confirmed br) $ insertIntoMempool (txHash tx) (memRefTime br) + return ths where uns op = getUnspent op >>= \case - Just u -> return u + Just u -> return (u, []) Nothing -> do $(logWarnS) "BlockLogic" $ "No unspent output: " <> txHashToHex (outPointHash op) <> @@ -390,7 +418,7 @@ fromString (show (outPointIndex op)) throwError (NoUnspent (cs (show op))) Just Spender {spenderHash = s} -> do - deleteTx net True s + ths <- deleteTx net True s getUnspent op >>= \case Nothing -> do $(logErrorS) "BlockLogic" $ @@ -399,7 +427,7 @@ " " <> fromString (show (outPointIndex op)) throwError (NoUnspent (cs (show op))) - Just u -> return u + Just u -> return (u, ths) th = txHash tx iscb = all (== nullOutPoint) (map prevOutput (txIn tx)) ws = map Just (txWitness tx) <> repeat Nothing @@ -537,7 +565,7 @@ => Network -> Bool -- ^ only delete transaction if unconfirmed -> TxHash - -> m () + -> m [TxHash] -- ^ deleted transactions deleteTx net mo h = do $(logDebugS) "BlockLogic" $ "Deleting transaction: " <> txHashToHex h getTxData h >>= \case @@ -549,7 +577,7 @@ | txDataDeleted t -> do $(logWarnS) "BlockLogic" $ "Transaction already deleted: " <> txHashToHex h - return () + return [] | mo && confirmed (txDataBlock t) -> do $(logErrorS) "BlockLogic" $ "Will not delete confirmed transaction: " <> txHashToHex h @@ -558,7 +586,7 @@ where go t = do ss <- nub . map spenderHash . I.elems <$> getSpenders h - mapM_ (deleteTx net True) ss + ths <- concat <$> mapM (deleteTx net True) ss forM_ (take (length (txOut (txData t))) [0 ..]) $ \n -> delOutput net (OutPoint h n) let ps = filter (/= nullOutPoint) (map prevOutput (txIn (txData t))) @@ -566,6 +594,7 @@ unless (confirmed (txDataBlock t)) $ deleteFromMempool h insertTx t {txDataDeleted = True} updateAddressCounts net (txDataAddresses t) (subtract 1) + return $ nub (h : ths) insertDeletedMempoolTx :: ( StoreRead m diff --git a/src/Network/Haskoin/Store/Messages.hs b/src/Network/Haskoin/Store/Messages.hs deleted file mode 100644 --- a/src/Network/Haskoin/Store/Messages.hs +++ /dev/null @@ -1,133 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -module Network.Haskoin.Store.Messages where - -import Data.ByteString (ByteString) -import Data.Word -import Database.RocksDB (DB) -import Haskoin -import Haskoin.Node -import Network.Haskoin.Store.Data -import Network.Socket -import NQE -import UnliftIO.Exception -import UnliftIO.STM (TVar) - - --- | Mailbox for block store. -type BlockStore = Mailbox BlockMessage - --- | Store mailboxes. -data Store = - Store - { storeManager :: !Manager - -- ^ peer manager mailbox - , storeChain :: !Chain - -- ^ chain header process mailbox - , storeBlock :: !BlockStore - -- ^ block storage mailbox - } - --- | Configuration for a 'Store'. -data StoreConfig = - StoreConfig - { storeConfMaxPeers :: !Int - -- ^ max peers to connect to - , storeConfInitPeers :: ![HostPort] - -- ^ static set of peers to connect to - , storeConfDiscover :: !Bool - -- ^ discover new peers? - , storeConfDB :: !LayeredDB - -- ^ RocksDB database handler - , storeConfNetwork :: !Network - -- ^ network constants - , storeConfListen :: !(Listen StoreEvent) - -- ^ listen to store events - } - --- | Configuration for a block store. -data BlockConfig = - BlockConfig - { blockConfManager :: !Manager - -- ^ peer manager from running node - , blockConfChain :: !Chain - -- ^ chain from a running node - , blockConfListener :: !(Listen StoreEvent) - -- ^ listener for store events - , blockConfDB :: !LayeredDB - -- ^ RocksDB database handle - , blockConfNet :: !Network - -- ^ network constants - } - --- | Messages that a 'BlockStore' can accept. -data BlockMessage - = BlockNewBest !BlockNode - -- ^ new block header in chain - | BlockPeerConnect !Peer !SockAddr - -- ^ new peer connected - | BlockPeerDisconnect !Peer !SockAddr - -- ^ peer disconnected - | BlockReceived !Peer !Block - -- ^ new block received from a peer - | BlockNotFound !Peer ![BlockHash] - -- ^ block not found - | BlockTxReceived !Peer !Tx - -- ^ transaction received from peer - | BlockTxAvailable !Peer ![TxHash] - -- ^ peer has transactions available - | BlockPing !(Listen ()) - -- ^ internal housekeeping ping - | PurgeMempool - -- ^ purge mempool transactions - --- | Events that the store can generate. -data StoreEvent - = StoreBestBlock !BlockHash - -- ^ new best block - | StoreMempoolNew !TxHash - -- ^ new mempool transaction - | StorePeerConnected !Peer - !SockAddr - -- ^ new peer connected - | StorePeerDisconnected !Peer - !SockAddr - -- ^ peer has disconnected - | StorePeerPong !Peer - !Word64 - -- ^ peer responded 'Ping' - | StoreTxAvailable !Peer - ![TxHash] - -- ^ peer inv transactions - | StoreTxReject !Peer - !TxHash - !RejectCode - !ByteString - -- ^ peer rejected transaction - -data PubExcept - = PubNoPeers - | PubReject RejectCode - | PubTimeout - | PubPeerDisconnected - deriving Eq - -instance Show PubExcept where - show PubNoPeers = "no peers" - show (PubReject c) = - "rejected: " <> - case c of - RejectMalformed -> "malformed" - RejectInvalid -> "invalid" - RejectObsolete -> "obsolete" - RejectDuplicate -> "duplicate" - RejectNonStandard -> "not standard" - RejectDust -> "dust" - RejectInsufficientFee -> "insufficient fee" - RejectCheckpoint -> "checkpoint" - show PubTimeout = "peer timeout or silent rejection" - show PubPeerDisconnected = "peer disconnected" - -instance Exception PubExcept diff --git a/src/Network/Haskoin/Store/Web.hs b/src/Network/Haskoin/Store/Web.hs --- a/src/Network/Haskoin/Store/Web.hs +++ b/src/Network/Haskoin/Store/Web.hs @@ -1,66 +1,128 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} - module Network.Haskoin.Store.Web where -import Conduit hiding (runResourceT) -import Control.Applicative ((<|>)) -import Control.Exception () -import Control.Monad -import Control.Monad.Logger -import Control.Monad.Reader (ReaderT) -import qualified Control.Monad.Reader as R -import Control.Monad.Trans.Maybe -import Data.Aeson (ToJSON (..), object, (.=)) -import Data.Aeson.Encoding (encodingToLazyByteString, - fromEncoding) -import qualified Data.ByteString as B -import Data.ByteString.Builder -import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString.Lazy.Char8 as C -import Data.Char -import Data.Function -import qualified Data.HashMap.Strict as H -import Data.List -import Data.Maybe -import Data.Serialize as Serialize -import Data.String.Conversions -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.Lazy as T.Lazy -import Data.Time.Clock -import Data.Time.Clock.System -import Data.Word -import Database.RocksDB as R -import Haskoin -import Haskoin.Node -import Network.Haskoin.Store.Data -import Network.Haskoin.Store.Data.Cached -import Network.Haskoin.Store.Messages -import Network.HTTP.Types -import Network.Wai -import NQE -import Text.Printf -import Text.Read (readMaybe) -import UnliftIO -import UnliftIO.Resource -import Web.Scotty.Internal.Types (ActionT) -import Web.Scotty.Trans (Parsable, ScottyError) -import qualified Web.Scotty.Trans as S -type WebT m = ActionT Except (ReaderT LayeredDB m) +import Conduit hiding (runResourceT) +import Control.Applicative ((<|>)) +import Control.Monad (forM_, forever, guard, + mzero, unless, when, (<=<)) +import Control.Monad.Logger (Loc, LogLevel, LogSource, + LogStr, LoggingT (..), + MonadLogger, MonadLoggerIO, + askLoggerIO, logInfoS, + monadLoggerLog, + runLoggingT) +import Control.Monad.Reader (ReaderT, ask, runReaderT) +import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) +import Data.Aeson (ToJSON (..), object, (.=)) +import Data.Aeson.Encoding (encodingToLazyByteString, + fromEncoding) +import qualified Data.ByteString as B +import Data.ByteString.Builder (Builder, lazyByteString) +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Char8 as C +import Data.Char (isSpace) +import Data.Function (on) +import qualified Data.HashMap.Strict as H +import Data.List (nub, sortBy) +import Data.Maybe (catMaybes, fromMaybe, + isJust, isNothing, + listToMaybe, mapMaybe) +import Data.Serialize as Serialize +import Data.String.Conversions (cs) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Lazy as T.Lazy +import Data.Time.Clock (NominalDiffTime, + diffUTCTime, + getCurrentTime) +import Data.Time.Clock.System (getSystemTime, + systemSeconds) +import Data.Word (Word32, Word64) +import Database.RocksDB (Property (..), getProperty) +import Haskoin (Address, Block (..), + BlockHash (..), + BlockHeader (..), + BlockHeight, + BlockNode (..), + GetData (..), Hash256, + InvType (..), + InvVector (..), KeyIndex, + Message (..), Network (..), + OutPoint (..), Tx, + TxHash (..), + VarString (..), + Version (..), XPubKey, + decodeHex, deriveAddr, + deriveCompatWitnessAddr, + deriveWitnessAddr, + eitherToMaybe, headerHash, + hexToBlockHash, + hexToTxHash, pubSubKey, + sockToHostAddress, + stringToAddr, txHash, + xPubImport) +import Haskoin.Node (Chain, Manager, + OnlinePeer (..), + chainGetBest, + managerGetPeers, + sendMessage) +import Network.Haskoin.Store.Data.RocksDB (withRocksDB) +import Network.Haskoin.Store.Data.Types (Balance (..), + BinSerial (..), + BlockDB (..), + BlockData (..), + BlockRef (..), + BlockTx (..), Event (..), + HealthCheck (..), + JsonSerial (..), Limit, + Offset, + PeerInformation (..), + PubExcept (..), Store (..), + StoreEvent (..), + StoreInput (..), + StoreRead (..), + StoreStream (..), + Transaction (..), + TxAfterHeight (..), + TxData (..), TxId (..), + UnixTime, Unspent, + XPubBal (..), + XPubSummary (..), + XPubUnspent (..), + applyLimit, + applyOffsetLimit, + blockAtOrBefore, + getTransaction, isCoinbase, + transactionData, + zeroBalance) +import Network.HTTP.Types (Status (..), status400, + status404, status500, + status503) +import Network.Wai (Middleware, Request (..), + responseStatus) +import NQE (Publisher, receive, + withSubscription) +import Text.Printf (printf) +import Text.Read (readMaybe) +import UnliftIO (Exception, TBQueue, + askRunInIO, atomically, + readTBQueue, timeout, + writeTBQueue) +import UnliftIO.Resource (runResourceT) +import Web.Scotty.Internal.Types (ActionT) +import Web.Scotty.Trans (Parsable, ScottyError) +import qualified Web.Scotty.Trans as S -type DeriveAddrs = XPubKey -> KeyIndex -> [(Address, PubKey, KeyIndex)] +type LoggerIO = Loc -> LogSource -> LogLevel -> LogStr -> IO () -type Offset = Word32 -type Limit = Word32 +type WebT m = ActionT Except (ReaderT BlockDB m) +type DeriveAddr = XPubKey -> KeyIndex -> Address + data Except = ThingNotFound | ServerError @@ -110,7 +172,7 @@ WebConfig { webPort :: !Int , webNetwork :: !Network - , webDB :: !LayeredDB + , webDB :: !BlockDB , webPublisher :: !(Publisher StoreEvent) , webStore :: !Store , webMaxLimits :: !MaxLimits @@ -124,7 +186,6 @@ , maxLimitFull :: !Word32 , maxLimitOffset :: !Word32 , maxLimitDefault :: !Word32 - , maxLimitGap :: !Word32 } deriving (Eq, Show) @@ -169,8 +230,7 @@ guard $ x > 1230768000 return StartParamTime {startParamTime = x} -instance MonadIO m => StoreRead (WebT m) where - isInitialized = lift isInitialized +instance MonadLoggerIO m => StoreRead (WebT m) where getBestBlock = lift getBestBlock getBlocksAtHeight = lift . getBlocksAtHeight getBlock = lift . getBlock @@ -180,13 +240,23 @@ getOrphanTx = lift . getOrphanTx getUnspent = lift . getUnspent getBalance = lift . getBalance + getBalances = lift . getBalances getMempool = lift getMempool + getAddressesTxs addrs start limit = + lift (getAddressesTxs addrs start limit) + getAddressesUnspents addrs start limit = + lift (getAddressesUnspents addrs start limit) -askDB :: Monad m => WebT m LayeredDB -askDB = lift R.ask +askDB :: Monad m => WebT m BlockDB +askDB = lift ask -runStream :: MonadUnliftIO m => s -> ReaderT s (ResourceT m) a -> m a -runStream s f = runResourceT (R.runReaderT f s) +runStream :: + MonadUnliftIO m + => LoggerIO + -> s + -> ReaderT s (ResourceT (LoggingT m)) a + -> m a +runStream l s f = runLoggingT (runResourceT (runReaderT f s)) l defHandler :: Monad m => Network -> Except -> WebT m () defHandler net e = do @@ -216,7 +286,8 @@ -> WebT m () protoSerial net proto = S.raw . serialAny net proto -scottyBestBlock :: MonadUnliftIO m => Network -> Bool -> WebT m () +scottyBestBlock :: + (MonadLoggerIO m, MonadUnliftIO m) => Network -> Bool -> WebT m () scottyBestBlock net raw = do setHeaders n <- parseNoTx @@ -233,7 +304,8 @@ then rawBlock b >>= protoSerial net proto else protoSerial net proto (pruneTx n b) -scottyBlock :: MonadUnliftIO m => Network -> Bool -> WebT m () +scottyBlock :: + (MonadLoggerIO m, MonadUnliftIO m) => Network -> Bool -> WebT m () scottyBlock net raw = do setHeaders block <- myBlockHash <$> S.param "block" @@ -256,14 +328,15 @@ proto <- setupBin hs <- getBlocksAtHeight height db <- askDB + l <- askLoggerIO if raw then S.stream $ \io flush' -> do - runStream db . runConduit $ + runStream l db . runConduit $ yieldMany hs .| concatMapMC getBlock .| mapMC rawBlock .| streamAny net proto io flush' else S.stream $ \io flush' -> do - runStream db . runConduit $ + runStream l db . runConduit $ yieldMany hs .| concatMapMC getBlock .| mapC (pruneTx n) .| streamAny net proto io flush' @@ -290,8 +363,9 @@ n <- parseNoTx proto <- setupBin db <- askDB + l <- askLoggerIO S.stream $ \io flush' -> do - runStream db . runConduit $ + runStream l db . runConduit $ yieldMany (nub heights) .| concatMapMC getBlocksAtHeight .| concatMapMC getBlock .| mapC (pruneTx n) .| @@ -304,10 +378,12 @@ n <- parseNoTx proto <- setupBin db <- askDB + l <- askLoggerIO getBestBlock >>= \case Just h -> S.stream $ \io flush' -> do - runStream db . runConduit $ f n h 100 .| streamAny net proto io + runStream l db . runConduit $ + f n h 100 .| streamAny net proto io flush' Nothing -> S.raise ThingNotFound where @@ -334,8 +410,9 @@ n <- parseNoTx proto <- setupBin db <- askDB + l <- askLoggerIO S.stream $ \io flush' -> do - runStream db . runConduit $ + runStream l db . runConduit $ yieldMany (nub blocks) .| concatMapMC getBlock .| mapC (pruneTx n) .| streamAny net proto io flush' @@ -378,8 +455,9 @@ txids <- map myTxHash <$> S.param "txids" proto <- setupBin db <- askDB + l <- askLoggerIO S.stream $ \io flush' -> do - runStream db . runConduit $ + runStream l db . runConduit $ yieldMany (nub txids) .| concatMapMC getTransaction .| streamAny net proto io flush' @@ -391,10 +469,11 @@ h <- myBlockHash <$> S.param "block" proto <- setupBin db <- askDB + l <- askLoggerIO getBlock h >>= \case Just b -> S.stream $ \io flush' -> do - runStream db . runConduit $ + runStream l db . runConduit $ yieldMany (blockDataTxs b) .| concatMapMC getTransaction .| streamAny net proto io flush' @@ -407,8 +486,9 @@ txids <- map myTxHash <$> S.param "txids" proto <- setupBin db <- askDB + l <- askLoggerIO S.stream $ \io flush' -> do - runStream db . runConduit $ + runStream l db . runConduit $ yieldMany (nub txids) .| concatMapMC getTransaction .| mapC transactionData .| streamAny net proto io @@ -431,10 +511,11 @@ h <- myBlockHash <$> S.param "block" proto <- setupBin db <- askDB + l <- askLoggerIO getBlock h >>= \case Just b -> S.stream $ \io flush' -> do - runStream db . runConduit $ + runStream l db . runConduit $ yieldMany (blockDataTxs b) .| concatMapMC getTransaction .| mapC transactionData .| streamAny net proto io @@ -455,8 +536,9 @@ l <- getLimit limits full proto <- setupBin db <- askDB + lg <- askLoggerIO S.stream $ \io flush' -> do - runStream db . runConduit $ f proto o l s a io + runStream lg db . runConduit $ f proto o l s a io flush' where f proto o l s a io @@ -476,8 +558,9 @@ l <- getLimit limits full proto <- setupBin db <- askDB + lg <- askLoggerIO S.stream $ \io flush' -> do - runStream db . runConduit $ f proto l s as io + runStream lg db . runConduit $ f proto l s as io flush' where f proto l s as io @@ -494,8 +577,9 @@ l <- getLimit limits False proto <- setupBin db <- askDB + lg <- askLoggerIO S.stream $ \io flush' -> do - runStream db . runConduit $ + runStream lg db . runConduit $ getAddressUnspentsLimit o l s a .| streamAny net proto io flush' @@ -508,8 +592,9 @@ l <- getLimit limits False proto <- setupBin db <- askDB + lg <- askLoggerIO S.stream $ \io flush' -> do - runStream db . runConduit $ + runStream lg db . runConduit $ getAddressesUnspentsLimit l s as .| streamAny net proto io flush' @@ -518,19 +603,7 @@ setHeaders a <- parseAddress net proto <- setupBin - res <- - getBalance a >>= \case - Just b -> return b - Nothing -> - return - Balance - { balanceAddress = a - , balanceAmount = 0 - , balanceUnspentCount = 0 - , balanceZero = 0 - , balanceTxCount = 0 - , balanceTotalReceived = 0 - } + res <- fromMaybe (zeroBalance a) <$> getBalance a protoSerial net proto res scottyAddressesBalances :: @@ -539,38 +612,23 @@ setHeaders as <- parseAddresses net proto <- setupBin - let f a Nothing = - Balance - { balanceAddress = a - , balanceAmount = 0 - , balanceUnspentCount = 0 - , balanceZero = 0 - , balanceTxCount = 0 - , balanceTotalReceived = 0 - } - f _ (Just b) = b - db <- askDB - S.stream $ \io flush' -> do - runStream db . runConduit $ - yieldMany as .| mapMC (\a -> f a <$> getBalance a) .| - streamAny net proto io - flush' + res <- zipWith f as <$> getBalances as + protoSerial net proto res + where + f a Nothing = zeroBalance a + f _ (Just b) = b scottyXpubBalances :: (MonadUnliftIO m, MonadLoggerIO m) => Network - -> MaxLimits -> WebT m () -scottyXpubBalances net max_limits = do +scottyXpubBalances net = do setHeaders xpub <- parseXpub net proto <- setupBin derive <- parseDeriveAddrs net - db <- askDB - S.stream $ \io flush' -> do - runStream db . runConduit $ - xpubBals max_limits derive xpub .| streamAny net proto io - flush' + res <- lift (xpubBals derive xpub) + protoSerial net proto res scottyXpubTxs :: (MonadLoggerIO m, MonadUnliftIO m) @@ -586,45 +644,31 @@ derive <- parseDeriveAddrs net proto <- setupBin db <- askDB + lg <- askLoggerIO S.stream $ \io flush' -> do - runStream db . runConduit $ f proto l s derive io x + runStream lg db . runConduit $ f proto l s derive io x flush' where f proto l s derive io x | full = - xpubTxs limits s l derive x .| + xpubTxs s l derive x .| concatMapMC (getTransaction . blockTxHash) .| streamAny net proto io - | otherwise = xpubTxs limits s l derive x .| streamAny net proto io + | otherwise = xpubTxs s l derive x .| streamAny net proto io xpubTxs :: - (Monad m, StoreRead m, StoreStream m) - => MaxLimits - -> Maybe BlockRef + (MonadUnliftIO m, StoreRead m, StoreStream m) + => Maybe BlockRef -> Maybe Limit - -> DeriveAddrs + -> DeriveAddr -> XPubKey -> ConduitT i BlockTx m () -xpubTxs max_limits start limit derive xpub = do - ts <- - fmap (nub . sortBy (flip compare `on` blockTxBlock)) $ - (go 0 >> go 1) .| sinkList - forM_ ts yield .| applyLimit limit - where - go m = yieldMany (addrs m) .| txs .| gap - addrs m = map (\(a, _, _) -> a) (derive (pubSubKey xpub m) 0) - txs = - awaitForever $ \a -> do - ts <- getAddressTxs a start .| applyLimit limit .| sinkList - yield ts - gap = - let r 0 = return () - r i = - await >>= \case - Nothing -> return () - Just [] -> r (i - 1) - Just xs -> yieldMany xs >> r (maxLimitGap max_limits) - in r (maxLimitGap max_limits) +xpubTxs start limit derive xpub = do + bs <- lift (xpubBals derive xpub) + let as = map (balanceAddress . xPubBal) bs + ts <- mapM_ (\a -> getAddressTxs a start .| applyLimit limit) as .| sinkList + let ts' = nub $ sortBy (flip compare `on` blockTxBlock) ts + forM_ ts' yield .| applyLimit limit scottyXpubUnspents :: (MonadLoggerIO m, MonadUnliftIO m) => Network -> MaxLimits -> WebT m () @@ -636,20 +680,22 @@ l <- getLimit limits False derive <- parseDeriveAddrs net db <- askDB + lg <- askLoggerIO S.stream $ \io flush' -> do - runStream db . runConduit $ - xpubUnspentLimit net limits l s derive x .| streamAny net proto io + runStream lg db . runConduit $ + xpubUnspentLimit l s derive x .| streamAny net proto io flush' scottyXpubSummary :: - (MonadLoggerIO m, MonadUnliftIO m) => Network -> MaxLimits -> WebT m () -scottyXpubSummary net max_limits = do + (MonadLoggerIO m, MonadUnliftIO m) => Network -> WebT m () +scottyXpubSummary net = do setHeaders x <- parseXpub net derive <- parseDeriveAddrs net proto <- setupBin db <- askDB - res <- liftIO . runStream db $ xpubSummary max_limits derive x + lg <- askLoggerIO + res <- liftIO . runStream lg db $ xpubSummary derive x protoSerial net proto res scottyPostTx :: @@ -683,7 +729,7 @@ scottyDbStats :: MonadLoggerIO m => WebT m () scottyDbStats = do setHeaders - LayeredDB {layeredDB = BlockDB {blockDB = db}} <- askDB + BlockDB {blockDB = db} <- askDB stats <- lift (getProperty db Stats) case stats of Nothing -> do @@ -705,10 +751,11 @@ flush' >> receive sub >>= \se -> do let me = case se of - StoreBestBlock block_hash -> - Just (EventBlock block_hash) - StoreMempoolNew tx_hash -> Just (EventTx tx_hash) - _ -> Nothing + StoreBestBlock b -> Just (EventBlock b) + StoreMempoolNew t -> Just (EventTx t) + StoreTxDeleted t -> Just (EventTx t) + StoreBlockReverted b -> Just (EventBlock b) + _ -> Nothing case me of Nothing -> return () Just e -> @@ -736,14 +783,15 @@ setHeaders proto <- setupBin db <- askDB + lg <- askLoggerIO h <- - liftIO . runStream db $ + liftIO . runStream lg db $ healthCheck net (storeManager st) (storeChain st) tos when (not (healthOK h) || not (healthSynced h)) $ S.status status503 protoSerial net proto h runWeb :: (MonadLoggerIO m, MonadUnliftIO m) => WebConfig -> m () -runWeb WebConfig { webDB = db +runWeb WebConfig { webDB = bdb , webPort = port , webNetwork = net , webStore = st @@ -757,7 +805,7 @@ then Just <$> logIt else return Nothing runner <- askRunInIO - S.scottyT port (runner . withLayeredDB db) $ do + S.scottyT port (runner . withRocksDB bdb) $ do case req_logger of Just m -> S.middleware m Nothing -> return () @@ -791,11 +839,11 @@ S.get "/address/unspent" $ scottyAddressesUnspent net limits S.get "/address/:address/balance" $ scottyAddressBalance net S.get "/address/balances" $ scottyAddressesBalances net - S.get "/xpub/:xpub/balances" $ scottyXpubBalances net limits + S.get "/xpub/:xpub/balances" $ scottyXpubBalances net S.get "/xpub/:xpub/transactions" $ scottyXpubTxs net limits False S.get "/xpub/:xpub/transactions/full" $ scottyXpubTxs net limits True S.get "/xpub/:xpub/unspent" $ scottyXpubUnspents net limits - S.get "/xpub/:xpub" $ scottyXpubSummary net limits + S.get "/xpub/:xpub" $ scottyXpubSummary net S.post "/transactions" $ scottyPostTx net st pub S.get "/dbstats" scottyDbStats S.get "/events" $ scottyEvents net pub @@ -803,7 +851,7 @@ S.get "/health" $ scottyHealth net st tos S.notFound $ S.raise ThingNotFound -getStart :: MonadUnliftIO m => WebT m (Maybe BlockRef) +getStart :: (MonadLoggerIO m, MonadUnliftIO m) => WebT m (Maybe BlockRef) getStart = runMaybeT $ do s <- MaybeT $ (Just <$> S.param "height") `S.rescue` const (return Nothing) @@ -884,15 +932,15 @@ Nothing -> S.next Just x -> return x -parseDeriveAddrs :: (Monad m, ScottyError e) => Network -> ActionT e m DeriveAddrs +parseDeriveAddrs :: (Monad m, ScottyError e) => Network -> ActionT e m DeriveAddr parseDeriveAddrs net | getSegWit net = do t <- S.param "derive" `S.rescue` const (return "standard") return $ case (t :: Text) of - "segwit" -> deriveWitnessAddrs - "compat" -> deriveCompatWitnessAddrs - _ -> deriveAddrs - | otherwise = return deriveAddrs + "segwit" -> \i -> fst . deriveWitnessAddr i + "compat" -> \i -> fst . deriveCompatWitnessAddr i + _ -> \i -> fst . deriveAddr i + | otherwise = return (\i -> fst . deriveAddr i) parseNoTx :: (Monad m, ScottyError e) => ActionT e m Bool parseNoTx = S.param "notx" `S.rescue` const (return False) @@ -976,7 +1024,8 @@ td = tx_time_delta tm bd ml lk = timeout_ok (blockTimeout tos) bd tk = timeout_ok (txTimeout tos) td - ok = ck && bk && pk && lk && tk + sy = in_sync bb cb + ok = ck && bk && pk && lk && (tk || not sy) return HealthCheck { healthBlockBest = block_hash <$> bb @@ -986,7 +1035,7 @@ , healthPeers = pc , healthNetwork = getNetworkName net , healthOK = ok - , healthSynced = in_sync bb cb + , healthSynced = sy , healthLastBlock = bd , healthLastTx = td } @@ -1038,36 +1087,36 @@ return PeerInformation { peerUserAgent = ua - , peerAddress = as + , peerAddress = sockToHostAddress as , peerVersion = vs , peerServices = sv , peerRelay = rl } +deriveAddresses :: DeriveAddr -> XPubKey -> Word32 -> [(Word32, Address)] +deriveAddresses derive xpub start = map (\i -> (i, derive xpub i)) [start ..] + xpubBals :: - (MonadResource m, MonadUnliftIO m, StoreRead m) - => MaxLimits - -> DeriveAddrs + (MonadUnliftIO m, StoreRead m) + => DeriveAddr -> XPubKey - -> ConduitT i XPubBal m () -xpubBals limits derive xpub = go 0 >> go 1 + -> m [XPubBal] +xpubBals derive xpub = do + ext <- derive_until_gap 0 (deriveAddresses derive (pubSubKey xpub 0) 0) + chg <- derive_until_gap 1 (deriveAddresses derive (pubSubKey xpub 1) 0) + return (ext ++ chg) where - go m = - yieldMany (addrs m) .| mapMC (uncurry bal) .| gap (maxLimitGap limits) - bal a p = - getBalance a >>= \case - Nothing -> return Nothing - Just b' -> return $ Just XPubBal {xPubBalPath = p, xPubBal = b'} - addrs m = - map (\(a, _, n') -> (a, [m, n'])) (derive (pubSubKey xpub m) 0) - gap n = - let r 0 = return () - r i = - await >>= \case - Just (Just b) -> yield b >> r n - Just Nothing -> r (i - 1) - Nothing -> return () - in r n + xbalance _ Nothing _ = Nothing + xbalance m (Just b) n = Just XPubBal {xPubBalPath = [m, n], xPubBal = b} + derive_until_gap _ [] = return [] + derive_until_gap m as = do + let n = 32 + let (as1, as2) = splitAt n as + mbs <- getBalances (map snd as1) + let xbs = zipWith (xbalance m) mbs (map fst as1) + if all isNothing mbs + then return (catMaybes xbs) + else (catMaybes xbs <>) <$> derive_until_gap m as2 xpubUnspent :: ( MonadResource m @@ -1075,18 +1124,20 @@ , StoreStream m , StoreRead m ) - => Network - -> MaxLimits - -> Maybe BlockRef - -> DeriveAddrs + => Maybe BlockRef + -> DeriveAddr -> XPubKey -> ConduitT i XPubUnspent m () -xpubUnspent _net max_limits start derive xpub = - xpubBals max_limits derive xpub .| go +xpubUnspent start derive xpub = do + xs <- filter positive <$> lift (xpubBals derive xpub) + yieldMany xs .| go where + positive XPubBal {xPubBal = Balance {balanceUnspentCount = c}} = c > 0 go = - awaitForever $ \XPubBal {xPubBalPath = p, xPubBal = b} -> - getAddressUnspents (balanceAddress b) start .| + awaitForever $ \XPubBal { xPubBalPath = p + , xPubBal = Balance {balanceAddress = a} + } -> + getAddressUnspents a start .| mapC (\t -> XPubUnspent {xPubUnspentPath = p, xPubUnspent = t}) xpubUnspentLimit :: @@ -1095,24 +1146,21 @@ , StoreStream m , StoreRead m ) - => Network - -> MaxLimits - -> Maybe Limit + => Maybe Limit -> Maybe BlockRef - -> DeriveAddrs + -> DeriveAddr -> XPubKey -> ConduitT i XPubUnspent m () -xpubUnspentLimit net max_limits limit start derive xpub = - xpubUnspent net max_limits start derive xpub .| applyLimit limit +xpubUnspentLimit limit start derive xpub = + xpubUnspent start derive xpub .| applyLimit limit xpubSummary :: (MonadResource m, MonadUnliftIO m, StoreStream m, StoreRead m) - => MaxLimits - -> DeriveAddrs + => DeriveAddr -> XPubKey -> m XPubSummary -xpubSummary max_limits derive x = do - bs <- runConduit $ xpubBals max_limits derive x .| sinkList +xpubSummary derive x = do + bs <- xpubBals derive x let f XPubBal {xPubBalPath = p, xPubBal = Balance {balanceAddress = a}} = (a, p) pm = H.fromList $ map f bs @@ -1204,18 +1252,14 @@ concatMapMC (getTransaction . blockTxHash) getAddressesTxsLimit :: - (MonadResource m, MonadUnliftIO m, StoreStream m) + (MonadUnliftIO m, StoreRead m) => Maybe Limit -> Maybe BlockRef -> [Address] -> ConduitT i BlockTx m () getAddressesTxsLimit limit start addrs = do - ts <- - fmap (nub . sortBy (flip compare `on` blockTxBlock)) $ - get_txs .| sinkList - forM_ ts yield .| applyLimit limit - where - get_txs = mapM_ (\a -> getAddressTxs a start .| applyLimit limit) addrs + ts <- lift (getAddressesTxs addrs start limit) + forM_ ts yield getAddressesTxsFull :: (MonadResource m, MonadUnliftIO m, StoreStream m, StoreRead m) @@ -1238,28 +1282,14 @@ getAddressUnspents addr start .| applyOffsetLimit offset limit getAddressesUnspentsLimit :: - (Monad m, StoreStream m) + (Monad m, StoreRead m) => Maybe Limit -> Maybe BlockRef -> [Address] -> ConduitT i Unspent m () getAddressesUnspentsLimit limit start addrs = do - uns <- - fmap (nub . sortBy (flip compare `on` unspentBlock)) $ - get_uns .| sinkList - forM_ uns yield .| applyLimit limit - where - get_uns = mapM_ (\a -> getAddressUnspents a start .| applyLimit limit) addrs - -applyOffsetLimit :: Monad m => Offset -> Maybe Limit -> ConduitT i i m () -applyOffsetLimit offset limit = applyOffset offset >> applyLimit limit - -applyOffset :: Monad m => Offset -> ConduitT i i m () -applyOffset = dropC . fromIntegral - -applyLimit :: Monad m => Maybe Limit -> ConduitT i i m () -applyLimit Nothing = mapC id -applyLimit (Just l) = takeC (fromIntegral l) + uns <- lift (getAddressesUnspents addrs start limit) + forM_ uns yield conduitToQueue :: MonadIO m => TBQueue (Maybe a) -> ConduitT a Void m () conduitToQueue q = @@ -1357,7 +1387,8 @@ in T.decodeUtf8 $ m <> " " <> p <> q <> " " <> cs (show v) fmtDiff :: NominalDiffTime -> Text -fmtDiff d = cs (printf "%0.3f" (realToFrac (d * 1000) :: Double) :: String) <> " ms" +fmtDiff d = + cs (printf "%0.3f" (realToFrac (d * 1000) :: Double) :: String) <> " ms" fmtStatus :: Status -> Text fmtStatus s = cs (show (statusCode s)) <> " " <> cs (statusMessage s) diff --git a/test/Haskoin/StoreSpec.hs b/test/Haskoin/StoreSpec.hs --- a/test/Haskoin/StoreSpec.hs +++ b/test/Haskoin/StoreSpec.hs @@ -8,8 +8,7 @@ import Control.Monad.Logger import Control.Monad.Trans import Data.Maybe -import Database.RocksDB (DB) -import Database.RocksDB as R +import Database.RocksDB import Haskoin import Haskoin.Node import Haskoin.Store @@ -18,7 +17,7 @@ import UnliftIO data TestStore = TestStore - { testStoreDB :: !LayeredDB + { testStoreDB :: !BlockDB , testStoreBlockStore :: !BlockStore , testStoreChain :: !Chain , testStoreEvents :: !(Inbox StoreEvent) @@ -42,7 +41,7 @@ bestHeight `shouldBe` 8 it "get a block and its transactions" $ withTestStore net "get-block-txs" $ \TestStore {..} -> - withLayeredDB testStoreDB $ do + withRocksDB testStoreDB $ do let h1 = "e8588129e146eeb0aa7abdc3590f8c5920cc5ff42daf05c23b29d4ae5b51fc22" h2 = @@ -83,21 +82,13 @@ , errorIfExists = True , compression = SnappyCompression } - let ldb = - LayeredDB - { layeredDB = - BlockDB - { blockDB = db - , blockDBopts = defaultReadOptions - } - , layeredCache = Nothing - } + let bdb = BlockDB {blockDB = db, blockDBopts = defaultReadOptions} let cfg = StoreConfig { storeConfMaxPeers = 20 , storeConfInitPeers = [] , storeConfDiscover = True - , storeConfDB = ldb + , storeConfDB = bdb , storeConfNetwork = net , storeConfListen = (`sendSTM` x) } @@ -105,7 +96,7 @@ lift $ f TestStore - { testStoreDB = ldb + { testStoreDB = bdb , testStoreBlockStore = storeBlock , testStoreChain = storeChain , testStoreEvents = x diff --git a/test/Network/Haskoin/Store/Data/TypesSpec.hs b/test/Network/Haskoin/Store/Data/TypesSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/Haskoin/Store/Data/TypesSpec.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE OverloadedStrings #-} +module Network.Haskoin.Store.Data.TypesSpec + ( spec + ) where + +import Data.Serialize (runGet, runPut) +import Data.Text (Text) +import qualified Data.Text as T () +import Haskoin (Address, Network, + TxHash (TxHash), btc, + stringToAddr) +import Network.Haskoin.Store.Data.Types (BinSerial (..)) +import NQE () +import Test.Hspec (Expectation, Spec, describe, + it, shouldBe) + +spec :: Spec +spec = do + let net = btc + describe "Transaction hash serialisation" $ do + it "tx hash serialisation identity" $ + let tx = + TxHash + "0666939fb16533c8e5ebaf6052bb8c90d27ee53fe6035bb763de5253e0b1cd44" + in testSerial net tx + describe "Address serialisation" $ do + it "address serialisation identity" $ + let Just addr = + stringToAddr net "1DtDAYYTWRoiXvHRjARwVhjCUnNTk1XfXw" + in testSerial net addr + it "address list serialisation identity" $ + let expected = + toAddrList + net + [ "1DtDAYYTWRoiXvHRjARwVhjCUnNTk1XfXw" + , "1GhnssnwRZwWKbHQXJRFpQfkfvE6hDG2KF" + ] + in testSerial net expected + +toAddrList :: Network -> [Text] -> [Address] +toAddrList net = map (\t -> let Just a = stringToAddr net t in a) + +testSerial :: (Eq a, Show a, BinSerial a) => Network -> a -> Expectation +testSerial net input = + let raw = runPut $ binSerial net input + deser = runGet (binDeserial net) raw + in deser `shouldBe` Right input diff --git a/test/Network/Haskoin/Store/DataSpec.hs b/test/Network/Haskoin/Store/DataSpec.hs deleted file mode 100644 --- a/test/Network/Haskoin/Store/DataSpec.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Network.Haskoin.Store.DataSpec - ( spec - ) where - -import Control.Monad -import Control.Monad.Logger -import Control.Monad.Trans -import Data.Either -import Data.Maybe -import Data.Serialize -import qualified Data.Text as T -import Haskoin -import Haskoin.Node -import Haskoin.Store -import NQE -import Test.Hspec - -spec :: Spec -spec = do - let net = btc - - describe "Test TxHash serialization" $ - it "serializes tx" $ do - let tx = TxHash "0666939fb16533c8e5ebaf6052bb8c90d27ee53fe6035bb763de5253e0b1cd44" - testSerial net tx - - describe "Test Address serialization" $ - it "serialize address" $ do - let addr = fromJust $ stringToAddr net "1DtDAYYTWRoiXvHRjARwVhjCUnNTk1XfXw" - testSerial net addr - - describe "Test serialization of a list of addresses" $ - it "serialize addresses" $ do - let addr1 = fromJust $ stringToAddr net "1DtDAYYTWRoiXvHRjARwVhjCUnNTk1XfXw" - addr2 = fromJust $ stringToAddr net "1GhnssnwRZwWKbHQXJRFpQfkfvE6hDG2KF" - expected = toAddrList net ["1DtDAYYTWRoiXvHRjARwVhjCUnNTk1XfXw", "1GhnssnwRZwWKbHQXJRFpQfkfvE6hDG2KF"] - testSerial net expected - -toAddrList :: Network -> [T.Text] -> [Address] -toAddrList net = map (fromJust . stringToAddr net) - -testSerial :: (Eq a, Show a, BinSerial a) => Network -> a -> Expectation -testSerial net input = - let raw = runPut $ binSerial net input - deser = runGet (binDeserial net) raw - in deser `shouldBe` Right input