haskoin-store 0.19.5 → 0.20.0
raw patch · 19 files changed
+2368/−2262 lines, 19 filesdep +QuickCheckdep +deepseqdep ~haskoin-coredep ~haskoin-nodedep ~rocksdb-query
Dependencies added: QuickCheck, deepseq
Dependency ranges changed: haskoin-core, haskoin-node, rocksdb-query
Files
- CHANGELOG.md +26/−1
- README.md +1/−1
- app/Main.hs +39/−98
- haskoin-store.cabal +33/−20
- src/Haskoin/Store.hs +83/−52
- src/Network/Haskoin/Store/Block.hs +127/−53
- src/Network/Haskoin/Store/Data.hs +0/−1192
- src/Network/Haskoin/Store/Data/Cached.hs +0/−189
- src/Network/Haskoin/Store/Data/ImportDB.hs +70/−77
- src/Network/Haskoin/Store/Data/KeyValue.hs +30/−10
- src/Network/Haskoin/Store/Data/Memory.hs +60/−34
- src/Network/Haskoin/Store/Data/RocksDB.hs +146/−40
- src/Network/Haskoin/Store/Data/Types.hs +1341/−0
- src/Network/Haskoin/Store/Logic.hs +100/−71
- src/Network/Haskoin/Store/Messages.hs +0/−133
- src/Network/Haskoin/Store/Web.hs +259/−228
- test/Haskoin/StoreSpec.hs +6/−15
- test/Network/Haskoin/Store/Data/TypesSpec.hs +47/−0
- test/Network/Haskoin/Store/DataSpec.hs +0/−48
CHANGELOG.md view
@@ -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
README.md view
@@ -32,4 +32,4 @@ ## API Documentation -* [Swagger API Documentation](https://btc.haskoin.com/).+* [Swagger API Documentation](https://api.haskoin.com/).
app/Main.hs view
@@ -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")
haskoin-store.cabal view
@@ -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
src/Haskoin/Store.hs view
@@ -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 }
src/Network/Haskoin/Store/Block.hs view
@@ -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
− src/Network/Haskoin/Store/Data.hs
@@ -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- }
− src/Network/Haskoin/Store/Data/Cached.hs
@@ -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
src/Network/Haskoin/Store/Data/ImportDB.hs view
@@ -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
src/Network/Haskoin/Store/Data/KeyValue.hs view
@@ -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 =
src/Network/Haskoin/Store/Data/Memory.hs view
@@ -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)
src/Network/Haskoin/Store/Data/RocksDB.hs view
@@ -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
+ src/Network/Haskoin/Store/Data/Types.hs view
@@ -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)
src/Network/Haskoin/Store/Logic.hs view
@@ -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
− src/Network/Haskoin/Store/Messages.hs
@@ -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
src/Network/Haskoin/Store/Web.hs view
@@ -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)
test/Haskoin/StoreSpec.hs view
@@ -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
+ test/Network/Haskoin/Store/Data/TypesSpec.hs view
@@ -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
− test/Network/Haskoin/Store/DataSpec.hs
@@ -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