haskoin-store 0.21.7 → 0.22.0
raw patch · 29 files changed
+6885/−6888 lines, 29 filesdep ~haskoin-nodedep ~hedis
Dependency ranges changed: haskoin-node, hedis
Files
- CHANGELOG.md +13/−0
- app/Main.hs +66/−105
- haskoin-store.cabal +24/−26
- src/Haskoin/Store.hs +60/−218
- src/Haskoin/Store/BlockStore.hs +513/−0
- src/Haskoin/Store/Cache.hs +970/−0
- src/Haskoin/Store/Common.hs +1387/−0
- src/Haskoin/Store/Database/Memory.hs +392/−0
- src/Haskoin/Store/Database/Reader.hs +237/−0
- src/Haskoin/Store/Database/Types.hs +464/−0
- src/Haskoin/Store/Database/Writer.hs +356/−0
- src/Haskoin/Store/Logic.hs +902/−0
- src/Haskoin/Store/Manager.hs +221/−0
- src/Haskoin/Store/Web.hs +1178/−0
- src/Network/Haskoin/Store/BlockStore.hs +0/−537
- src/Network/Haskoin/Store/CacheWriter.hs +0/−568
- src/Network/Haskoin/Store/Common.hs +0/−1472
- src/Network/Haskoin/Store/Data/CacheReader.hs +0/−331
- src/Network/Haskoin/Store/Data/DatabaseReader.hs +0/−266
- src/Network/Haskoin/Store/Data/DatabaseWriter.hs +0/−376
- src/Network/Haskoin/Store/Data/MemoryDatabase.hs +0/−403
- src/Network/Haskoin/Store/Data/Types.hs +0/−360
- src/Network/Haskoin/Store/Logic.hs +0/−904
- src/Network/Haskoin/Store/Web.hs +0/−1203
- test/Haskoin/Store/CacheSpec.hs +35/−0
- test/Haskoin/Store/CommonSpec.hs +61/−0
- test/Haskoin/StoreSpec.hs +6/−20
- test/Network/Haskoin/Store/CommonSpec.hs +0/−62
- test/Network/Haskoin/Store/Data/CacheReaderSpec.hs +0/−37
CHANGELOG.md view
@@ -4,6 +4,19 @@ 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.22.0+### Changed+- Extreme code refactoring.+- Move all code to Haskoin and drop Network from modules.++### Added+- Use Redis pipelining when importing multiple transactions into cache.+- Implement configurable LRU for Redis cache.+- Import xpubs directly into cache from web worker thread when a key is requested.++### Removed+- Only expose a few modules to external API.+ ## 0.21.7 ### Changed - Improve build configuration.
app/Main.hs view
@@ -9,22 +9,17 @@ import Control.Monad (when) import Control.Monad.Logger (LogLevel (..), filterLogger, logInfoS, runStderrLoggingT)+import Data.Default (def) import Data.List (intercalate) import Data.Maybe (fromMaybe) import Data.String.Conversions (cs) import Data.Version (showVersion)-import Database.Redis (defaultConnectInfo, parseConnectInfo,- withCheckedConnect) import Haskoin (Network (..), allNets, bch, bchRegTest, bchTest, btc, btcRegTest, btcTest)-import Haskoin.Node (Host, Port)-import Haskoin.Store (CacheReaderConfig (..),- MaxLimits (..), StoreConfig (..),- Timeouts (..), WebConfig (..),- connectRocksDB, runWeb, withStore)-import NQE (inboxToMailbox, newInbox,- withPublisher)+import Haskoin.Store (StoreConfig (..), WebConfig (..),+ WebLimits (..), WebTimeouts (..),+ runWeb, withStore) import Options.Applicative (Parser, auto, eitherReader, execParser, fullDesc, header, help, helper, info, long, many, metavar,@@ -35,24 +30,25 @@ import System.FilePath ((</>)) import System.IO.Unsafe (unsafePerformIO) import Text.Read (readMaybe)-import UnliftIO (MonadUnliftIO, liftIO, withRunInIO)+import UnliftIO (MonadUnliftIO, liftIO) import UnliftIO.Directory (createDirectoryIfMissing, getAppUserDataDirectory) data Config = Config- { configDir :: !FilePath- , configPort :: !Int- , configNetwork :: !Network- , configDiscover :: !Bool- , configPeers :: ![(Host, Maybe Port)]- , configVersion :: !Bool- , configDebug :: !Bool- , configReqLog :: !Bool- , configMaxLimits :: !MaxLimits- , configTimeouts :: !Timeouts- , configRedis :: !Bool- , configRedisURL :: !String- , configRedisMin :: !Int+ { configDir :: !FilePath+ , configPort :: !Int+ , configNetwork :: !Network+ , configDiscover :: !Bool+ , configPeers :: ![(String, Maybe Int)]+ , configVersion :: !Bool+ , configDebug :: !Bool+ , configReqLog :: !Bool+ , configWebLimits :: !WebLimits+ , configWebTimeouts :: !WebTimeouts+ , configRedis :: !Bool+ , configRedisURL :: !String+ , configRedisMin :: !Int+ , configRedisMax :: !Integer } defPort :: Int@@ -64,22 +60,12 @@ netNames :: String netNames = intercalate "|" (map getNetworkName allNets) -defMaxLimits :: MaxLimits-defMaxLimits =- MaxLimits- { maxLimitCount = 20000- , maxLimitFull = 5000- , maxLimitOffset = 50000- , maxLimitDefault = 2000- , maxLimitGap = 32- }--defTimeouts :: Timeouts-defTimeouts = Timeouts {blockTimeout = 7200, txTimeout = 600}- defRedisMin :: Int defRedisMin = 100 +defRedisMax :: Integer+defRedisMax = 100 * 1000 * 1000+ config :: Parser Config config = do configDir <-@@ -111,42 +97,42 @@ metavar "MAXLIMIT" <> long "maxlimit" <> help "Max limit for listings (0 for no limit)" <> showDefault <>- value (maxLimitCount defMaxLimits)+ value (maxLimitCount def) maxLimitFull <- option auto $ metavar "MAXLIMITFULL" <> long "maxfull" <> help "Max limit for full listings (0 for no limit)" <> showDefault <>- value (maxLimitFull defMaxLimits)+ value (maxLimitFull def) maxLimitOffset <- option auto $ metavar "MAXOFFSET" <> long "maxoffset" <> help "Max offset (0 for no limit)" <> showDefault <>- value (maxLimitOffset defMaxLimits)+ value (maxLimitOffset def) maxLimitDefault <- option auto $ metavar "LIMITDEFAULT" <> long "deflimit" <> help "Default limit (0 for max)" <> showDefault <>- value (maxLimitDefault defMaxLimits)+ value (maxLimitDefault def) maxLimitGap <- option auto $ metavar "MAXGAP" <> long "maxgap" <> help "Max gap for xpub queries" <> showDefault <>- value (maxLimitGap defMaxLimits)+ value (maxLimitGap def) blockTimeout <- option auto $ metavar "BLOCKSECONDS" <> long "blocktimeout" <> help "Last block mined timeout (0 for infinite)" <> showDefault <>- value (blockTimeout defTimeouts)+ value (blockTimeout def) txTimeout <- option auto $ metavar "TXSECONDS" <> long "txtimeout" <> help "Last transaction broadcast timeout (0 for infinite)" <> showDefault <>- value (txTimeout defTimeouts)+ value (txTimeout def) configRedis <- switch $ long "cache" <> help "Redis cache for extended public keys" configRedisURL <-@@ -158,10 +144,16 @@ help "Minimum used xpub addresses to cache" <> showDefault <> value defRedisMin+ configRedisMax <-+ option auto $+ metavar "MAXKEYS" <> long "cachekeys" <>+ help "Maximum number of keys in Redis xpub cache" <>+ showDefault <>+ value defRedisMax pure Config- { configMaxLimits = MaxLimits {..}- , configTimeouts = Timeouts {..}+ { configWebLimits = WebLimits {..}+ , configWebTimeouts = WebTimeouts {..} , .. } @@ -175,7 +167,7 @@ | s == getNetworkName bchRegTest = Right bchRegTest | otherwise = Left "Network name invalid" -peerReader :: String -> Either String (Host, Maybe Port)+peerReader :: String -> Either String (String, Maybe Int) peerReader s = do let (host, p) = span (/= ':') s when (null host) (Left "Peer name or address not defined")@@ -216,76 +208,45 @@ , configPeers = peers , configDir = db_dir , configDebug = deb- , configMaxLimits = limits+ , configWebLimits = limits , configReqLog = reqlog- , configTimeouts = tos+ , configWebTimeouts = tos , configRedis = redis , configRedisURL = redisurl , configRedisMin = cachemin+ , configRedisMax = redismax } = runStderrLoggingT . filterLogger l $ do $(logInfoS) "Main" $ "Creating working directory if not found: " <> cs wd createDirectoryIfMissing True wd- db <- connectRocksDB (maxLimitGap limits) (wd </> "db")- withcache $ \maybecache ->- withPublisher $ \pub ->- let scfg =- StoreConfig- { storeConfMaxPeers = 20- , storeConfInitPeers =- map- (second (fromMaybe (getDefaultPort net)))- peers- , storeConfDiscover = disc- , storeConfDB = db- , storeConfNetwork = net- , storeConfPublisher = pub- , storeConfCache = maybecache- , storeConfGap = maxLimitGap limits- , storeConfCacheMin = cachemin+ let scfg =+ StoreConfig+ { storeConfMaxPeers = 20+ , storeConfInitPeers =+ map (second (fromMaybe (getDefaultPort net))) peers+ , storeConfDiscover = disc+ , storeConfDB = wd </> "db"+ , storeConfNetwork = net+ , storeConfCache =+ if redis+ then Just redisurl+ else Nothing+ , storeConfGap = maxLimitGap limits+ , storeConfCacheMin = cachemin+ , storeConfMaxKeys = redismax+ }+ in withStore scfg $ \st ->+ let wcfg =+ WebConfig+ { webPort = port+ , webStore = st+ , webMaxLimits = limits+ , webReqLog = reqlog+ , webWebTimeouts = tos }- in withStore scfg $ \st ->- let crcfg =- case maybecache of- Nothing -> Nothing- Just (conn, mbox) ->- Just- CacheReaderConfig- { cacheReaderConn = conn- , cacheReaderWriter =- inboxToMailbox mbox- , cacheReaderGap =- maxLimitGap limits- }- wcfg =- WebConfig- { webPort = port- , webNetwork = net- , webDB = db- , webPublisher = pub- , webStore = st- , webMaxLimits = limits- , webReqLog = reqlog- , webTimeouts = tos- , webCache = crcfg- }- in runWeb wcfg+ in runWeb wcfg where- withcache f =- if redis- then do- conninfo <-- if null redisurl- then return defaultConnectInfo- else case parseConnectInfo redisurl of- Left e -> error e- Right r -> return r- cachembox <- newInbox- withRunInIO $ \r ->- withCheckedConnect conninfo $ \conn ->- r $ f (Just (conn, cachembox))- else f Nothing l _ lvl | deb = True | otherwise = LevelInfo <= lvl
haskoin-store.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 89d53a7ce243c07c2c313ca4cdeef18c520b70f50e576c1810596f1e412f4eee+-- hash: 7200ad7a5b35e08670d60a7a256a04aed6ff5a16c24b137f95d4bdbd483d4be9 name: haskoin-store-version: 0.21.7+version: 0.22.0 synopsis: Storage and index for Bitcoin and Bitcoin Cash description: Store and index Bitcoin or Bitcoin Cash blocks, transactions, balances and unspent outputs. All data is available via REST API in JSON or binary format.@@ -34,16 +34,16 @@ Haskoin.Store Paths_haskoin_store other-modules:- Network.Haskoin.Store.BlockStore- Network.Haskoin.Store.CacheWriter- Network.Haskoin.Store.Common- Network.Haskoin.Store.Data.CacheReader- Network.Haskoin.Store.Data.DatabaseReader- Network.Haskoin.Store.Data.DatabaseWriter- Network.Haskoin.Store.Data.MemoryDatabase- Network.Haskoin.Store.Data.Types- Network.Haskoin.Store.Logic- Network.Haskoin.Store.Web+ Haskoin.Store.BlockStore+ Haskoin.Store.Cache+ Haskoin.Store.Common+ Haskoin.Store.Database.Memory+ Haskoin.Store.Database.Reader+ Haskoin.Store.Database.Types+ Haskoin.Store.Database.Writer+ Haskoin.Store.Logic+ Haskoin.Store.Manager+ Haskoin.Store.Web autogen-modules: Paths_haskoin_store hs-source-dirs:@@ -99,9 +99,7 @@ , filepath , hashable >=1.3.0.0 , haskoin-core >=0.12.0- , haskoin-node , haskoin-store- , hedis , monad-logger >=0.3.32 , mtl >=2.2.2 , nqe >=0.6.1@@ -119,20 +117,20 @@ type: exitcode-stdio-1.0 main-is: Spec.hs other-modules:+ Haskoin.Store.CacheSpec+ Haskoin.Store.CommonSpec Haskoin.StoreSpec- Network.Haskoin.Store.CommonSpec- Network.Haskoin.Store.Data.CacheReaderSpec Haskoin.Store- Network.Haskoin.Store.BlockStore- Network.Haskoin.Store.CacheWriter- Network.Haskoin.Store.Common- Network.Haskoin.Store.Data.CacheReader- Network.Haskoin.Store.Data.DatabaseReader- Network.Haskoin.Store.Data.DatabaseWriter- Network.Haskoin.Store.Data.MemoryDatabase- Network.Haskoin.Store.Data.Types- Network.Haskoin.Store.Logic- Network.Haskoin.Store.Web+ Haskoin.Store.BlockStore+ Haskoin.Store.Cache+ Haskoin.Store.Common+ Haskoin.Store.Database.Memory+ Haskoin.Store.Database.Reader+ Haskoin.Store.Database.Types+ Haskoin.Store.Database.Writer+ Haskoin.Store.Logic+ Haskoin.Store.Manager+ Haskoin.Store.Web Paths_haskoin_store hs-source-dirs: test
src/Haskoin/Store.hs view
@@ -1,229 +1,71 @@ module Haskoin.Store- ( StoreConfig(..)- , store- , withStore- , module Network.Haskoin.Store.Common- , module Network.Haskoin.Store.BlockStore- , module Network.Haskoin.Store.Logic- , module Network.Haskoin.Store.Web- , module Network.Haskoin.Store.CacheWriter- , module Network.Haskoin.Store.Data.Types- , module Network.Haskoin.Store.Data.CacheReader- , module Network.Haskoin.Store.Data.DatabaseReader- , module Network.Haskoin.Store.Data.DatabaseWriter- , module Network.Haskoin.Store.Data.MemoryDatabase- ) where--import Control.Monad (forever, unless,- when)-import Control.Monad.Logger (MonadLoggerIO)-import Data.Serialize (decode)-import Data.Word (Word32)-import Database.Redis (Connection)-import Haskoin (BlockHash (..),- Inv (..),- InvType (..),- InvVector (..),- Message (..),- MessageCommand (..),- Network,- NetworkAddress (..),- NotFound (..),- Pong (..),- Reject (..),- TxHash (..),- VarString (..),- sockToHostAddress)-import Haskoin.Node (ChainEvent (..),- ChainMessage,- HostPort,- ManagerMessage,- NodeConfig (..),- NodeEvent (..),- PeerEvent (..),- node)-import Network.Haskoin.Store.BlockStore-import Network.Haskoin.Store.CacheWriter-import Network.Haskoin.Store.Common-import Network.Haskoin.Store.Data.CacheReader-import Network.Haskoin.Store.Data.DatabaseReader-import Network.Haskoin.Store.Data.DatabaseWriter-import Network.Haskoin.Store.Data.MemoryDatabase-import Network.Haskoin.Store.Data.Types-import Network.Haskoin.Store.Logic-import Network.Haskoin.Store.Web-import Network.Socket (SockAddr (..))-import NQE (Inbox, Listen,- Process (..),- Publisher,- PublisherMessage (Event),- inboxToMailbox,- newInbox, receive,- send, sendSTM,- withProcess,- withSubscription)-import UnliftIO (MonadIO,- MonadUnliftIO, link,- withAsync)---- | 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 :: !DatabaseReader- -- ^ RocksDB database handler- , storeConfNetwork :: !Network- -- ^ network constants- , storeConfPublisher :: !(Publisher StoreEvent)- -- ^ publish store events- , storeConfCache :: !(Maybe (Connection, CacheWriterInbox))- -- ^ Redis cache configuration- , storeConfGap :: !Word32- -- ^ gap for extended public keys- , storeConfCacheMin :: !Int- -- ^ minimum number of addresses for caching- }--withStore ::- (MonadLoggerIO m, MonadUnliftIO m)- => StoreConfig- -> (Store -> m a)- -> m a-withStore cfg f = do- mgri <- newInbox- chi <- newInbox- withProcess (store cfg mgri chi) $ \(Process _ b) ->- f- Store- { storeManager = inboxToMailbox mgri- , storeChain = inboxToMailbox chi- , storeBlock = b- }---- | Run a Haskoin Store instance. It will launch a network node and a--- 'BlockStore', connect to the network and start synchronizing blocks and--- transactions.-store ::- (MonadLoggerIO m, MonadUnliftIO m)- => StoreConfig- -> Inbox ManagerMessage- -> Inbox ChainMessage- -> Inbox BlockStoreMessage- -> m ()-store cfg mgri chi bsi = do- let ncfg =- NodeConfig- { nodeConfMaxPeers = storeConfMaxPeers cfg- , nodeConfDB = databaseHandle (storeConfDB cfg)- , nodeConfPeers = storeConfInitPeers cfg- , nodeConfDiscover = storeConfDiscover cfg- , nodeConfEvents = storeDispatch b ((`sendSTM` l) . Event)- , nodeConfNetAddr =- NetworkAddress 0 (sockToHostAddress (SockAddrInet 0 0))- , nodeConfNet = storeConfNetwork cfg- , nodeConfTimeout = 10- }- withAsync (node ncfg mgri chi) $ \a -> do- link a- let bcfg =- BlockStoreConfig- { blockConfChain = inboxToMailbox chi- , blockConfManager = inboxToMailbox mgri- , blockConfListener = (`sendSTM` l) . Event- , blockConfDB = storeConfDB cfg- , blockConfNet = storeConfNetwork cfg- }- case storeConfCache cfg of- Nothing -> blockStore bcfg bsi- Just cacheinfo -> do- let cwm = inboxToMailbox (snd cacheinfo)- crconf =- CacheReaderConfig- { cacheReaderConn = fst cacheinfo- , cacheReaderWriter = cwm- , cacheReaderGap = storeConfGap cfg- }- cwconf =- CacheWriterConfig- { cacheWriterReader = crconf- , cacheWriterChain = c- , cacheWriterMailbox = snd cacheinfo- , cacheWriterNetwork = storeConfNetwork cfg- , cacheWriterMin = storeConfCacheMin cfg- }- cw =- withDatabaseReader- (storeConfDB cfg)- (cacheWriter cwconf)- withAsync cw $ \w ->- withSubscription l $ \evts -> do- link w- withAsync (cacheWriterEvents evts cwm) $ \cwd -> do- link cwd- blockStore bcfg bsi- where- l = storeConfPublisher cfg- b = inboxToMailbox bsi- c = inboxToMailbox chi--cacheWriterEvents :: MonadIO m => Inbox StoreEvent -> CacheWriter -> m ()-cacheWriterEvents evts cwm = forever $ receive evts >>= (`cacheWriterDispatch` cwm)--cacheWriterDispatch :: MonadIO m => StoreEvent -> CacheWriter -> m ()-cacheWriterDispatch (StoreBestBlock _) = send CacheNewBlock-cacheWriterDispatch (StoreMempoolNew txh) = send (CacheNewTx txh)-cacheWriterDispatch (StoreTxDeleted txh) = send (CacheDelTx txh)-cacheWriterDispatch _ = const (return ())---- | Dispatcher of node events.-storeDispatch :: BlockStore -> Listen StoreEvent -> Listen NodeEvent--storeDispatch b pub (PeerEvent (PeerConnected p a)) = do- pub (StorePeerConnected p a)- BlockPeerConnect p a `sendSTM` b+ ( StoreRead (..)+ , BlockData (..)+ , TxData (..)+ , Spender (..)+ , Balance (..)+ , Unspent (..)+ , BlockTx (..)+ , BlockRef (..)+ , XPubSpec (..)+ , XPubBal (..)+ , XPubSummary (..)+ , XPubUnspent (..)+ , DeriveType (..)+ , UnixTime+ , Limit+ , Offset+ , BlockPos -storeDispatch b pub (PeerEvent (PeerDisconnected p a)) = do- pub (StorePeerDisconnected p a)- BlockPeerDisconnect p a `sendSTM` b+ , Transaction (..)+ , StoreInput (..)+ , StoreOutput (..)+ , getTransaction+ , transactionData+ , fromTransaction+ , toTransaction -storeDispatch b _ (ChainEvent (ChainBestBlock bn)) =- BlockNewBest bn `sendSTM` b+ , BinSerial (..)+ , JsonSerial (..) -storeDispatch _ _ (ChainEvent _) = return ()+ , blockAtOrBefore+ , confirmed+ , nullBalance+ , isCoinbase -storeDispatch _ pub (PeerEvent (PeerMessage p (MPong (Pong n)))) =- pub (StorePeerPong p n)+ , PeerInformation (..)+ , HealthCheck (..)+ , StoreEvent (..)+ , PubExcept (..)+ , TxId (..)+ , TxAfterHeight (..) -storeDispatch b _ (PeerEvent (PeerMessage p (MBlock block))) =- BlockReceived p block `sendSTM` b+ , StoreWrite (..) -storeDispatch b _ (PeerEvent (PeerMessage p (MTx tx))) =- BlockTxReceived p tx `sendSTM` b+ , StoreConfig (..)+ , Store (..)+ , withStore -storeDispatch b _ (PeerEvent (PeerMessage p (MNotFound (NotFound is)))) = do- let blocks =- [ BlockHash h- | InvVector t h <- is- , t == InvBlock || t == InvWitnessBlock- ]- unless (null blocks) $ BlockNotFound p blocks `sendSTM` b+ , DatabaseReader (..)+ , DatabaseReaderT+ , connectRocksDB+ , withDatabaseReader -storeDispatch b pub (PeerEvent (PeerMessage p (MInv (Inv is)))) = do- let txs = [TxHash h | InvVector t h <- is, t == InvTx || t == InvWitnessTx]- pub (StoreTxAvailable p txs)- unless (null txs) $ BlockTxAvailable p txs `sendSTM` b+ , WebConfig (..)+ , WebLimits (..)+ , WebTimeouts (..)+ , Except (..)+ , runWeb -storeDispatch _ pub (PeerEvent (PeerMessage p (MReject r))) =- when (rejectMessage r == MCTx) $- case decode (rejectData r) of- Left _ -> return ()- Right th ->- pub $- StoreTxReject p th (rejectCode r) (getVarString (rejectReason r))+ , CacheConfig (..)+ , CacheT+ , CacheError (..)+ , withCache+ , connectRedis+ ) where -storeDispatch _ _ (PeerEvent _) = return ()+import Haskoin.Store.Cache+import Haskoin.Store.Common+import Haskoin.Store.Database.Reader+import Haskoin.Store.Manager+import Haskoin.Store.Web
+ src/Haskoin/Store/BlockStore.hs view
@@ -0,0 +1,513 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+module Haskoin.Store.BlockStore+ ( BlockStoreConfig(..)+ , blockStore+ ) where++import Control.Applicative ((<|>))+import Control.Monad (forM, 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 (MaybeT (MaybeT), runMaybeT)+import Data.Maybe (catMaybes, isNothing,+ listToMaybe)+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 Haskoin.Node (Chain, Manager)+import Haskoin.Store.Common (BlockStore,+ BlockStoreMessage (..),+ StoreEvent (..), StoreRead (..),+ StoreWrite (..), UnixTime)+import Haskoin.Store.Database.Reader (DatabaseReader)+import Haskoin.Store.Database.Writer (DatabaseWriter,+ runDatabaseWriter)+import Haskoin.Store.Logic (ImportException, deleteTx,+ getOldMempool, getOldOrphans,+ importBlock, importOrphan,+ initBest, newMempoolTx,+ revertBlock)+import NQE (Inbox, Listen, 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+ | Uninitialized+ | AncestorNotInChain !BlockHeight+ !BlockHash+ deriving (Show, Eq, Ord, Exception)++data Syncing = Syncing+ { syncingPeer :: !Peer+ , syncingTime :: !UnixTime+ , syncingHead :: !BlockNode+ }++-- | Block store process state.+data BlockRead = BlockRead+ { mySelf :: !BlockStore+ , myConfig :: !BlockStoreConfig+ , myPeer :: !(TVar (Maybe Syncing))+ }++-- | Configuration for a block store.+data BlockStoreConfig =+ BlockStoreConfig+ { blockConfManager :: !Manager+ -- ^ peer manager from running node+ , blockConfChain :: !Chain+ -- ^ chain from a running node+ , blockConfListener :: !(Listen StoreEvent)+ -- ^ listener for store events+ , blockConfDB :: !DatabaseReader+ -- ^ RocksDB database handle+ , blockConfNet :: !Network+ -- ^ network constants+ }++type BlockT m = ReaderT BlockRead m++runImport ::+ MonadLoggerIO m+ => ReaderT DatabaseWriter (ExceptT ImportException m) a+ -> ReaderT BlockRead m (Either ImportException a)+runImport f =+ ReaderT $ \r -> runExceptT (runDatabaseWriter (blockConfDB (myConfig r)) f)++runRocksDB :: ReaderT DatabaseReader m a -> ReaderT BlockRead m a+runRocksDB f =+ ReaderT $ \BlockRead {myConfig = BlockStoreConfig {blockConfDB = db}} ->+ runReaderT f db++instance MonadIO m => StoreRead (ReaderT BlockRead m) where+ 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)+ getOrphans = runRocksDB getOrphans+ getAddressUnspents a s = runRocksDB . getAddressUnspents a s+ getAddressTxs a s = runRocksDB . getAddressTxs a s++-- | Run block store process.+blockStore ::+ (MonadUnliftIO m, MonadLoggerIO m)+ => BlockStoreConfig+ -> Inbox BlockStoreMessage+ -> m ()+blockStore cfg inbox = do+ pb <- newTVarIO Nothing+ runReaderT+ (ini >> run)+ BlockRead {mySelf = inboxToMailbox inbox, myConfig = cfg, myPeer = pb}+ where+ ini = do+ net <- asks (blockConfNet . myConfig)+ runImport (initBest net) >>= \case+ Left e -> do+ $(logErrorS) "BlockStore" $+ "Could not initialize block store: " <> fromString (show e)+ throwIO e+ Right () -> return ()+ run =+ withAsync (pingMe (inboxToMailbox inbox)) . const . forever $ do+ receive inbox >>= \x ->+ ReaderT $ \r -> runReaderT (processBlockStoreMessage x) r++isInSync ::+ (MonadLoggerIO m, StoreRead m, MonadReader BlockRead m)+ => m Bool+isInSync =+ getBestBlock >>= \case+ Nothing -> do+ $(logErrorS) "BlockStore" "Block database uninitialized"+ throwIO Uninitialized+ Just bb ->+ asks (blockConfChain . myConfig) >>= chainGetBest >>= \cb ->+ return (headerHash (nodeHeader cb) == bb)++mempool :: MonadLoggerIO m => Peer -> m ()+mempool p = do+ $(logDebugS) "BlockStore" "Requesting mempool from network peer"+ MMempool `sendMessage` p++processBlock ::+ (MonadUnliftIO m, MonadLoggerIO m)+ => Peer+ -> Block+ -> ReaderT BlockRead m ()+processBlock peer block = do+ void . runMaybeT $ do+ checkpeer+ blocknode <- getblocknode+ net <- asks (blockConfNet . myConfig)+ lift (runImport (importBlock net block blocknode)) >>= \case+ Right deletedtxids -> do+ listener <- asks (blockConfListener . myConfig)+ $(logInfoS) "BlockStore" $ "Best block indexed: " <> hexhash+ atomically $ do+ mapM_ (listener . StoreTxDeleted) deletedtxids+ listener (StoreBestBlock blockhash)+ lift (syncMe peer)+ Left e -> do+ $(logErrorS) "BlockStore" $+ "Error importing block: " <> hexhash <> ": " <>+ fromString (show e)+ killPeer (PeerMisbehaving (show e)) peer+ where+ header = blockHeader block+ blockhash = headerHash header+ hexhash = blockHashToHex blockhash+ checkpeer =+ getSyncingState >>= \case+ Just Syncing {syncingPeer = syncingpeer}+ | peer == syncingpeer -> return ()+ _ -> do+ $(logErrorS) "BlockStore" $ "Peer sent unexpected block: " <> hexhash+ killPeer (PeerMisbehaving "Sent unpexpected block") peer+ mzero+ getblocknode =+ asks (blockConfChain . myConfig) >>= chainGetBlock blockhash >>= \case+ Nothing -> do+ $(logErrorS) "BlockStore" $ "Block header not found: " <> hexhash+ killPeer (PeerMisbehaving "Sent unknown block") peer+ mzero+ Just n -> return n++processNoBlocks ::+ (MonadUnliftIO m, MonadLoggerIO m)+ => Peer+ -> [BlockHash]+ -> ReaderT BlockRead m ()+processNoBlocks p _bs = do+ $(logErrorS) "BlockStore" (cs m)+ killPeer (PeerMisbehaving m) p+ where+ m = "I do not like peers that cannot find them blocks"++processTx :: (MonadUnliftIO m, MonadLoggerIO m) => Peer -> Tx -> BlockT m ()+processTx _p tx =+ isInSync >>= \sync ->+ when sync $ do+ now <- fromIntegral . systemSeconds <$> liftIO getSystemTime+ net <- asks (blockConfNet . myConfig)+ runImport (newMempoolTx net tx now) >>= \case+ Right (Just deleted) -> do+ l <- blockConfListener <$> asks myConfig+ $(logInfoS) "BlockStore" $+ "New mempool tx: " <> txHashToHex (txHash tx)+ atomically $ do+ mapM_ (l . StoreTxDeleted) deleted+ l (StoreMempoolNew (txHash tx))+ _ -> return ()++processOrphans ::+ (MonadUnliftIO m, MonadLoggerIO m) => BlockT m ()+processOrphans =+ isInSync >>= \sync ->+ when sync $ do+ now <- fromIntegral . systemSeconds <$> liftIO getSystemTime+ net <- asks (blockConfNet . myConfig)+ old <- getOldOrphans now+ case old of+ [] -> return ()+ _ -> do+ $(logInfoS) "BlockStore" $+ "Removing " <> cs (show (length old)) <>+ " expired orphan transactions"+ void . runImport $ mapM_ deleteOrphanTx old+ orphans <- getOrphans+ case orphans of+ [] -> return ()+ _ ->+ $(logInfoS) "BlockStore" $+ "Attempting to import " <> cs (show (length orphans)) <>+ " orphan transactions"+ ops <-+ zip (map snd orphans) <$>+ mapM (runImport . uncurry (importOrphan net)) orphans+ 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+++processTxs ::+ (MonadUnliftIO m, MonadLoggerIO m)+ => Peer+ -> [TxHash]+ -> ReaderT BlockRead m ()+processTxs p hs =+ isInSync >>= \sync ->+ when sync $ do+ xs <-+ fmap catMaybes . forM hs $ \h ->+ runMaybeT $ do+ t <- lift $ getTxData h+ guard (isNothing t)+ return (getTxHash h)+ unless (null xs) $ do+ $(logInfoS) "BlockStore" $+ "Requesting " <> fromString (show (length xs)) <>+ " new transactions"+ net <- blockConfNet <$> asks myConfig+ let inv =+ if getSegWit net+ then InvWitnessTx+ else InvTx+ MGetData (GetData (map (InvVector inv) xs)) `sendMessage` p++checkTime :: (MonadUnliftIO m, MonadLoggerIO m) => ReaderT BlockRead m ()+checkTime =+ asks myPeer >>= readTVarIO >>= \case+ Nothing -> return ()+ Just Syncing {syncingTime = t, syncingPeer = p} -> do+ n <- fromIntegral . systemSeconds <$> liftIO getSystemTime+ when (n > t + 60) $ do+ $(logErrorS) "BlockStore" "Syncing peer timeout"+ resetPeer+ killPeer PeerTimeout p++processDisconnect ::+ (MonadUnliftIO m, MonadLoggerIO m)+ => Peer+ -> ReaderT BlockRead m ()+processDisconnect p =+ asks myPeer >>= readTVarIO >>= \case+ Nothing -> return ()+ Just Syncing {syncingPeer = p'}+ | p == p' -> do+ resetPeer+ getPeer >>= \case+ Nothing ->+ $(logWarnS)+ "BlockStore"+ "No peers available after syncing peer disconnected"+ Just peer -> do+ $(logWarnS) "BlockStore" "Selected another peer to sync"+ syncMe peer+ | otherwise -> return ()++pruneMempool :: (MonadUnliftIO m, MonadLoggerIO m) => BlockT m ()+pruneMempool =+ isInSync >>= \sync ->+ when sync $ do+ now <- fromIntegral . systemSeconds <$> liftIO getSystemTime+ getOldMempool now >>= \case+ [] -> return ()+ old -> deletetxs old+ where+ deletetxs old = do+ $(logInfoS) "BlockStore" $+ "Removing " <> cs (show (length old)) <> " old mempool transactions"+ net <- asks (blockConfNet . myConfig)+ forM_ old $ \txid ->+ runImport (deleteTx net True txid) >>= \case+ Left _ -> return ()+ Right txids -> do+ listener <- asks (blockConfListener . myConfig)+ atomically $ mapM_ (listener . StoreTxDeleted) txids++syncMe :: (MonadUnliftIO m, MonadLoggerIO m) => Peer -> BlockT m ()+syncMe peer =+ void . runMaybeT $ do+ checksyncingpeer+ reverttomainchain+ syncbest <- syncbestnode+ bestblock <- bestblocknode+ chainbest <- chainbestnode+ end syncbest bestblock chainbest+ blocknodes <- selectblocks chainbest syncbest+ setPeer peer (last blocknodes)+ net <- asks (blockConfNet . myConfig)+ let inv =+ if getSegWit net+ then InvWitnessBlock+ else InvBlock+ vectors =+ map+ (InvVector inv . getBlockHash . headerHash . nodeHeader)+ blocknodes+ $(logInfoS) "BlockStore" $+ "Requesting " <> fromString (show (length vectors)) <> " blocks"+ MGetData (GetData vectors) `sendMessage` peer+ where+ checksyncingpeer =+ getSyncingState >>= \case+ Nothing -> return ()+ Just Syncing {syncingPeer = p}+ | p == peer -> return ()+ | otherwise -> do+ $(logInfoS) "BlockStore" "Already syncing against another peer"+ mzero+ chainbestnode = chainGetBest =<< asks (blockConfChain . myConfig)+ bestblocknode = do+ bb <-+ lift getBestBlock >>= \case+ Nothing -> do+ $(logErrorS) "BlockStore" "No best block set"+ throwIO Uninitialized+ Just b -> return b+ ch <- asks (blockConfChain . myConfig)+ chainGetBlock bb ch >>= \case+ Nothing -> do+ $(logErrorS) "BlockStore" $+ "Header not found for best block: " <> blockHashToHex bb+ throwIO (BlockNotInChain bb)+ Just x -> return x+ syncbestnode =+ asks myPeer >>= readTVarIO >>= \case+ Just Syncing {syncingHead = b} -> return b+ Nothing -> bestblocknode+ end syncbest bestblock chainbest+ | nodeHeader bestblock == nodeHeader chainbest = do+ resetPeer >> mempool peer >> mzero+ | nodeHeader syncbest == nodeHeader chainbest = do mzero+ | otherwise =+ when (nodeHeight syncbest > nodeHeight bestblock + 500) mzero+ selectblocks chainbest syncbest = do+ synctop <-+ top+ chainbest+ (maxsyncheight (nodeHeight chainbest) (nodeHeight syncbest))+ ch <- asks (blockConfChain . myConfig)+ parents <- chainGetParents (nodeHeight syncbest + 1) synctop ch+ return $+ if length parents < 500+ then parents <> [chainbest]+ else parents+ maxsyncheight chainheight syncbestheight+ | chainheight <= syncbestheight + 501 = chainheight+ | otherwise = syncbestheight + 501+ top chainbest syncheight = do+ ch <- asks (blockConfChain . myConfig)+ if syncheight == nodeHeight chainbest+ then return chainbest+ else chainGetAncestor syncheight chainbest ch >>= \case+ Just x -> return x+ Nothing -> do+ $(logErrorS) "BlockStore" $+ "Could not find header for ancestor of block: " <>+ blockHashToHex (headerHash (nodeHeader chainbest))+ throwIO $+ AncestorNotInChain+ syncheight+ (headerHash (nodeHeader chainbest))+ reverttomainchain = do+ bestblockhash <- headerHash . nodeHeader <$> bestblocknode+ ch <- asks (blockConfChain . myConfig)+ chainBlockMain bestblockhash ch >>= \y ->+ unless y $ do+ $(logErrorS) "BlockStore" $+ "Reverting best block: " <> blockHashToHex bestblockhash+ resetPeer+ net <- asks (blockConfNet . myConfig)+ lift (runImport (revertBlock net bestblockhash)) >>= \case+ Left e -> do+ $(logErrorS) "BlockStore" $+ "Could not revert best block: " <> cs (show e)+ throwIO e+ Right txids -> do+ listener <- asks (blockConfListener . myConfig)+ atomically $ do+ mapM_ (listener . StoreTxDeleted) txids+ listener (StoreBlockReverted bestblockhash)+ reverttomainchain++resetPeer :: (MonadLoggerIO m, MonadReader BlockRead m) => m ()+resetPeer = do+ box <- asks myPeer+ atomically $ writeTVar box Nothing++setPeer :: (MonadIO m, MonadReader BlockRead m) => Peer -> BlockNode -> m ()+setPeer p b = do+ box <- asks myPeer+ now <- fromIntegral . systemSeconds <$> liftIO getSystemTime+ atomically . writeTVar box $+ Just Syncing {syncingPeer = p, syncingHead = b, syncingTime = now}++getPeer :: (MonadIO m, MonadReader BlockRead m) => m (Maybe Peer)+getPeer = runMaybeT $ MaybeT syncingpeer <|> MaybeT onlinepeer+ where+ syncingpeer = fmap syncingPeer <$> getSyncingState+ onlinepeer =+ listToMaybe . map onlinePeerMailbox <$>+ (managerGetPeers =<< asks (blockConfManager . myConfig))++getSyncingState :: (MonadIO m, MonadReader BlockRead m) => m (Maybe Syncing)+getSyncingState = readTVarIO =<< asks myPeer++processBlockStoreMessage ::+ (MonadUnliftIO m, MonadLoggerIO m)+ => BlockStoreMessage+ -> BlockT m ()+processBlockStoreMessage (BlockNewBest _) = do+ getPeer >>= \case+ Nothing -> do+ $(logDebugS)+ "BlockStore"+ "New best block event received but no peers available"+ Just p -> syncMe p+processBlockStoreMessage (BlockPeerConnect p _) = syncMe p+processBlockStoreMessage (BlockPeerDisconnect p _sa) = processDisconnect p+processBlockStoreMessage (BlockReceived p b) = processBlock p b+processBlockStoreMessage (BlockNotFound p bs) = processNoBlocks p bs+processBlockStoreMessage (BlockTxReceived p tx) = processTx p tx+processBlockStoreMessage (BlockTxAvailable p ts) = processTxs p ts+processBlockStoreMessage (BlockPing r) = do+ processOrphans+ checkTime+ pruneMempool+ atomically (r ())++pingMe :: MonadLoggerIO m => BlockStore -> m ()+pingMe mbox =+ forever $ do+ threadDelay =<< liftIO (randomRIO (5 * 1000 * 1000, 10 * 1000 * 1000))+ BlockPing `query` mbox
+ src/Haskoin/Store/Cache.hs view
@@ -0,0 +1,970 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeSynonymInstances #-}+module Haskoin.Store.Cache+ ( CacheConfig(..)+ , CacheT+ , CacheError(..)+ , withCache+ , connectRedis+ , blockRefScore+ , scoreBlockRef+ , CacheWriter+ , CacheWriterInbox+ , CacheWriterMessage (..)+ , cacheWriter+ ) where++import Control.DeepSeq (NFData)+import Control.Monad (forM, forM_, forever, unless, void)+import Control.Monad.Logger (MonadLoggerIO, logDebugS, logErrorS,+ logInfoS, logWarnS)+import Control.Monad.Reader (ReaderT (..), asks)+import Control.Monad.Trans (lift)+import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)+import Data.Bits (shift, (.&.), (.|.))+import Data.ByteString (ByteString)+import qualified Data.ByteString.Short as BSS+import Data.Either (rights)+import qualified Data.HashMap.Strict as HashMap+import qualified Data.IntMap.Strict as IntMap+import Data.List (nub, sort)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Maybe (catMaybes, fromJust, mapMaybe)+import Data.Serialize (decode, encode)+import Data.Serialize (Serialize)+import Data.String.Conversions (cs)+import Data.Time.Clock.System (getSystemTime, systemSeconds)+import Data.Word (Word32, Word64)+import Database.Redis (Connection, Redis, Reply,+ checkedConnect, defaultConnectInfo,+ hgetall, parseConnectInfo, runRedis,+ runRedis, zadd, zrangeWithscores,+ zrangebyscoreWithscoresLimit, zrem)+import qualified Database.Redis as Redis+import GHC.Generics (Generic)+import Haskoin (Address, BlockHash,+ BlockHeader (..), BlockNode (..),+ DerivPathI (..), KeyIndex,+ OutPoint (..), Tx (..), TxHash,+ TxIn (..), TxOut (..), XPubKey,+ blockHashToHex, derivePubPath,+ eitherToMaybe, headerHash,+ pathToList, scriptToAddressBS,+ txHash, txHashToHex, xPubAddr,+ xPubCompatWitnessAddr,+ xPubWitnessAddr)+import Haskoin.Node (Chain, chainGetAncestor,+ chainGetBlock, chainGetSplitBlock)+import Haskoin.Store.Common (Balance (..), BlockData (..),+ BlockRef (..), BlockTx (..),+ DeriveType (..), Limit, Offset,+ Prev (..), StoreRead (..),+ StoreRead (..), TxData (..),+ Unspent (..), XPubBal (..),+ XPubSpec (..), XPubUnspent (..),+ nullBalance, sortTxs, xPubBals,+ xPubTxs, xPubUnspents)+import NQE (Inbox, Mailbox, receive)+import UnliftIO (Exception, MonadIO, MonadUnliftIO,+ liftIO, throwIO)++type RedisReply a = Redis (Either Reply a)++runRedisReply :: MonadIO m => RedisReply a -> CacheT m a+runRedisReply action =+ asks cacheConn >>= \conn ->+ liftIO (runRedis conn action) >>= \case+ Left e -> throwIO (RedisError e)+ Right x -> return x++data CacheConfig =+ CacheConfig+ { cacheConn :: !Connection+ , cacheGap :: !Word32+ , cacheMin :: !Int+ , cacheMax :: !Integer+ , cacheChain :: !Chain+ }++type CacheT = ReaderT CacheConfig++data CacheError+ = RedisError Reply+ | LogicError String+ deriving (Show, Eq, Generic, NFData, Exception)++connectRedis :: MonadIO m => String -> m Connection+connectRedis redisurl = do+ conninfo <-+ if null redisurl+ then return defaultConnectInfo+ else case parseConnectInfo redisurl of+ Left e -> error e+ Right r -> return r+ liftIO (checkedConnect conninfo)++instance (MonadLoggerIO m, StoreRead m) => StoreRead (CacheT m) where+ getBestBlock = lift getBestBlock+ getBlocksAtHeight = lift . getBlocksAtHeight+ getBlock = lift . getBlock+ getTxData = lift . getTxData+ getOrphanTx = lift . getOrphanTx+ getOrphans = lift getOrphans+ getSpenders = lift . getSpenders+ getSpender = lift . getSpender+ getBalance = lift . getBalance+ getBalances = lift . getBalances+ getAddressesTxs addrs start = lift . getAddressesTxs addrs start+ getAddressTxs addr start = lift . getAddressTxs addr start+ getUnspent = lift . getUnspent+ getAddressUnspents addr start = lift . getAddressUnspents addr start+ getAddressesUnspents addrs start = lift . getAddressesUnspents addrs start+ getMempool = lift getMempool+ xPubBals = getXPubBalances+ xPubUnspents = getXPubUnspents+ xPubTxs = getXPubTxs+ getMaxGap = asks cacheGap++withCache :: StoreRead m => CacheConfig -> CacheT m a -> m a+withCache s f = runReaderT f s++balancesPfx :: ByteString+balancesPfx = "b"++txSetPfx :: ByteString+txSetPfx = "t"++utxoPfx :: ByteString+utxoPfx = "u"++getXPubTxs ::+ (MonadLoggerIO m, StoreRead m)+ => XPubSpec+ -> Maybe BlockRef+ -> Offset+ -> Maybe Limit+ -> CacheT m [BlockTx]+getXPubTxs xpub start offset limit =+ c >>= \case+ [] ->+ newXPubC xpub >>= \(bals, t) ->+ if t+ then c+ else do+ txs <- d+ $(logDebugS) "Cache" $+ "Not caching xpub with " <>+ cs (show (lenNotNull bals)) <>+ " balances"+ return txs+ txs -> do+ $(logDebugS) "Cache" $+ "Cache hit for " <> cs (show (length txs)) <> " xpub txs"+ return txs+ where+ c = cacheGetXPubTxs xpub start offset limit+ d = lift $ xPubTxs xpub start offset limit++getXPubUnspents ::+ (MonadLoggerIO m, StoreRead m)+ => XPubSpec+ -> Maybe BlockRef+ -> Offset+ -> Maybe Limit+ -> CacheT m [XPubUnspent]+getXPubUnspents xpub start offset limit =+ cacheGetXPubBalances xpub >>= \case+ [] ->+ newXPubC xpub >>= \(bals, t) ->+ if t+ then process bals+ else do+ uns <- lift $ xPubUnspents xpub start offset limit+ $(logDebugS) "Cache" $+ "Not caching xpub with " <>+ cs (show (lenNotNull bals)) <>+ " balances"+ return uns+ bals -> process bals+ where+ process bals = do+ ops <- map snd <$> cacheGetXPubUnspents xpub start offset limit+ uns <- catMaybes <$> mapM getUnspent ops+ let addrmap =+ Map.fromList $+ map (\b -> (balanceAddress (xPubBal b), xPubBalPath b)) bals+ addrutxo =+ mapMaybe+ (\u ->+ either+ (const Nothing)+ (\a -> Just (a, u))+ (scriptToAddressBS+ (BSS.fromShort (unspentScript u))))+ uns+ xpubutxo =+ mapMaybe+ (\(a, u) -> (\p -> XPubUnspent p u) <$> Map.lookup a addrmap)+ addrutxo+ return xpubutxo++getXPubBalances ::+ (MonadLoggerIO m, StoreRead m)+ => XPubSpec+ -> CacheT m [XPubBal]+getXPubBalances xpub = do+ cacheGetXPubBalances xpub >>= \case+ [] ->+ newXPubC xpub >>= \(bals, t) ->+ if t+ then return bals+ else do+ $(logDebugS) "Cache" $+ "Not caching xpub with " <>+ cs (show (lenNotNull bals)) <>+ " balances"+ return bals+ bals -> return bals++cacheGetXPubBalances :: MonadIO m => XPubSpec -> CacheT m [XPubBal]+cacheGetXPubBalances xpub = do+ now <- systemSeconds <$> liftIO getSystemTime+ runRedisReply $ do+ bals <- redisGetXPubBalances xpub+ x <-+ case bals of+ Right (_:_) -> touchKeys now [xpub]+ _ -> return (pure 0)+ return $ x >> bals++cacheGetXPubTxs ::+ MonadIO m+ => XPubSpec+ -> Maybe BlockRef+ -> Offset+ -> Maybe Limit+ -> CacheT m [BlockTx]+cacheGetXPubTxs xpub start offset limit = do+ now <- systemSeconds <$> liftIO getSystemTime+ runRedisReply $ do+ txs <- redisGetXPubTxs xpub start offset limit+ x <-+ case txs of+ Right (_:_) -> touchKeys now [xpub]+ _ -> return (pure 0)+ return $ x >> txs++cacheGetXPubUnspents ::+ MonadIO m+ => XPubSpec+ -> Maybe BlockRef+ -> Offset+ -> Maybe Limit+ -> CacheT m [(BlockRef, OutPoint)]+cacheGetXPubUnspents xpub start offset limit = do+ now <- systemSeconds <$> liftIO getSystemTime+ runRedisReply $ do+ x <- touchKeys now [xpub]+ uns <- redisGetXPubUnspents xpub start offset limit+ return $ x >> uns++redisGetXPubBalances :: XPubSpec -> RedisReply [XPubBal]+redisGetXPubBalances xpub =+ getAllFromMap (balancesPfx <> encode xpub) >>=+ return . fmap (sort . map (uncurry f))+ where+ f p b = XPubBal {xPubBalPath = p, xPubBal = b}++redisGetXPubTxs ::+ XPubSpec+ -> Maybe BlockRef+ -> Offset+ -> Maybe Limit+ -> RedisReply [BlockTx]+redisGetXPubTxs xpub start offset limit = do+ xs <-+ getFromSortedSet+ (txSetPfx <> encode xpub)+ (blockRefScore <$> start)+ (fromIntegral offset)+ (fromIntegral <$> limit)+ return $ map (uncurry f) <$> xs+ where+ f t s = BlockTx {blockTxHash = t, blockTxBlock = scoreBlockRef s}++redisGetXPubUnspents ::+ XPubSpec+ -> Maybe BlockRef+ -> Offset+ -> Maybe Limit+ -> RedisReply [(BlockRef, OutPoint)]+redisGetXPubUnspents xpub start offset limit = do+ xs <-+ getFromSortedSet+ (utxoPfx <> encode xpub)+ (blockRefScore <$> start)+ (fromIntegral offset)+ (fromIntegral <$> limit)+ return $ map (uncurry f) <$> xs+ where+ f o s = (scoreBlockRef s, o)++blockRefScore :: BlockRef -> Double+blockRefScore BlockRef {blockRefHeight = h, blockRefPos = p} =+ fromIntegral (0x001fffffffffffff - (h' .|. p'))+ where+ h' = (fromIntegral h .&. 0x07ffffff) `shift` 26 :: Word64+ p' = (fromIntegral p .&. 0x03ffffff) :: Word64+blockRefScore MemRef {memRefTime = t} = 0 - t'+ where+ t' = fromIntegral (t .&. 0x001fffffffffffff)++scoreBlockRef :: Double -> BlockRef+scoreBlockRef s+ | s < 0 = MemRef {memRefTime = n}+ | otherwise = BlockRef {blockRefHeight = h, blockRefPos = p}+ where+ n = truncate (abs s) :: Word64+ m = 0x001fffffffffffff - n+ h = fromIntegral (m `shift` (-26))+ p = fromIntegral (m .&. 0x03ffffff)++getFromSortedSet ::+ Serialize a+ => ByteString+ -> Maybe Double+ -> Integer+ -> Maybe Integer+ -> RedisReply [(a, Double)]+getFromSortedSet key Nothing offset Nothing = do+ xs <- zrangeWithscores key offset (-1)+ return $ do+ ys <- map (\(x, s) -> (, s) <$> decode x) <$> xs+ return (rights ys)+getFromSortedSet key Nothing offset (Just count) = do+ xs <- zrangeWithscores key offset (offset + count - 1)+ return $ do+ ys <- map (\(x, s) -> (, s) <$> decode x) <$> xs+ return (rights ys)+getFromSortedSet key (Just score) offset Nothing = do+ xs <-+ zrangebyscoreWithscoresLimit+ key+ score+ (2 ^ (53 :: Integer) - 1)+ offset+ (-1)+ return $ do+ ys <- map (\(x, s) -> (, s) <$> decode x) <$> xs+ return (rights ys)+getFromSortedSet key (Just score) offset (Just count) = do+ xs <-+ zrangebyscoreWithscoresLimit+ key+ score+ (2 ^ (53 :: Integer) - 1)+ offset+ count+ return $ do+ ys <- map (\(x, s) -> (, s) <$> decode x) <$> xs+ return (rights ys)++getAllFromMap :: (Serialize k, Serialize v) => ByteString -> RedisReply [(k, v)]+getAllFromMap n = do+ fxs <- hgetall n+ return $ do+ xs <- fxs+ return+ [ (k, v)+ | (k', v') <- xs+ , let Right k = decode k'+ , let Right v = decode v'+ ]++data CacheWriterMessage+ = CacheNewTx !TxHash+ | CacheDelTx !TxHash+ | CacheNewBlock+ deriving (Show, Eq, Generic, NFData)++type CacheWriterInbox = Inbox CacheWriterMessage+type CacheWriter = Mailbox CacheWriterMessage++data AddressXPub =+ AddressXPub+ { addressXPubSpec :: !XPubSpec+ , addressXPubPath :: ![KeyIndex]+ } deriving (Show, Eq, Generic, NFData, Serialize)++mempoolSetKey :: ByteString+mempoolSetKey = "mempool"++addrPfx :: ByteString+addrPfx = "a"++bestBlockKey :: ByteString+bestBlockKey = "head"++maxKey :: ByteString+maxKey = "max"++xPubAddrFunction :: DeriveType -> XPubKey -> Address+xPubAddrFunction DeriveNormal = xPubAddr+xPubAddrFunction DeriveP2SH = xPubCompatWitnessAddr+xPubAddrFunction DeriveP2WPKH = xPubWitnessAddr++cacheWriter ::+ (MonadUnliftIO m, MonadLoggerIO m, StoreRead m)+ => CacheConfig+ -> CacheWriterInbox+ -> m ()+cacheWriter cfg inbox =+ runReaderT+ (newBlockC >> forever (pruneDB >> receive inbox >>= cacheWriterReact))+ cfg++pruneDB :: (MonadLoggerIO m, StoreRead m) => CacheT m Integer+pruneDB = do+ x <- asks cacheMax+ s <- runRedisReply Redis.dbsize+ if s > x+ then do+ n <- flush (s - x)+ $(logDebugS) "Cache" $ "Pruned " <> cs (show n) <> " keys"+ return n+ else return 0+ where+ flush n = do+ n' <-+ runRedisReply $ do+ eks <- getFromSortedSet maxKey Nothing 0 (Just 10)+ case eks of+ Right ks -> do+ xs <- sequence <$> forM (map fst ks) redisDelXPubKeys+ return $ xs >>= return . sum+ Left _ -> return $ eks >> return 0+ if n <= n'+ then return n'+ else (n' +) <$> flush (n - n')++touchKeys :: Real a => a -> [XPubSpec] -> RedisReply Integer+touchKeys _ [] = return (pure 0)+touchKeys now xpubs =+ Redis.zadd maxKey $ map ((realToFrac now, ) . encode) xpubs++cacheWriterReact ::+ (MonadUnliftIO m, MonadLoggerIO m, StoreRead m)+ => CacheWriterMessage+ -> CacheT m ()+cacheWriterReact CacheNewBlock = newBlockC+cacheWriterReact (CacheNewTx txh) = newTxC txh+cacheWriterReact (CacheDelTx txh) = newTxC txh++lenNotNull :: [XPubBal] -> Int+lenNotNull bals = length $ filter (not . nullBalance . xPubBal) bals++newXPubC ::+ (MonadLoggerIO m, StoreRead m)+ => XPubSpec+ -> CacheT m ([XPubBal], Bool)+newXPubC xpub = do+ bals <- cacheGetXPubBalances xpub+ x <- asks cacheMin+ if null bals+ then do+ bals' <- lift $ xPubBals xpub+ case lenNotNull bals' of+ 0 -> return (bals', False)+ _+ | x <= lenNotNull bals' -> go bals' >> return (bals', True)+ | otherwise -> return (bals', False)+ else return (bals, False)+ where+ go bals = do+ $(logDebugS) "Cache" $+ "Adding xpub with " <> cs (show (lenNotNull bals)) <> " balances"+ utxo <- lift $ xPubUnspents xpub Nothing 0 Nothing+ xtxs <- lift $ xPubTxs xpub Nothing 0 Nothing+ now <- systemSeconds <$> liftIO getSystemTime+ runRedisReply $ do+ x <- redisAddXPubBalances xpub bals+ y <-+ redisAddXPubUnspents+ xpub+ (map ((\u -> (unspentPoint u, unspentBlock u)) . xPubUnspent)+ utxo)+ z <- redisAddXPubTxs xpub xtxs+ a <- touchKeys now [xpub]+ return $ x >> y >> z >> a >> return ()++newBlockC :: (MonadLoggerIO m, StoreRead m) => CacheT m ()+newBlockC =+ lift getBestBlock >>= \case+ Nothing -> $(logErrorS) "Cache" "Best block not set yet"+ Just newhead -> do+ cacheGetHead >>= \case+ Nothing -> do+ $(logInfoS) "Cache" "Cache has no best block set"+ importBlockC newhead+ Just cachehead -> go newhead cachehead+ where+ go newhead cachehead+ | cachehead == newhead = return ()+ | otherwise = do+ ch <- asks cacheChain+ chainGetBlock newhead ch >>= \case+ Nothing -> do+ $(logErrorS) "Cache" $+ "No header for new head: " <> blockHashToHex newhead+ throwIO . LogicError . cs $+ "No header for new head: " <> blockHashToHex newhead+ Just newheadnode ->+ chainGetBlock cachehead ch >>= \case+ Nothing -> do+ $(logErrorS) "Cache" $+ "No header for cache head: " <>+ blockHashToHex cachehead+ Just cacheheadnode -> go2 newheadnode cacheheadnode+ go2 newheadnode cacheheadnode+ | nodeHeight cacheheadnode > nodeHeight newheadnode = do+ $(logErrorS) "Cache" $+ "Cache head is above new best block: " <>+ blockHashToHex (headerHash (nodeHeader newheadnode))+ | otherwise = do+ ch <- asks cacheChain+ split <- chainGetSplitBlock cacheheadnode newheadnode ch+ if split == cacheheadnode+ then if prevBlock (nodeHeader newheadnode) ==+ headerHash (nodeHeader cacheheadnode)+ then importBlockC (headerHash (nodeHeader newheadnode))+ else go3 newheadnode cacheheadnode+ else removeHeadC >> newBlockC+ go3 newheadnode cacheheadnode = do+ ch <- asks cacheChain+ chainGetAncestor (nodeHeight cacheheadnode + 1) newheadnode ch >>= \case+ Nothing -> do+ $(logErrorS) "Cache" $+ "Could not get expected ancestor block at height " <>+ cs (show (nodeHeight cacheheadnode + 1)) <>+ " for: " <>+ blockHashToHex (headerHash (nodeHeader newheadnode))+ throwIO $ LogicError "Could not get expected ancestor block"+ Just a -> do+ importBlockC (headerHash (nodeHeader a))+ newBlockC++newTxC :: (MonadLoggerIO m, StoreRead m) => TxHash -> CacheT m ()+newTxC th =+ lift (getTxData th) >>= \case+ Just txd -> importMultiTxC [txd]+ Nothing ->+ $(logErrorS) "Cache" $ "Transaction not found: " <> txHashToHex th++importBlockC :: (StoreRead m, MonadLoggerIO m) => BlockHash -> CacheT m ()+importBlockC bh =+ lift (getBlock bh) >>= \case+ Nothing -> do+ $(logErrorS) "Cache" $ "Could not get block: " <> blockHashToHex bh+ throwIO . LogicError . cs $+ "Could not get block: " <> blockHashToHex bh+ Just bd -> do+ $(logInfoS) "Cache" $ "Importing block: " <> blockHashToHex bh+ go bd+ where+ go bd = do+ let ths = blockDataTxs bd+ tds <- sortTxData . catMaybes <$> mapM (lift . getTxData) ths+ importMultiTxC tds+ cacheSetHead bh++removeHeadC :: (StoreRead m, MonadLoggerIO m) => CacheT m ()+removeHeadC =+ void . runMaybeT $ do+ bh <- MaybeT cacheGetHead+ bd <- MaybeT (lift (getBlock bh))+ lift $ do+ tds <-+ sortTxData . catMaybes <$>+ mapM (lift . getTxData) (blockDataTxs bd)+ $(logWarnS) "Cache" $ "Reverting head: " <> blockHashToHex bh+ forM_ (reverse (map (txHash . txData) tds)) newTxC+ cacheSetHead (prevBlock (blockDataHeader bd))+ syncMempoolC++importMultiTxC :: (StoreRead m, MonadLoggerIO m) => [TxData] -> CacheT m ()+importMultiTxC txs = do+ addrmap <-+ Map.fromList . catMaybes . zipWith (\a -> fmap (a, )) alladdrs <$>+ cacheGetAddrsInfo alladdrs+ balmap <-+ Map.fromList . zipWith (,) alladdrs <$>+ mapM (lift . getBalance) alladdrs+ unspentmap <-+ Map.fromList . catMaybes . zipWith (\p -> fmap (p, )) allops <$>+ lift (mapM getUnspent allops)+ gap <- getMaxGap+ now <- systemSeconds <$> liftIO getSystemTime+ newaddrs <-+ runRedisReply $ do+ x <- redisImportMultiTx addrmap unspentmap txs+ y <- redisUpdateBalances addrmap balmap+ z <- touchKeys now (allxpubs addrmap)+ newaddrs <- redisGetNewAddrs gap addrmap+ return $ x >> y >> z >> newaddrs+ unless (Map.null newaddrs) $ cacheAddAddresses newaddrs+ where+ allops = map snd $ concatMap txInputs txs <> concatMap txOutputs txs+ alladdrs = nub . map fst $ concatMap txInputs txs <> concatMap txOutputs txs+ allxpubs addrmap = nub . map addressXPubSpec $ Map.elems addrmap++redisImportMultiTx ::+ Map Address AddressXPub+ -> Map OutPoint Unspent+ -> [TxData]+ -> RedisReply ()+redisImportMultiTx addrmap unspentmap txs = do+ xs <- mapM importtxentries txs+ return $ sequence xs >> return ()+ where+ uns p i =+ case Map.lookup p unspentmap of+ Just u ->+ redisAddXPubUnspents (addressXPubSpec i) [(p, unspentBlock u)]+ Nothing -> redisRemXPubUnspents (addressXPubSpec i) [p]+ addtx tx a p =+ case Map.lookup a addrmap of+ Just i -> do+ x <-+ redisAddXPubTxs+ (addressXPubSpec i)+ [ BlockTx+ { blockTxHash = txHash (txData tx)+ , blockTxBlock = txDataBlock tx+ }+ ]+ y <- uns p i+ return $ x >> y >> return ()+ Nothing -> return (pure ())+ remtx tx a p =+ case Map.lookup a addrmap of+ Just i -> do+ x <- redisRemXPubTxs (addressXPubSpec i) [txHash (txData tx)]+ y <- uns p i+ return $ x >> y >> return ()+ Nothing -> return (pure ())+ importtxentries tx =+ if txDataDeleted tx+ then do+ x <- mapM (uncurry (remtx tx)) (txaddrops tx)+ y <- redisRemFromMempool (txHash (txData tx))+ return $ sequence x >> y >> return ()+ else do+ tops <- mapM (uncurry (addtx tx)) (txaddrops tx)+ mem <-+ case txDataBlock tx of+ b@MemRef {} ->+ redisAddToMempool+ BlockTx+ { blockTxHash = txHash (txData tx)+ , blockTxBlock = b+ }+ _ -> redisRemFromMempool (txHash (txData tx))+ return $ sequence tops >> mem >> return ()+ txaddrops td = spnts td <> utxos td+ spnts td = txInputs td+ utxos td = txOutputs td++redisUpdateBalances ::+ Map Address AddressXPub -> Map Address Balance -> RedisReply ()+redisUpdateBalances addrmap balmap = do+ bs <-+ forM (Map.keys addrmap) $ \a ->+ let ainfo = fromJust (Map.lookup a addrmap)+ bal = fromJust (Map.lookup a balmap)+ in redisAddXPubBalances (addressXPubSpec ainfo) [xpubbal ainfo bal]+ return $ sequence bs >> return ()+ where+ xpubbal ainfo bal =+ XPubBal {xPubBalPath = addressXPubPath ainfo, xPubBal = bal}++cacheAddAddresses ::+ (StoreRead m, MonadLoggerIO m)+ => Map Address AddressXPub+ -> CacheT m ()+cacheAddAddresses addrmap = do+ gap <- getMaxGap+ newmap <- runRedisReply (redisGetNewAddrs gap addrmap)+ balmap <- Map.fromList <$> mapM getbal (Map.keys newmap)+ utxomap <- Map.fromList <$> mapM getutxo (Map.keys newmap)+ txmap <- Map.fromList <$> mapM gettxmap (Map.keys newmap)+ let notnulls = getnotnull newmap balmap+ xpubbals = getxpubbals newmap balmap+ unspents = getunspents newmap utxomap+ txs = gettxs newmap txmap+ newaddrs <-+ runRedisReply $ do+ x' <-+ forM (HashMap.toList xpubbals) $ \(x, bs) ->+ redisAddXPubBalances x bs+ y' <-+ forM (HashMap.toList unspents) $ \(x, us) ->+ redisAddXPubUnspents x (map uns us)+ z' <- forM (HashMap.toList txs) $ \(x, ts) -> redisAddXPubTxs x ts+ newaddrs <- redisGetNewAddrs gap notnulls+ return $ do+ _ <- sequence x'+ _ <- sequence y'+ _ <- sequence z'+ newaddrs+ unless (null newaddrs) $ cacheAddAddresses newaddrs+ where+ uns u = (unspentPoint u, unspentBlock u)+ gettxs newmap txmap =+ let f a ts =+ let i = fromJust (Map.lookup a newmap)+ in (addressXPubSpec i, ts)+ g m (x, ts) = HashMap.insertWith (<>) x ts m+ in foldl g HashMap.empty (map (uncurry f) (Map.toList txmap))+ getunspents newmap utxomap =+ let f a us =+ let i = fromJust (Map.lookup a newmap)+ in (addressXPubSpec i, us)+ g m (x, us) = HashMap.insertWith (<>) x us m+ in foldl g HashMap.empty (map (uncurry f) (Map.toList utxomap))+ getxpubbals newmap balmap =+ let f a b =+ let i = fromJust (Map.lookup a newmap)+ in ( addressXPubSpec i+ , XPubBal {xPubBal = b, xPubBalPath = addressXPubPath i})+ g m (x, b) = HashMap.insertWith (<>) x [b] m+ in foldl g HashMap.empty (map (uncurry f) (Map.toList balmap))+ getnotnull newmap balmap =+ let f a _ =+ let i = fromJust (Map.lookup a newmap)+ in (a, i)+ in Map.fromList . map (uncurry f) . Map.toList $+ Map.filter (not . nullBalance) balmap+ getbal a = (a, ) <$> lift (getBalance a)+ getutxo a = (a, ) <$> lift (getAddressUnspents a Nothing Nothing)+ gettxmap a = (a, ) <$> lift (getAddressTxs a Nothing Nothing)++redisGetNewAddrs ::+ KeyIndex+ -> Map Address AddressXPub+ -> RedisReply (Map Address AddressXPub)+redisGetNewAddrs gap addrmap =+ xbalmap >>= \xbalmap' ->+ return $ do+ xbmap' <- xbalmap'+ return . Map.fromList $+ concatMap (uncurry newaddrs) (HashMap.toList xbmap')+ where+ xbalmap = do+ xbs <-+ forM xpubs $ \xpub -> do+ bals <- redisGetXPubBalances xpub+ return $ bals >>= return . (xpub, )+ return $ do+ xbs' <- sequence xbs+ return $ HashMap.fromList xbs'+ newaddrs xpub bals =+ let paths = HashMap.lookupDefault [] xpub xpubmap+ ext = maximum . map (head . tail) $ filter ((== 0) . head) paths+ chg = maximum . map (head . tail) $ filter ((== 1) . head) paths+ extnew =+ addrsToAdd+ bals+ gap+ AddressXPub+ {addressXPubSpec = xpub, addressXPubPath = [0, ext]}+ intnew =+ addrsToAdd+ bals+ gap+ AddressXPub+ {addressXPubSpec = xpub, addressXPubPath = [1, chg]}+ in extnew <> intnew+ xpubs = HashMap.keys xpubmap+ xpubmap =+ let f xmap ainfo =+ let xpub = addressXPubSpec ainfo+ path = addressXPubPath ainfo+ in HashMap.insertWith (<>) xpub [path] xmap+ in foldl f HashMap.empty (Map.elems addrmap)++syncMempoolC :: (MonadLoggerIO m, StoreRead m) => CacheT m ()+syncMempoolC = do+ nodepool <- map blockTxHash <$> lift getMempool+ cachepool <- map blockTxHash <$> cacheGetMempool+ txs <- catMaybes <$> mapM (lift . getTxData) (nodepool <> cachepool)+ importMultiTxC txs++cacheGetMempool :: MonadIO m => CacheT m [BlockTx]+cacheGetMempool = runRedisReply redisGetMempool++cacheGetHead :: MonadIO m => CacheT m (Maybe BlockHash)+cacheGetHead = runRedisReply redisGetHead++cacheSetHead :: MonadIO m => BlockHash -> CacheT m ()+cacheSetHead bh = runRedisReply (redisSetHead bh) >> return ()++cacheGetAddrsInfo ::+ MonadIO m => [Address] -> CacheT m [Maybe AddressXPub]+cacheGetAddrsInfo as = runRedisReply (redisGetAddrsInfo as)++redisAddToMempool :: BlockTx -> Redis (Either Reply Integer)+redisAddToMempool btx =+ zadd+ mempoolSetKey+ [(blockRefScore (blockTxBlock btx), encode (blockTxHash btx))]++redisRemFromMempool :: TxHash -> RedisReply Integer+redisRemFromMempool th = zrem mempoolSetKey [encode th]++redisSetAddrInfo :: Address -> AddressXPub -> RedisReply Redis.Status+redisSetAddrInfo a i = Redis.set (addrPfx <> encode a) (encode i)++redisDelXPubKeys :: XPubSpec -> RedisReply Integer+redisDelXPubKeys xpub = do+ ebals <- redisGetXPubBalances xpub+ case ebals of+ Right bals -> go (map (balanceAddress . xPubBal) bals)+ Left _ -> return $ ebals >> return 0+ where+ go addrs = do+ addrcount <-+ if null addrs+ then return (pure 0)+ else Redis.del (map ((addrPfx <>) . encode) addrs)+ txsetcount <- Redis.del [txSetPfx <> encode xpub]+ utxocount <- Redis.del [utxoPfx <> encode xpub]+ balcount <- Redis.del [balancesPfx <> encode xpub]+ return $ do+ addrs' <- addrcount+ txset' <- txsetcount+ utxo' <- utxocount+ bal' <- balcount+ return $ addrs' + txset' + utxo' + bal'++redisAddXPubTxs :: XPubSpec -> [BlockTx] -> RedisReply Integer+redisAddXPubTxs _ [] = return (Right 0)+redisAddXPubTxs xpub btxs =+ zadd (txSetPfx <> encode xpub) $+ map (\t -> (blockRefScore (blockTxBlock t), encode (blockTxHash t))) btxs++redisRemXPubTxs :: XPubSpec -> [TxHash] -> RedisReply Integer+redisRemXPubTxs xpub txhs = zrem (txSetPfx <> encode xpub) (map encode txhs)++redisAddXPubUnspents :: XPubSpec -> [(OutPoint, BlockRef)] -> RedisReply Integer+redisAddXPubUnspents _ [] = return (Right 0)+redisAddXPubUnspents xpub utxo =+ zadd (utxoPfx <> encode xpub) $+ map (\(p, r) -> (blockRefScore r, encode p)) utxo++redisRemXPubUnspents ::+ XPubSpec -> [OutPoint] -> RedisReply Integer+redisRemXPubUnspents _ [] = return (Right 0)+redisRemXPubUnspents xpub ops = zrem (utxoPfx <> encode xpub) (map encode ops)++redisAddXPubBalances :: XPubSpec -> [XPubBal] -> RedisReply ()+redisAddXPubBalances _ [] = return (pure ())+redisAddXPubBalances xpub bals = do+ xs <- mapM (uncurry (Redis.hset (balancesPfx <> encode xpub))) entries+ ys <-+ forM bals $ \b ->+ redisSetAddrInfo+ (balanceAddress (xPubBal b))+ AddressXPub+ {addressXPubSpec = xpub, addressXPubPath = xPubBalPath b}+ return $ sequence xs >> sequence ys >> return ()+ where+ entries = map (\b -> (encode (xPubBalPath b), encode (xPubBal b))) bals++redisSetHead :: BlockHash -> RedisReply Redis.Status+redisSetHead bh = Redis.set bestBlockKey (encode bh)++redisGetAddrsInfo :: [Address] -> RedisReply [Maybe AddressXPub]+redisGetAddrsInfo [] = return (Right [])+redisGetAddrsInfo as = do+ is <- mapM (\a -> Redis.get (addrPfx <> encode a)) as+ return $ do+ is' <- sequence is+ return $ map (eitherToMaybe . decode =<<) is'++addrsToAdd ::+ [XPubBal]+ -> KeyIndex+ -> AddressXPub+ -> [(Address, AddressXPub)]+addrsToAdd xbals gap addrinfo =+ let headi = head (addressXPubPath addrinfo)+ maxi =+ maximum $+ map (head . tail . xPubBalPath) $+ filter ((== headi) . head . xPubBalPath) xbals+ xpub = addressXPubSpec addrinfo+ newi = head (tail (addressXPubPath addrinfo))+ genixs =+ if maxi - newi < gap+ then [maxi + 1 .. newi + gap]+ else []+ paths = map (Deriv :/ headi :/) genixs+ keys = map (\p -> derivePubPath p (xPubSpecKey xpub)) paths+ list = map pathToList paths+ xpubf = xPubAddrFunction (xPubDeriveType xpub)+ addrs = map xpubf keys+ in zipWith+ (\a p ->+ (a, AddressXPub {addressXPubSpec = xpub, addressXPubPath = p}))+ addrs+ list++sortTxData :: [TxData] -> [TxData]+sortTxData tds =+ let txm = Map.fromList (map (\d -> (txHash (txData d), d)) tds)+ ths = map (txHash . snd) (sortTxs (map txData tds))+ in mapMaybe (\h -> Map.lookup h txm) ths++txInputs :: TxData -> [(Address, OutPoint)]+txInputs td =+ let is = txIn (txData td)+ ps = IntMap.toAscList (txDataPrevs td)+ as = map (scriptToAddressBS . prevScript . snd) ps+ f (Right a) i = Just (a, prevOutput i)+ f (Left _) _ = Nothing+ in catMaybes (zipWith f as is)++txOutputs :: TxData -> [(Address, OutPoint)]+txOutputs td =+ let ps =+ zipWith+ (\i _ ->+ OutPoint+ {outPointHash = txHash (txData td), outPointIndex = i})+ [0 ..]+ (txOut (txData td))+ as = map (scriptToAddressBS . scriptOutput) (txOut (txData td))+ f (Right a) p = Just (a, p)+ f (Left _) _ = Nothing+ in catMaybes (zipWith f as ps)++redisGetHead :: RedisReply (Maybe BlockHash)+redisGetHead = do+ x <- Redis.get bestBlockKey+ return $ (eitherToMaybe . decode =<<) <$> x++redisGetMempool :: RedisReply [BlockTx]+redisGetMempool = do+ xs <- getFromSortedSet mempoolSetKey Nothing 0 Nothing+ return $ do+ ys <- xs+ return $ map (uncurry f) ys+ where+ f t s = BlockTx {blockTxBlock = scoreBlockRef s, blockTxHash = t}
+ src/Haskoin/Store/Common.hs view
@@ -0,0 +1,1387 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+module Haskoin.Store.Common+ ( BlockStoreMessage(..)+ , DeriveType(..)+ , Limit+ , Offset+ , BlockStore+ , UnixTime+ , getUnixTime+ , putUnixTime+ , BlockPos+ , XPubSpec(..)+ , StoreRead(..)+ , StoreWrite(..)+ , JsonSerial(..)+ , BinSerial(..)+ , BlockRef(..)+ , BlockTx(..)+ , confirmed+ , Balance(..)+ , BlockData(..)+ , StoreInput(..)+ , isCoinbase+ , Spender(..)+ , StoreOutput(..)+ , Prev(..)+ , TxData(..)+ , Unspent(..)+ , Transaction(..)+ , transactionData+ , fromTransaction+ , toTransaction+ , TxAfterHeight(..)+ , TxId(..)+ , PeerInformation(..)+ , XPubBal(..)+ , XPubUnspent(..)+ , XPubSummary(..)+ , HealthCheck(..)+ , Event(..)+ , StoreEvent(..)+ , PubExcept(..)+ , zeroBalance+ , nullBalance+ , getTransaction+ , blockAtOrBefore+ , applyOffset+ , applyLimit+ , applyOffsetLimit+ , applyOffsetC+ , applyLimitC+ , applyOffsetLimitC+ , sortTxs+ ) where++import Conduit (ConduitT, dropC, mapC, takeC)+import Control.Applicative ((<|>))+import Control.DeepSeq (NFData)+import Control.Exception (Exception)+import Control.Monad (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.Function (on)+import Data.Hashable (Hashable (..))+import qualified Data.IntMap as I+import Data.IntMap.Strict (IntMap)+import Data.List (nub, partition, sortBy)+import Data.Maybe (catMaybes, isJust, listToMaybe,+ mapMaybe)+import Data.Serialize (Get, Put, Putter, Serialize (..),+ getListOf, getShortByteString,+ getWord32be, getWord64be, getWord8,+ putListOf, putShortByteString,+ putWord32be, putWord64be, putWord8)+import qualified Data.Serialize as S+import Data.String.Conversions (cs)+import qualified Data.Text.Encoding as T+import Data.Word (Word32, Word64)+import GHC.Generics (Generic)+import Haskoin (Address, Block, BlockHash,+ BlockHeader (..), BlockHeight,+ BlockNode, BlockWork, HostAddress,+ KeyIndex, Network (..),+ NetworkAddress (..), OutPoint (..),+ PubKeyI (..), RejectCode (..),+ Tx (..), TxHash (..), TxIn (..),+ TxOut (..), WitnessStack,+ XPubKey (..), addrToJSON,+ addrToString, deriveAddr,+ deriveCompatWitnessAddr,+ deriveWitnessAddr, eitherToMaybe,+ encodeHex, headerHash,+ hostToSockAddr, pubSubKey,+ scriptToAddressBS, stringToAddr,+ txHash, wrapPubKey)+import Haskoin.Node (Peer)+import Network.Socket (SockAddr)+import NQE (Listen, Mailbox)+import qualified Paths_haskoin_store as P++data DeriveType+ = DeriveNormal+ | DeriveP2SH+ | DeriveP2WPKH+ deriving (Show, Eq, Generic, NFData, Serialize)++-- | Messages for block store actor.+data BlockStoreMessage+ = 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++-- | Mailbox for block store.+type BlockStore = Mailbox BlockStoreMessage++data XPubSpec =+ XPubSpec+ { xPubSpecKey :: !XPubKey+ , xPubDeriveType :: !DeriveType+ } deriving (Show, Eq, Generic, NFData)++instance Hashable XPubSpec where+ hashWithSalt i XPubSpec {xPubSpecKey = XPubKey {xPubKey = pubkey}} =+ hashWithSalt i pubkey++instance Serialize XPubSpec where+ put XPubSpec {xPubSpecKey = k, xPubDeriveType = t} = do+ put (xPubDepth k)+ put (xPubParent k)+ put (xPubIndex k)+ put (xPubChain k)+ put (wrapPubKey True (xPubKey k))+ put t+ get = do+ d <- get+ p <- get+ i <- get+ c <- get+ k <- get+ t <- get+ let x =+ XPubKey+ { xPubDepth = d+ , xPubParent = p+ , xPubIndex = i+ , xPubChain = c+ , xPubKey = pubKeyPoint k+ }+ return XPubSpec {xPubSpecKey = x, xPubDeriveType = t}++type DeriveAddr = XPubKey -> KeyIndex -> Address++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))+ getOrphans :: m [(UnixTime, Tx)]+ getSpenders :: TxHash -> m (IntMap Spender)+ getSpender :: OutPoint -> m (Maybe Spender)+ getBalance :: Address -> m Balance+ getBalance a = head <$> getBalances [a]+ getBalances :: [Address] -> m [Balance]+ getBalances as = mapM getBalance as+ getAddressesTxs :: [Address] -> Maybe BlockRef -> Maybe Limit -> m [BlockTx]+ getAddressTxs :: Address -> Maybe BlockRef -> Maybe Limit -> m [BlockTx]+ getAddressTxs a = getAddressesTxs [a]+ getUnspent :: OutPoint -> m (Maybe Unspent)+ getAddressUnspents ::+ Address -> Maybe BlockRef -> Maybe Limit -> m [Unspent]+ getAddressUnspents a = getAddressesUnspents [a]+ getAddressesUnspents ::+ [Address] -> Maybe BlockRef -> Maybe Limit -> m [Unspent]+ getMempool :: m [BlockTx]+ xPubBals :: XPubSpec -> m [XPubBal]+ xPubBals xpub = do+ gap <- getMaxGap+ ext <-+ derive_until_gap+ gap+ 0+ (deriveAddresses+ (deriveFunction (xPubDeriveType xpub))+ (pubSubKey (xPubSpecKey xpub) 0)+ 0)+ chg <-+ derive_until_gap+ gap+ 1+ (deriveAddresses+ (deriveFunction (xPubDeriveType xpub))+ (pubSubKey (xPubSpecKey xpub) 1)+ 0)+ return (ext ++ chg)+ where+ xbalance m b n = XPubBal {xPubBalPath = [m, n], xPubBal = b}+ derive_until_gap _ _ [] = return []+ derive_until_gap gap m as = do+ let (as1, as2) = splitAt (fromIntegral gap) as+ bs <- getBalances (map snd as1)+ let xbs = zipWith (xbalance m) bs (map fst as1)+ if all nullBalance bs+ then return xbs+ else (xbs <>) <$> derive_until_gap gap m as2+ xPubSummary :: XPubSpec -> m XPubSummary+ xPubSummary xpub = do+ bs <- filter (not . nullBalance . xPubBal) <$> xPubBals xpub+ let ex = foldl max 0 [i | XPubBal {xPubBalPath = [0, i]} <- bs]+ ch = foldl max 0 [i | XPubBal {xPubBalPath = [1, i]} <- bs]+ uc =+ sum+ [ c+ | XPubBal {xPubBal = Balance {balanceUnspentCount = c}} <-+ bs+ ]+ xt = [b | b@XPubBal {xPubBalPath = [0, _]} <- bs]+ rx =+ sum+ [ r+ | XPubBal {xPubBal = Balance {balanceTotalReceived = r}} <-+ xt+ ]+ return+ XPubSummary+ { xPubSummaryConfirmed = sum (map (balanceAmount . xPubBal) bs)+ , xPubSummaryZero = sum (map (balanceZero . xPubBal) bs)+ , xPubSummaryReceived = rx+ , xPubUnspentCount = uc+ , xPubChangeIndex = ch+ , xPubExternalIndex = ex+ }+ xPubUnspents ::+ XPubSpec+ -> Maybe BlockRef+ -> Offset+ -> Maybe Limit+ -> m [XPubUnspent]+ xPubUnspents xpub start offset limit = do+ xs <- filter positive <$> xPubBals xpub+ applyOffsetLimit offset limit <$> go xs+ where+ positive XPubBal {xPubBal = Balance {balanceUnspentCount = c}} = c > 0+ go [] = return []+ go (XPubBal {xPubBalPath = p, xPubBal = Balance {balanceAddress = a}}:xs) = do+ uns <- getAddressUnspents a start limit+ let xuns =+ map+ (\t ->+ XPubUnspent {xPubUnspentPath = p, xPubUnspent = t})+ uns+ (xuns <>) <$> go xs+ xPubTxs ::+ XPubSpec -> Maybe BlockRef -> Offset -> Maybe Limit -> m [BlockTx]+ xPubTxs xpub start offset limit = do+ bs <- xPubBals xpub+ let as = map (balanceAddress . xPubBal) bs+ ts <- concat <$> mapM (\a -> getAddressTxs a start limit) as+ let ts' = nub $ sortBy (flip compare `on` blockTxBlock) ts+ return $ applyOffsetLimit offset limit ts'+ getMaxGap :: m Word32+ getMaxGap = return 32++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 :: [BlockTx] -> m ()+ insertOrphanTx :: Tx -> UnixTime -> m ()+ deleteOrphanTx :: TxHash -> m ()+ setBalance :: Balance -> m ()+ insertUnspent :: Unspent -> m ()+ deleteUnspent :: OutPoint -> m ()++deriveAddresses :: DeriveAddr -> XPubKey -> Word32 -> [(Word32, Address)]+deriveAddresses derive xpub start = map (\i -> (i, derive xpub i)) [start ..]++deriveFunction :: DeriveType -> DeriveAddr+deriveFunction DeriveNormal i = fst . deriveAddr i+deriveFunction DeriveP2SH i = fst . deriveCompatWitnessAddr i+deriveFunction DeriveP2WPKH i = fst . deriveWitnessAddr i++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+ }++nullBalance :: Balance -> Bool+nullBalance Balance { balanceAmount = 0+ , balanceUnspentCount = 0+ , balanceZero = 0+ , balanceTxCount = 0+ , balanceTotalReceived = 0+ } = True+nullBalance _ = False++-- | 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]++-- | 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)]++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, Ord, 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, Serialize, 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+ }+ deriving (Eq, Show, Generic, Serialize, NFData)++xPubSummaryPairs :: A.KeyValue kv => XPubSummary -> [kv]+xPubSummaryPairs XPubSummary { xPubSummaryConfirmed = c+ , xPubSummaryZero = z+ , xPubSummaryReceived = r+ , xPubUnspentCount = u+ , xPubExternalIndex = ext+ , xPubChangeIndex = ch+ } =+ [ "balance" .=+ object+ ["confirmed" .= c, "unconfirmed" .= z, "received" .= r, "utxo" .= u]+ , "indices" .= object ["change" .= ch, "external" .= ext]+ ]++xPubSummaryToJSON :: XPubSummary -> Value+xPubSummaryToJSON = object . xPubSummaryPairs++xPubSummaryToEncoding :: XPubSummary -> Encoding+xPubSummaryToEncoding = pairs . mconcat . xPubSummaryPairs++instance ToJSON XPubSummary where+ toJSON = xPubSummaryToJSON+ toEncoding = xPubSummaryToEncoding++instance JsonSerial XPubSummary where+ jsonSerial _ = xPubSummaryToEncoding+ jsonValue _ = xPubSummaryToJSON++instance BinSerial XPubSummary where+ binSerial _ = put+ binDeserial _ = get++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++-- | 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 :: Offset -> Maybe Limit -> [a] -> [a]+applyOffsetLimit offset limit = applyLimit limit . applyOffset offset++applyOffset :: Offset -> [a] -> [a]+applyOffset = drop . fromIntegral++applyLimit :: Maybe Limit -> [a] -> [a]+applyLimit Nothing = id+applyLimit (Just l) = take (fromIntegral l)++applyOffsetLimitC :: Monad m => Offset -> Maybe Limit -> ConduitT i i m ()+applyOffsetLimitC offset limit = applyOffsetC offset >> applyLimitC limit++applyOffsetC :: Monad m => Offset -> ConduitT i i m ()+applyOffsetC = dropC . fromIntegral++applyLimitC :: Monad m => Maybe Limit -> ConduitT i i m ()+applyLimitC Nothing = mapC id+applyLimitC (Just l) = takeC (fromIntegral l)++sortTxs :: [Tx] -> [(Word32, Tx)]+sortTxs txs = go $ zip [0 ..] txs+ where+ go [] = []+ go ts =+ let (is, ds) =+ partition+ (all ((`notElem` map (txHash . snd) ts) .+ outPointHash . prevOutput) .+ txIn . snd)+ ts+ in is <> go ds
+ src/Haskoin/Store/Database/Memory.hs view
@@ -0,0 +1,392 @@+{-# LANGUAGE FlexibleInstances #-}+module Haskoin.Store.Database.Memory+ ( MemoryState(..)+ , MemoryDatabase(..)+ , withMemoryDatabase+ , emptyMemoryDatabase+ , getMempoolH+ , getOrphanTxH+ , getSpenderH+ , getSpendersH+ , getUnspentH+ ) where++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 (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 (nub, sortBy)+import Data.Maybe (catMaybes, fromJust, fromMaybe,+ isJust)+import Data.Word (Word32)+import Haskoin (Address, BlockHash, BlockHeight,+ OutPoint (..), Tx, TxHash,+ headerHash, txHash)+import Haskoin.Store.Common (Balance, BlockData (..),+ BlockRef, BlockTx (..), Limit,+ Spender, StoreRead (..),+ StoreWrite (..), TxData (..),+ UnixTime, Unspent (..),+ applyLimit, zeroBalance)+import Haskoin.Store.Database.Types (BalVal, OutVal (..), UnspentVal,+ balanceToVal, unspentToVal,+ valToBalance, valToUnspent)+import UnliftIO++data MemoryState =+ MemoryState+ { memoryDatabase :: !(TVar MemoryDatabase)+ , memoryMaxGap :: !Word32+ }++withMemoryDatabase ::+ MonadIO m+ => MemoryState+ -> ReaderT MemoryState m a+ -> m a+withMemoryDatabase = flip R.runReaderT++data MemoryDatabase = MemoryDatabase+ { hBest :: !(Maybe BlockHash)+ , hBlock :: !(HashMap BlockHash BlockData)+ , hHeight :: !(HashMap BlockHeight [BlockHash])+ , hTx :: !(HashMap TxHash TxData)+ , hSpender :: !(HashMap TxHash (IntMap (Maybe Spender)))+ , hUnspent :: !(HashMap TxHash (IntMap (Maybe UnspentVal)))+ , hBalance :: !(HashMap Address BalVal)+ , hAddrTx :: !(HashMap Address (HashMap BlockRef (HashMap TxHash Bool)))+ , hAddrOut :: !(HashMap Address (HashMap BlockRef (HashMap OutPoint (Maybe OutVal))))+ , hMempool :: !(Maybe [BlockTx])+ , hOrphans :: !(HashMap TxHash (Maybe (UnixTime, Tx)))+ } deriving (Eq, Show)++emptyMemoryDatabase :: MemoryDatabase+emptyMemoryDatabase =+ MemoryDatabase+ { hBest = Nothing+ , hBlock = M.empty+ , hHeight = M.empty+ , hTx = M.empty+ , hSpender = M.empty+ , hUnspent = M.empty+ , hBalance = M.empty+ , hAddrTx = M.empty+ , hAddrOut = M.empty+ , hMempool = Nothing+ , hOrphans = M.empty+ }++getBestBlockH :: MemoryDatabase -> Maybe BlockHash+getBestBlockH = hBest++getBlocksAtHeightH :: BlockHeight -> MemoryDatabase -> [BlockHash]+getBlocksAtHeightH h = M.lookupDefault [] h . hHeight++getBlockH :: BlockHash -> MemoryDatabase -> Maybe BlockData+getBlockH h = M.lookup h . hBlock++getTxDataH :: TxHash -> MemoryDatabase -> Maybe TxData+getTxDataH t = M.lookup t . hTx++getSpenderH :: OutPoint -> MemoryDatabase -> Maybe (Maybe Spender)+getSpenderH op db = do+ m <- M.lookup (outPointHash op) (hSpender db)+ I.lookup (fromIntegral (outPointIndex op)) m++getSpendersH :: TxHash -> MemoryDatabase -> IntMap (Maybe Spender)+getSpendersH t = M.lookupDefault I.empty t . hSpender++getBalanceH :: Address -> MemoryDatabase -> Balance+getBalanceH a =+ fromMaybe (zeroBalance a) . fmap (valToBalance a) . M.lookup a . hBalance++getMempoolH :: MemoryDatabase -> Maybe [BlockTx]+getMempoolH = hMempool++getOrphansH :: MemoryDatabase -> [(UnixTime, Tx)]+getOrphansH = catMaybes . M.elems . hOrphans++getOrphanTxH :: TxHash -> MemoryDatabase -> Maybe (Maybe (UnixTime, Tx))+getOrphanTxH h = M.lookup h . hOrphans++getAddressesTxsH ::+ [Address] -> Maybe BlockRef -> Maybe Limit -> MemoryDatabase -> [BlockTx]+getAddressesTxsH addrs start limit db = applyLimit limit xs+ where+ xs =+ nub . sortBy (flip compare `on` blockTxBlock) . concat $+ map (\a -> getAddressTxsH a start limit db) addrs++getAddressTxsH ::+ Address -> Maybe BlockRef -> Maybe Limit -> MemoryDatabase -> [BlockTx]+getAddressTxsH addr start limit db =+ applyLimit limit .+ dropWhile h .+ sortBy (flip compare) . catMaybes . concatMap (uncurry f) . M.toList $+ M.lookupDefault M.empty addr (hAddrTx db)+ where+ f b hm = map (uncurry (g b)) $ M.toList hm+ g b h' True = Just BlockTx {blockTxBlock = b, blockTxHash = h'}+ g _ _ False = Nothing+ h BlockTx {blockTxBlock = b} =+ case start of+ Nothing -> False+ Just br -> b > br++getAddressesUnspentsH ::+ [Address] -> Maybe BlockRef -> Maybe Limit -> MemoryDatabase -> [Unspent]+getAddressesUnspentsH addrs start limit db = applyLimit limit xs+ where+ xs =+ nub . sortBy (flip compare `on` unspentBlock) . concat $+ map (\a -> getAddressUnspentsH a start limit db) addrs++getAddressUnspentsH ::+ Address -> Maybe BlockRef -> Maybe Limit -> MemoryDatabase -> [Unspent]+getAddressUnspentsH addr start limit db =+ applyLimit limit .+ dropWhile h .+ sortBy (flip compare) . catMaybes . concatMap (uncurry f) . M.toList $+ M.lookupDefault M.empty addr (hAddrOut db)+ where+ f b hm = map (uncurry (g b)) $ M.toList hm+ g b p (Just u) =+ Just+ Unspent+ { unspentBlock = b+ , unspentAmount = outValAmount u+ , unspentScript = B.Short.toShort (outValScript u)+ , unspentPoint = p+ }+ g _ _ Nothing = Nothing+ h Unspent {unspentBlock = b} =+ case start of+ Nothing -> False+ Just br -> b > br++setBestH :: BlockHash -> MemoryDatabase -> MemoryDatabase+setBestH h db = db {hBest = Just h}++insertBlockH :: BlockData -> MemoryDatabase -> MemoryDatabase+insertBlockH bd db =+ db {hBlock = M.insert (headerHash (blockDataHeader bd)) bd (hBlock db)}++setBlocksAtHeightH :: [BlockHash] -> BlockHeight -> MemoryDatabase -> MemoryDatabase+setBlocksAtHeightH hs g db = db {hHeight = M.insert g hs (hHeight db)}++insertTxH :: TxData -> MemoryDatabase -> MemoryDatabase+insertTxH tx db = db {hTx = M.insert (txHash (txData tx)) tx (hTx db)}++insertSpenderH :: OutPoint -> Spender -> MemoryDatabase -> MemoryDatabase+insertSpenderH op s db =+ db+ { hSpender =+ M.insertWith+ (<>)+ (outPointHash op)+ (I.singleton (fromIntegral (outPointIndex op)) (Just s))+ (hSpender db)+ }++deleteSpenderH :: OutPoint -> MemoryDatabase -> MemoryDatabase+deleteSpenderH op db =+ db+ { hSpender =+ M.insertWith+ (<>)+ (outPointHash op)+ (I.singleton (fromIntegral (outPointIndex op)) Nothing)+ (hSpender db)+ }++setBalanceH :: Balance -> MemoryDatabase -> MemoryDatabase+setBalanceH bal db = db {hBalance = M.insert a b (hBalance db)}+ where+ (a, b) = balanceToVal bal++insertAddrTxH :: Address -> BlockTx -> MemoryDatabase -> MemoryDatabase+insertAddrTxH a btx db =+ let s =+ M.singleton+ a+ (M.singleton+ (blockTxBlock btx)+ (M.singleton (blockTxHash btx) True))+ in db {hAddrTx = M.unionWith (M.unionWith M.union) s (hAddrTx db)}++deleteAddrTxH :: Address -> BlockTx -> MemoryDatabase -> MemoryDatabase+deleteAddrTxH a btx db =+ let s =+ M.singleton+ a+ (M.singleton+ (blockTxBlock btx)+ (M.singleton (blockTxHash btx) False))+ in db {hAddrTx = M.unionWith (M.unionWith M.union) s (hAddrTx db)}++insertAddrUnspentH :: Address -> Unspent -> MemoryDatabase -> MemoryDatabase+insertAddrUnspentH a u db =+ let uns =+ OutVal+ { outValAmount = unspentAmount u+ , outValScript = B.Short.fromShort (unspentScript u)+ }+ s =+ M.singleton+ a+ (M.singleton+ (unspentBlock u)+ (M.singleton (unspentPoint u) (Just uns)))+ in db {hAddrOut = M.unionWith (M.unionWith M.union) s (hAddrOut db)}++deleteAddrUnspentH :: Address -> Unspent -> MemoryDatabase -> MemoryDatabase+deleteAddrUnspentH a u db =+ let s =+ M.singleton+ a+ (M.singleton+ (unspentBlock u)+ (M.singleton (unspentPoint u) Nothing))+ in db {hAddrOut = M.unionWith (M.unionWith M.union) s (hAddrOut db)}++setMempoolH :: [BlockTx] -> MemoryDatabase -> MemoryDatabase+setMempoolH xs db = db {hMempool = Just xs}++insertOrphanTxH :: Tx -> UnixTime -> MemoryDatabase -> MemoryDatabase+insertOrphanTxH tx u db =+ db {hOrphans = M.insert (txHash tx) (Just (u, tx)) (hOrphans db)}++deleteOrphanTxH :: TxHash -> MemoryDatabase -> MemoryDatabase+deleteOrphanTxH h db = db {hOrphans = M.insert h Nothing (hOrphans db)}++getUnspentH :: OutPoint -> MemoryDatabase -> Maybe (Maybe Unspent)+getUnspentH op db = do+ m <- M.lookup (outPointHash op) (hUnspent db)+ fmap (valToUnspent op) <$> I.lookup (fromIntegral (outPointIndex op)) m++insertUnspentH :: Unspent -> MemoryDatabase -> MemoryDatabase+insertUnspentH u db =+ db+ { hUnspent =+ M.insertWith+ (<>)+ (outPointHash (unspentPoint u))+ (I.singleton+ (fromIntegral (outPointIndex (unspentPoint u)))+ (Just (snd (unspentToVal u))))+ (hUnspent db)+ }++deleteUnspentH :: OutPoint -> MemoryDatabase -> MemoryDatabase+deleteUnspentH op db =+ db+ { hUnspent =+ M.insertWith+ (<>)+ (outPointHash op)+ (I.singleton (fromIntegral (outPointIndex op)) Nothing)+ (hUnspent db)+ }++instance MonadIO m => StoreRead (ReaderT MemoryState m) where+ getBestBlock = do+ v <- R.asks memoryDatabase >>= readTVarIO+ return $ getBestBlockH v+ getBlocksAtHeight h = do+ v <- R.asks memoryDatabase >>= readTVarIO+ return $ getBlocksAtHeightH h v+ getBlock b = do+ v <- R.asks memoryDatabase >>= readTVarIO+ return $ getBlockH b v+ getTxData t = do+ v <- R.asks memoryDatabase >>= readTVarIO+ return $ getTxDataH t v+ getSpender t = do+ v <- R.asks memoryDatabase >>= readTVarIO+ return . join $ getSpenderH t v+ getSpenders t = do+ v <- R.asks memoryDatabase >>= readTVarIO+ return . I.map fromJust . I.filter isJust $ getSpendersH t v+ getOrphanTx h = do+ v <- R.asks memoryDatabase >>= readTVarIO+ return . join $ getOrphanTxH h v+ getUnspent p = do+ v <- R.asks memoryDatabase >>= readTVarIO+ return . join $ getUnspentH p v+ getBalance a = do+ v <- R.asks memoryDatabase >>= readTVarIO+ return $ getBalanceH a v+ getMempool = do+ v <- R.asks memoryDatabase >>= readTVarIO+ return . fromMaybe [] $ getMempoolH v+ getAddressesTxs addr start limit = do+ v <- R.asks memoryDatabase >>= readTVarIO+ return $ getAddressesTxsH addr start limit v+ getAddressesUnspents addr start limit = do+ v <- R.asks memoryDatabase >>= readTVarIO+ return $ getAddressesUnspentsH addr start limit v+ getOrphans = do+ v <- R.asks memoryDatabase >>= readTVarIO+ return $ getOrphansH v+ getAddressTxs addr start limit = do+ v <- R.asks memoryDatabase >>= readTVarIO+ return $ getAddressTxsH addr start limit v+ getAddressUnspents addr start limit = do+ v <- R.asks memoryDatabase >>= readTVarIO+ return $ getAddressUnspentsH addr start limit v+ getMaxGap = R.asks memoryMaxGap++instance MonadIO m => StoreWrite (ReaderT MemoryState m) where+ setBest h = do+ v <- R.asks memoryDatabase+ atomically $ modifyTVar v (setBestH h)+ insertBlock b = do+ v <- R.asks memoryDatabase+ atomically $ modifyTVar v (insertBlockH b)+ setBlocksAtHeight h g = do+ v <- R.asks memoryDatabase+ atomically $ modifyTVar v (setBlocksAtHeightH h g)+ insertTx t = do+ v <- R.asks memoryDatabase+ atomically $ modifyTVar v (insertTxH t)+ insertSpender p s = do+ v <- R.asks memoryDatabase+ atomically $ modifyTVar v (insertSpenderH p s)+ deleteSpender p = do+ v <- R.asks memoryDatabase+ atomically $ modifyTVar v (deleteSpenderH p)+ insertAddrTx a t = do+ v <- R.asks memoryDatabase+ atomically $ modifyTVar v (insertAddrTxH a t)+ deleteAddrTx a t = do+ v <- R.asks memoryDatabase+ atomically $ modifyTVar v (deleteAddrTxH a t)+ insertAddrUnspent a u = do+ v <- R.asks memoryDatabase+ atomically $ modifyTVar v (insertAddrUnspentH a u)+ deleteAddrUnspent a u = do+ v <- R.asks memoryDatabase+ atomically $ modifyTVar v (deleteAddrUnspentH a u)+ setMempool xs = do+ v <- R.asks memoryDatabase+ atomically $ modifyTVar v (setMempoolH xs)+ insertOrphanTx t u = do+ v <- R.asks memoryDatabase+ atomically $ modifyTVar v (insertOrphanTxH t u)+ deleteOrphanTx h = do+ v <- R.asks memoryDatabase+ atomically $ modifyTVar v (deleteOrphanTxH h)+ setBalance b = do+ v <- R.asks memoryDatabase+ atomically $ modifyTVar v (setBalanceH b)+ insertUnspent h = do+ v <- R.asks memoryDatabase+ atomically $ modifyTVar v (insertUnspentH h)+ deleteUnspent p = do+ v <- R.asks memoryDatabase+ atomically $ modifyTVar v (deleteUnspentH p)
+ src/Haskoin/Store/Database/Reader.hs view
@@ -0,0 +1,237 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+module Haskoin.Store.Database.Reader+ ( DatabaseReader (..)+ , DatabaseReaderT+ , connectRocksDB+ , withDatabaseReader+ ) where++import Conduit (mapC, runConduit, runResourceT,+ sinkList, (.|))+import Control.Monad.Except (runExceptT, throwError)+import Control.Monad.Reader (ReaderT, ask, asks, 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 (Word32)+import Database.RocksDB (Compression (..), DB,+ Options (..), ReadOptions,+ defaultOptions,+ defaultReadOptions, open)+import Database.RocksDB.Query (insert, matching, matchingAsList,+ matchingSkip, retrieve)+import Haskoin (Address, BlockHash, BlockHeight,+ OutPoint (..), Tx, TxHash)+import Haskoin.Store.Common (Balance, BlockData,+ BlockRef (..), BlockTx (..),+ Limit, Spender, StoreRead (..),+ TxData, UnixTime, Unspent (..),+ applyLimit, applyLimitC,+ zeroBalance)+import Haskoin.Store.Database.Types (AddrOutKey (..), AddrTxKey (..),+ BalKey (..), BestKey (..),+ BlockKey (..), HeightKey (..),+ MemKey (..), OldMemKey (..),+ OrphanKey (..), SpenderKey (..),+ TxKey (..), UnspentKey (..),+ VersionKey (..), toUnspent,+ valToBalance, valToUnspent)+import UnliftIO (MonadIO, liftIO)++type DatabaseReaderT = ReaderT DatabaseReader++data DatabaseReader =+ DatabaseReader+ { databaseHandle :: !DB+ , databaseReadOptions :: !ReadOptions+ , databaseMaxGap :: !Word32+ }++dataVersion :: Word32+dataVersion = 16++connectRocksDB :: MonadIO m => Word32 -> FilePath -> m DatabaseReader+connectRocksDB gap dir = do+ db <-+ open+ dir+ defaultOptions+ { createIfMissing = True+ , compression = SnappyCompression+ , maxOpenFiles = -1+ , writeBufferSize = 2 ^ (30 :: Integer)+ }+ let bdb =+ DatabaseReader+ { databaseReadOptions = defaultReadOptions+ , databaseHandle = db+ , databaseMaxGap = gap+ }+ initRocksDB bdb+ return bdb++withDatabaseReader :: MonadIO m => DatabaseReader -> DatabaseReaderT m a -> m a+withDatabaseReader = flip runReaderT++initRocksDB :: MonadIO m => DatabaseReader -> m ()+initRocksDB bdb@DatabaseReader {databaseReadOptions = opts, databaseHandle = 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 => DatabaseReader -> m ()+migrate15to16 DatabaseReader {databaseReadOptions = opts, databaseHandle = 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)++setInitRocksDB :: MonadIO m => DB -> m ()+setInitRocksDB db = insert db VersionKey dataVersion++getBestDatabaseReader :: MonadIO m => DatabaseReader -> m (Maybe BlockHash)+getBestDatabaseReader DatabaseReader {databaseReadOptions = opts, databaseHandle = db} =+ retrieve db opts BestKey++getBlocksAtHeightDB :: MonadIO m => BlockHeight -> DatabaseReader -> m [BlockHash]+getBlocksAtHeightDB h DatabaseReader {databaseReadOptions = opts, databaseHandle = db} =+ retrieve db opts (HeightKey h) >>= \case+ Nothing -> return []+ Just ls -> return ls++getDatabaseReader :: MonadIO m => BlockHash -> DatabaseReader -> m (Maybe BlockData)+getDatabaseReader h DatabaseReader {databaseReadOptions = opts, databaseHandle = db} =+ retrieve db opts (BlockKey h)++getTxDataDB ::+ MonadIO m => TxHash -> DatabaseReader -> m (Maybe TxData)+getTxDataDB th DatabaseReader {databaseReadOptions = opts, databaseHandle = db} =+ retrieve db opts (TxKey th)++getSpenderDB :: MonadIO m => OutPoint -> DatabaseReader -> m (Maybe Spender)+getSpenderDB op DatabaseReader {databaseReadOptions = opts, databaseHandle = db} =+ retrieve db opts $ SpenderKey op++getSpendersDB :: MonadIO m => TxHash -> DatabaseReader -> m (IntMap Spender)+getSpendersDB th DatabaseReader {databaseReadOptions = opts, databaseHandle = db} =+ I.fromList . map (uncurry f) <$>+ liftIO (matchingAsList db opts (SpenderKeyS th))+ where+ f (SpenderKey op) s = (fromIntegral (outPointIndex op), s)+ f _ _ = undefined++getBalanceDB :: MonadIO m => Address -> DatabaseReader -> m Balance+getBalanceDB a DatabaseReader {databaseReadOptions = opts, databaseHandle = db} =+ fromMaybe (zeroBalance a) . fmap (valToBalance a) <$>+ retrieve db opts (BalKey a)++getMempoolDB :: MonadIO m => DatabaseReader -> m [BlockTx]+getMempoolDB DatabaseReader {databaseReadOptions = opts, databaseHandle = db} =+ fmap f . fromMaybe [] <$> retrieve db opts MemKey+ where+ f (t, h) = BlockTx {blockTxBlock = MemRef t, blockTxHash = h}++getOrphansDB ::+ MonadIO m+ => DatabaseReader+ -> m [(UnixTime, Tx)]+getOrphansDB DatabaseReader {databaseReadOptions = opts, databaseHandle = db} =+ liftIO . runResourceT . runConduit $+ matching db opts OrphanKeyS .| mapC snd .| sinkList++getOrphanTxDB :: MonadIO m => TxHash -> DatabaseReader -> m (Maybe (UnixTime, Tx))+getOrphanTxDB h DatabaseReader {databaseReadOptions = opts, databaseHandle = db} =+ retrieve db opts (OrphanKey h)++getAddressesTxsDB ::+ MonadIO m+ => [Address]+ -> Maybe BlockRef+ -> Maybe Limit+ -> DatabaseReader+ -> m [BlockTx]+getAddressesTxsDB addrs start limit db = do+ ts <- concat <$> mapM (\a -> getAddressTxsDB a start limit db) addrs+ let ts' = nub $ sortBy (flip compare `on` blockTxBlock) ts+ return $ applyLimit limit ts'++getAddressTxsDB ::+ MonadIO m+ => Address+ -> Maybe BlockRef+ -> Maybe Limit+ -> DatabaseReader+ -> m [BlockTx]+getAddressTxsDB a start limit DatabaseReader {databaseReadOptions = opts, databaseHandle = db} =+ liftIO . runResourceT . runConduit $+ x .| applyLimitC limit .| mapC (uncurry f) .| sinkList+ where+ x =+ case start of+ Nothing -> matching db opts (AddrTxKeyA a)+ Just br -> matchingSkip db opts (AddrTxKeyA a) (AddrTxKeyB a br)+ f AddrTxKey {addrTxKeyT = t} () = t+ f _ _ = undefined++getUnspentDB :: MonadIO m => OutPoint -> DatabaseReader -> m (Maybe Unspent)+getUnspentDB p DatabaseReader {databaseReadOptions = opts, databaseHandle = db} =+ fmap (valToUnspent p) <$> retrieve db opts (UnspentKey p)++getAddressesUnspentsDB ::+ MonadIO m+ => [Address]+ -> Maybe BlockRef+ -> Maybe Limit+ -> DatabaseReader+ -> m [Unspent]+getAddressesUnspentsDB addrs start limit bdb = do+ us <- concat <$> mapM (\a -> getAddressUnspentsDB a start limit bdb) addrs+ let us' = nub $ sortBy (flip compare `on` unspentBlock) us+ return $ applyLimit limit us'++getAddressUnspentsDB ::+ MonadIO m+ => Address+ -> Maybe BlockRef+ -> Maybe Limit+ -> DatabaseReader+ -> m [Unspent]+getAddressUnspentsDB a start limit DatabaseReader {databaseReadOptions = opts, databaseHandle = db} =+ liftIO . runResourceT . runConduit $+ x .| applyLimitC limit .| mapC (uncurry toUnspent) .| sinkList+ where+ x =+ case start of+ Nothing -> matching db opts (AddrOutKeyA a)+ Just br -> matchingSkip db opts (AddrOutKeyA a) (AddrOutKeyB a br)++instance MonadIO m => StoreRead (DatabaseReaderT m) where+ getBestBlock = ask >>= getBestDatabaseReader+ getBlocksAtHeight h = ask >>= getBlocksAtHeightDB h+ getBlock b = ask >>= getDatabaseReader 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+ getOrphans = ask >>= getOrphansDB+ getAddressUnspents a b c = ask >>= getAddressUnspentsDB a b c+ getAddressTxs a b c = ask >>= getAddressTxsDB a b c+ getMaxGap = asks databaseMaxGap
+ src/Haskoin/Store/Database/Types.hs view
@@ -0,0 +1,464 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Haskoin.Store.Database.Types+ ( AddrTxKey(..)+ , AddrOutKey(..)+ , BestKey(..)+ , BlockKey(..)+ , BalKey(..)+ , HeightKey(..)+ , MemKey(..)+ , OldMemKey(..)+ , OrphanKey(..)+ , SpenderKey(..)+ , TxKey(..)+ , UnspentKey(..)+ , VersionKey(..)+ , BalVal(..)+ , valToBalance+ , balanceToVal+ , UnspentVal(..)+ , toUnspent+ , unspentToVal+ , valToUnspent+ , OutVal(..)+ ) where++import Control.DeepSeq (NFData)+import Control.Monad (guard)+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Data.ByteString.Short (ShortByteString)+import qualified Data.ByteString.Short as BSS+import Data.Default (Default (..))+import Data.Hashable (Hashable)+import Data.Serialize (Serialize (..), getBytes, getWord8,+ putWord8)+import Data.Word (Word32, Word64)+import Database.RocksDB.Query (Key, KeyValue)+import GHC.Generics (Generic)+import Haskoin (Address, BlockHash, BlockHeight,+ OutPoint (..), Tx, TxHash)+import Haskoin.Store.Common (Balance (..), BlockData, BlockRef,+ BlockTx (..), Spender, TxData,+ UnixTime, Unspent (..), getUnixTime,+ putUnixTime)++-- | Database key for an address transaction.+data AddrTxKey+ = AddrTxKey { addrTxKeyA :: !Address+ , addrTxKeyT :: !BlockTx+ }+ -- ^ key for a transaction affecting an address+ | AddrTxKeyA { addrTxKeyA :: !Address }+ -- ^ short key that matches all entries+ | AddrTxKeyB { addrTxKeyA :: !Address+ , addrTxKeyB :: !BlockRef+ }+ | AddrTxKeyS+ deriving (Show, Eq, Ord, Generic, Hashable)++instance Serialize AddrTxKey+ -- 0x05 · Address · BlockRef · TxHash+ where+ put AddrTxKey { addrTxKeyA = a+ , addrTxKeyT = BlockTx { blockTxBlock = b+ , blockTxHash = t+ }+ } = do+ putWord8 0x05+ put a+ put b+ put t+ -- 0x05 · Address+ put AddrTxKeyA {addrTxKeyA = a} = do+ putWord8 0x05+ put a+ -- 0x05 · Address · BlockRef+ put AddrTxKeyB {addrTxKeyA = a, addrTxKeyB = b} = do+ putWord8 0x05+ put a+ put b+ -- 0x05+ put AddrTxKeyS = putWord8 0x05+ get = do+ guard . (== 0x05) =<< getWord8+ a <- get+ b <- get+ t <- get+ return+ AddrTxKey+ { addrTxKeyA = a+ , addrTxKeyT =+ BlockTx+ { blockTxBlock = b+ , blockTxHash = t+ }+ }++instance Key AddrTxKey+instance KeyValue AddrTxKey ()++-- | Database key for an address output.+data AddrOutKey+ = AddrOutKey { addrOutKeyA :: !Address+ , addrOutKeyB :: !BlockRef+ , addrOutKeyP :: !OutPoint }+ -- ^ full key+ | AddrOutKeyA { addrOutKeyA :: !Address }+ -- ^ short key for all spent or unspent outputs+ | AddrOutKeyB { addrOutKeyA :: !Address+ , addrOutKeyB :: !BlockRef+ }+ | AddrOutKeyS+ deriving (Show, Read, Eq, Ord, Generic, Hashable)++instance Serialize AddrOutKey+ -- 0x06 · StoreAddr · BlockRef · OutPoint+ where+ put AddrOutKey {addrOutKeyA = a, addrOutKeyB = b, addrOutKeyP = p} = do+ putWord8 0x06+ put a+ put b+ put p+ -- 0x06 · StoreAddr · BlockRef+ put AddrOutKeyB {addrOutKeyA = a, addrOutKeyB = b} = do+ putWord8 0x06+ put a+ put b+ -- 0x06 · StoreAddr+ put AddrOutKeyA {addrOutKeyA = a} = do+ putWord8 0x06+ put a+ -- 0x06+ put AddrOutKeyS = putWord8 0x06+ get = do+ guard . (== 0x06) =<< getWord8+ AddrOutKey <$> get <*> get <*> get++instance Key AddrOutKey++data OutVal = OutVal+ { outValAmount :: !Word64+ , outValScript :: !ByteString+ } deriving (Show, Read, Eq, Ord, Generic, Hashable, Serialize)++instance KeyValue AddrOutKey OutVal++-- | Transaction database key.+newtype TxKey = TxKey+ { txKey :: TxHash+ } deriving (Show, Read, Eq, Ord, Generic, Hashable)++instance Serialize TxKey where+ -- 0x02 · TxHash+ put (TxKey h) = do+ putWord8 0x02+ put h+ get = do+ guard . (== 0x02) =<< getWord8+ TxKey <$> get++instance Key TxKey+instance KeyValue TxKey TxData++data SpenderKey+ = SpenderKey { outputPoint :: !OutPoint }+ | SpenderKeyS { outputKeyS :: !TxHash }+ deriving (Show, Read, Eq, Ord, Generic, Hashable)++instance Serialize SpenderKey where+ -- 0x10 · TxHash · Index+ put (SpenderKey OutPoint {outPointHash = h, outPointIndex = i}) = do+ putWord8 0x10+ put h+ put i+ put (SpenderKeyS h) = do+ putWord8 0x10+ put h+ get = do+ guard . (== 0x10) =<< getWord8+ op <- OutPoint <$> get <*> get+ return $ SpenderKey op++instance Key SpenderKey+instance KeyValue SpenderKey Spender++-- | Unspent output database key.+data UnspentKey+ = UnspentKey { unspentKey :: !OutPoint }+ | UnspentKeyS { unspentKeyS :: !TxHash }+ | UnspentKeyB+ deriving (Show, Read, Eq, Ord, Generic, Hashable)++instance Serialize UnspentKey+ -- 0x09 · TxHash · Index+ where+ put UnspentKey {unspentKey = OutPoint {outPointHash = h, outPointIndex = i}} = do+ putWord8 0x09+ put h+ put i+ -- 0x09 · TxHash+ put UnspentKeyS {unspentKeyS = t} = do+ putWord8 0x09+ put t+ -- 0x09+ put UnspentKeyB = putWord8 0x09+ get = do+ guard . (== 0x09) =<< getWord8+ h <- get+ i <- get+ return $ UnspentKey OutPoint {outPointHash = h, outPointIndex = i}++instance Key UnspentKey+instance KeyValue UnspentKey UnspentVal++toUnspent :: AddrOutKey -> OutVal -> Unspent+toUnspent AddrOutKey {addrOutKeyB = b, addrOutKeyP = p} OutVal { outValAmount = v+ , outValScript = s+ } =+ Unspent+ { unspentBlock = b+ , unspentAmount = v+ , unspentScript = BSS.toShort s+ , unspentPoint = p+ }+toUnspent _ _ = undefined++-- | Mempool transaction database key.+data MemKey =+ MemKey+ deriving (Show, Read)++instance Serialize MemKey where+ -- 0x07+ put MemKey = do+ putWord8 0x07+ get = do+ guard . (== 0x07) =<< getWord8+ return MemKey++instance Key MemKey+instance KeyValue MemKey [(UnixTime, TxHash)]++-- | Orphan pool transaction database key.+data OrphanKey+ = OrphanKey+ { orphanKey :: !TxHash+ }+ | OrphanKeyS+ deriving (Show, Read, Eq, Ord, Generic, Hashable)++instance Serialize OrphanKey+ -- 0x08 · TxHash+ where+ put (OrphanKey h) = do+ putWord8 0x08+ put h+ -- 0x08+ put OrphanKeyS = putWord8 0x08+ get = do+ guard . (== 0x08) =<< getWord8+ OrphanKey <$> get++instance Key OrphanKey+instance KeyValue OrphanKey (UnixTime, Tx)++-- | Block entry database key.+newtype BlockKey = BlockKey+ { blockKey :: BlockHash+ } deriving (Show, Read, Eq, Ord, Generic, Hashable)++instance Serialize BlockKey where+ -- 0x01 · BlockHash+ put (BlockKey h) = do+ putWord8 0x01+ put h+ get = do+ guard . (== 0x01) =<< getWord8+ BlockKey <$> get++instance KeyValue BlockKey BlockData++-- | Block height database key.+newtype HeightKey = HeightKey+ { heightKey :: BlockHeight+ } deriving (Show, Read, Eq, Ord, Generic, Hashable)++instance Serialize HeightKey where+ -- 0x03 · BlockHeight+ put (HeightKey height) = do+ putWord8 0x03+ put height+ get = do+ guard . (== 0x03) =<< getWord8+ HeightKey <$> get++instance Key HeightKey+instance KeyValue HeightKey [BlockHash]++-- | Address balance database key.+data BalKey+ = BalKey+ { balanceKey :: !Address+ }+ | BalKeyS+ deriving (Show, Read, Eq, Ord, Generic, Hashable)++instance Serialize BalKey where+ -- 0x04 · Address+ put BalKey {balanceKey = a} = do+ putWord8 0x04+ put a+ -- 0x04+ put BalKeyS = putWord8 0x04+ get = do+ guard . (== 0x04) =<< getWord8+ BalKey <$> get++instance Key BalKey+instance KeyValue BalKey BalVal++-- | Key for best block in database.+data BestKey =+ BestKey+ deriving (Show, Read, Eq, Ord, Generic, Hashable)++instance Serialize BestKey where+ -- 0x00 × 32+ put BestKey = put (BS.replicate 32 0x00)+ get = do+ guard . (== BS.replicate 32 0x00) =<< getBytes 32+ return BestKey++instance Key BestKey+instance KeyValue BestKey BlockHash++-- | Key for database version.+data VersionKey =+ VersionKey+ deriving (Eq, Show, Read, Ord, Generic, Hashable)++instance Serialize VersionKey where+ -- 0x0a+ put VersionKey = putWord8 0x0a+ get = do+ guard . (== 0x0a) =<< getWord8+ return VersionKey++instance Key VersionKey+instance KeyValue VersionKey Word32+++-- | Old mempool transaction database key.+data OldMemKey+ = OldMemKey+ { memTime :: !UnixTime+ , memKey :: !TxHash+ }+ | OldMemKeyT+ { memTime :: !UnixTime+ }+ | OldMemKeyS+ deriving (Show, Read, Eq, Ord, Generic, Hashable)++instance Serialize OldMemKey where+ -- 0x07 · UnixTime · TxHash+ put (OldMemKey t h) = do+ putWord8 0x07+ putUnixTime t+ put h+ -- 0x07 · UnixTime+ put (OldMemKeyT t) = do+ putWord8 0x07+ putUnixTime t+ -- 0x07+ put OldMemKeyS = putWord8 0x07+ get = do+ guard . (== 0x07) =<< getWord8+ OldMemKey <$> getUnixTime <*> get++instance Key OldMemKey+instance KeyValue OldMemKey ()++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+ }
+ src/Haskoin/Store/Database/Writer.hs view
@@ -0,0 +1,356 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+module Haskoin.Store.Database.Writer+ ( DatabaseWriter+ , runDatabaseWriter+ ) where++import Control.Applicative ((<|>))+import Control.Monad (join)+import Control.Monad.Except (MonadError)+import Control.Monad.Reader (ReaderT)+import qualified Control.Monad.Reader as R+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 (nub)+import Data.Maybe (fromJust, fromMaybe, isJust,+ maybeToList)+import Database.RocksDB (BatchOp)+import Database.RocksDB.Query (deleteOp, insertOp, writeBatch)+import Haskoin (Address, BlockHash, BlockHeight,+ OutPoint (..), Tx, TxHash)+import Haskoin.Store.Common (Balance, BlockData,+ BlockRef (..), BlockTx (..),+ Spender, StoreRead (..),+ StoreWrite (..), TxData,+ UnixTime, Unspent, nullBalance,+ zeroBalance)+import Haskoin.Store.Database.Memory (MemoryDatabase (..),+ MemoryState (..),+ emptyMemoryDatabase,+ getMempoolH, getOrphanTxH,+ getSpenderH, getSpendersH,+ getUnspentH, withMemoryDatabase)+import Haskoin.Store.Database.Reader (DatabaseReader (..),+ withDatabaseReader)+import Haskoin.Store.Database.Types (AddrOutKey (..), AddrTxKey (..),+ BalKey (..), BalVal (..),+ BestKey (..), BlockKey (..),+ HeightKey (..), MemKey (..),+ OrphanKey (..), OutVal,+ SpenderKey (..), TxKey (..),+ UnspentKey (..),+ UnspentVal (..))+import UnliftIO (MonadIO, newTVarIO, readTVarIO)++data DatabaseWriter = DatabaseWriter+ { databaseWriterReader :: !DatabaseReader+ , databaseWriterState :: !MemoryState+ }++runDatabaseWriter ::+ (MonadIO m, MonadError e m)+ => DatabaseReader+ -> ReaderT DatabaseWriter m a+ -> m a+runDatabaseWriter bdb@DatabaseReader {databaseHandle = db, databaseMaxGap = gap} f = do+ hm <- newTVarIO emptyMemoryDatabase+ let ms = MemoryState {memoryDatabase = hm, memoryMaxGap = gap}+ x <-+ R.runReaderT+ f+ DatabaseWriter+ {databaseWriterReader = bdb, databaseWriterState = ms}+ ops <- hashMapOps <$> readTVarIO hm+ writeBatch db ops+ return x++hashMapOps :: MemoryDatabase -> [BatchOp]+hashMapOps db =+ bestBlockOp (hBest db) <>+ blockHashOps (hBlock db) <>+ blockHeightOps (hHeight db) <>+ txOps (hTx db) <>+ spenderOps (hSpender db) <>+ balOps (hBalance db) <>+ addrTxOps (hAddrTx db) <>+ addrOutOps (hAddrOut db) <>+ maybeToList (mempoolOp <$> hMempool db) <>+ orphanOps (hOrphans db) <>+ unspentOps (hUnspent db)++bestBlockOp :: Maybe BlockHash -> [BatchOp]+bestBlockOp Nothing = []+bestBlockOp (Just b) = [insertOp BestKey b]++blockHashOps :: HashMap BlockHash BlockData -> [BatchOp]+blockHashOps = map (uncurry f) . M.toList+ where+ f = insertOp . BlockKey++blockHeightOps :: HashMap BlockHeight [BlockHash] -> [BatchOp]+blockHeightOps = map (uncurry f) . M.toList+ where+ f = insertOp . HeightKey++txOps :: HashMap TxHash TxData -> [BatchOp]+txOps = map (uncurry f) . M.toList+ where+ f = insertOp . TxKey++spenderOps :: HashMap TxHash (IntMap (Maybe Spender)) -> [BatchOp]+spenderOps = concatMap (uncurry f) . M.toList+ where+ f h = map (uncurry (g h)) . I.toList+ g h i (Just s) = insertOp (SpenderKey (OutPoint h (fromIntegral i))) s+ g h i Nothing = deleteOp (SpenderKey (OutPoint h (fromIntegral i)))++balOps :: HashMap Address BalVal -> [BatchOp]+balOps = map (uncurry f) . M.toList+ where+ f = insertOp . BalKey++addrTxOps ::+ HashMap Address (HashMap BlockRef (HashMap TxHash Bool)) -> [BatchOp]+addrTxOps = concat . concatMap (uncurry f) . M.toList+ where+ f a = map (uncurry (g a)) . M.toList+ g a b = map (uncurry (h a b)) . M.toList+ h a b t True =+ insertOp+ (AddrTxKey+ { addrTxKeyA = a+ , addrTxKeyT =+ BlockTx+ { blockTxBlock = b+ , blockTxHash = t+ }+ })+ ()+ h a b t False =+ deleteOp+ AddrTxKey+ { addrTxKeyA = a+ , addrTxKeyT =+ BlockTx+ { blockTxBlock = b+ , blockTxHash = t+ }+ }++addrOutOps ::+ HashMap Address (HashMap BlockRef (HashMap OutPoint (Maybe OutVal)))+ -> [BatchOp]+addrOutOps = concat . concatMap (uncurry f) . M.toList+ where+ f a = map (uncurry (g a)) . M.toList+ g a b = map (uncurry (h a b)) . M.toList+ h a b p (Just l) =+ insertOp+ (AddrOutKey {addrOutKeyA = a, addrOutKeyB = b, addrOutKeyP = p})+ l+ h a b p Nothing =+ deleteOp AddrOutKey {addrOutKeyA = a, addrOutKeyB = b, addrOutKeyP = p}++mempoolOp :: [BlockTx] -> BatchOp+mempoolOp =+ insertOp MemKey .+ map (\BlockTx {blockTxBlock = MemRef t, blockTxHash = h} -> (t, h))++orphanOps :: HashMap TxHash (Maybe (UnixTime, Tx)) -> [BatchOp]+orphanOps = map (uncurry f) . M.toList+ where+ f h (Just x) = insertOp (OrphanKey h) x+ f h Nothing = deleteOp (OrphanKey h)++unspentOps :: HashMap TxHash (IntMap (Maybe UnspentVal)) -> [BatchOp]+unspentOps = concatMap (uncurry f) . M.toList+ where+ f h = map (uncurry (g h)) . I.toList+ g h i (Just u) = insertOp (UnspentKey (OutPoint h (fromIntegral i))) u+ g h i Nothing = deleteOp (UnspentKey (OutPoint h (fromIntegral i)))++setBestI :: MonadIO m => BlockHash -> DatabaseWriter -> m ()+setBestI bh DatabaseWriter {databaseWriterState = hm} =+ withMemoryDatabase hm $ setBest bh++insertBlockI :: MonadIO m => BlockData -> DatabaseWriter -> m ()+insertBlockI b DatabaseWriter {databaseWriterState = hm} =+ withMemoryDatabase hm $ insertBlock b++setBlocksAtHeightI :: MonadIO m => [BlockHash] -> BlockHeight -> DatabaseWriter -> m ()+setBlocksAtHeightI hs g DatabaseWriter {databaseWriterState = hm} =+ withMemoryDatabase hm $ setBlocksAtHeight hs g++insertTxI :: MonadIO m => TxData -> DatabaseWriter -> m ()+insertTxI t DatabaseWriter {databaseWriterState = hm} =+ withMemoryDatabase hm $ insertTx t++insertSpenderI :: MonadIO m => OutPoint -> Spender -> DatabaseWriter -> m ()+insertSpenderI p s DatabaseWriter {databaseWriterState = hm} =+ withMemoryDatabase hm $ insertSpender p s++deleteSpenderI :: MonadIO m => OutPoint -> DatabaseWriter -> m ()+deleteSpenderI p DatabaseWriter {databaseWriterState = hm} =+ withMemoryDatabase hm $ deleteSpender p++insertAddrTxI :: MonadIO m => Address -> BlockTx -> DatabaseWriter -> m ()+insertAddrTxI a t DatabaseWriter {databaseWriterState = hm} =+ withMemoryDatabase hm $ insertAddrTx a t++deleteAddrTxI :: MonadIO m => Address -> BlockTx -> DatabaseWriter -> m ()+deleteAddrTxI a t DatabaseWriter {databaseWriterState = hm} =+ withMemoryDatabase hm $ deleteAddrTx a t++insertAddrUnspentI :: MonadIO m => Address -> Unspent -> DatabaseWriter -> m ()+insertAddrUnspentI a u DatabaseWriter {databaseWriterState = hm} =+ withMemoryDatabase hm $ insertAddrUnspent a u++deleteAddrUnspentI :: MonadIO m => Address -> Unspent -> DatabaseWriter -> m ()+deleteAddrUnspentI a u DatabaseWriter {databaseWriterState = hm} =+ withMemoryDatabase hm $ deleteAddrUnspent a u++setMempoolI :: MonadIO m => [BlockTx] -> DatabaseWriter -> m ()+setMempoolI xs DatabaseWriter {databaseWriterState = hm} = withMemoryDatabase hm $ setMempool xs++insertOrphanTxI :: MonadIO m => Tx -> UnixTime -> DatabaseWriter -> m ()+insertOrphanTxI t p DatabaseWriter {databaseWriterState = hm} =+ withMemoryDatabase hm $ insertOrphanTx t p++deleteOrphanTxI :: MonadIO m => TxHash -> DatabaseWriter -> m ()+deleteOrphanTxI t DatabaseWriter {databaseWriterState = hm} =+ withMemoryDatabase hm $ deleteOrphanTx t++getBestBlockI :: MonadIO m => DatabaseWriter -> m (Maybe BlockHash)+getBestBlockI DatabaseWriter {databaseWriterState = hm, databaseWriterReader = db} =+ runMaybeT $ MaybeT f <|> MaybeT g+ where+ f = withMemoryDatabase hm getBestBlock+ g = withDatabaseReader db getBestBlock++getBlocksAtHeightI :: MonadIO m => BlockHeight -> DatabaseWriter -> m [BlockHash]+getBlocksAtHeightI bh DatabaseWriter {databaseWriterState = hm, databaseWriterReader = db} = do+ xs <- withMemoryDatabase hm $ getBlocksAtHeight bh+ ys <- withDatabaseReader db $ getBlocksAtHeight bh+ return . nub $ xs <> ys++getBlockI :: MonadIO m => BlockHash -> DatabaseWriter -> m (Maybe BlockData)+getBlockI bh DatabaseWriter {databaseWriterReader = db, databaseWriterState = hm} =+ runMaybeT $ MaybeT f <|> MaybeT g+ where+ f = withMemoryDatabase hm $ getBlock bh+ g = withDatabaseReader db $ getBlock bh++getTxDataI ::+ MonadIO m => TxHash -> DatabaseWriter -> m (Maybe TxData)+getTxDataI th DatabaseWriter {databaseWriterReader = db, databaseWriterState = hm} =+ runMaybeT $ MaybeT f <|> MaybeT g+ where+ f = withMemoryDatabase hm $ getTxData th+ g = withDatabaseReader db $ getTxData th++getOrphanTxI :: MonadIO m => TxHash -> DatabaseWriter -> m (Maybe (UnixTime, Tx))+getOrphanTxI h DatabaseWriter {databaseWriterReader = db, databaseWriterState = hm} =+ fmap join . runMaybeT $ MaybeT f <|> MaybeT g+ where+ f = getOrphanTxH h <$> readTVarIO (memoryDatabase hm)+ g = Just <$> withDatabaseReader db (getOrphanTx h)++getSpenderI :: MonadIO m => OutPoint -> DatabaseWriter -> m (Maybe Spender)+getSpenderI op DatabaseWriter {databaseWriterReader = db, databaseWriterState = hm} =+ fmap join . runMaybeT $ MaybeT f <|> MaybeT g+ where+ f = getSpenderH op <$> readTVarIO (memoryDatabase hm)+ g = Just <$> withDatabaseReader db (getSpender op)++getSpendersI :: MonadIO m => TxHash -> DatabaseWriter -> m (IntMap Spender)+getSpendersI t DatabaseWriter {databaseWriterReader = db, databaseWriterState = hm} = do+ hsm <- getSpendersH t <$> readTVarIO (memoryDatabase hm)+ dsm <- I.map Just <$> withDatabaseReader db (getSpenders t)+ return . I.map fromJust . I.filter isJust $ hsm <> dsm++getBalanceI :: MonadIO m => Address -> DatabaseWriter -> m Balance+getBalanceI a DatabaseWriter {databaseWriterReader = db, databaseWriterState = hm} =+ fromMaybe (zeroBalance a) <$> runMaybeT (MaybeT f <|> MaybeT g)+ where+ f =+ withMemoryDatabase hm $+ getBalance a >>= \b ->+ return $+ if nullBalance b+ then Nothing+ else Just b+ g =+ withDatabaseReader db $+ getBalance a >>= \b ->+ return $+ if nullBalance b+ then Nothing+ else Just b++setBalanceI :: MonadIO m => Balance -> DatabaseWriter -> m ()+setBalanceI b DatabaseWriter {databaseWriterState = hm} =+ withMemoryDatabase hm $ setBalance b++getUnspentI :: MonadIO m => OutPoint -> DatabaseWriter -> m (Maybe Unspent)+getUnspentI op DatabaseWriter {databaseWriterReader = db, databaseWriterState = hm} =+ fmap join . runMaybeT $ MaybeT f <|> MaybeT g+ where+ f = getUnspentH op <$> readTVarIO (memoryDatabase hm)+ g = Just <$> withDatabaseReader db (getUnspent op)++insertUnspentI :: MonadIO m => Unspent -> DatabaseWriter -> m ()+insertUnspentI u DatabaseWriter {databaseWriterState = hm} =+ withMemoryDatabase hm $ insertUnspent u++deleteUnspentI :: MonadIO m => OutPoint -> DatabaseWriter -> m ()+deleteUnspentI p DatabaseWriter {databaseWriterState = hm} =+ withMemoryDatabase hm $ deleteUnspent p++getMempoolI ::+ MonadIO m+ => DatabaseWriter+ -> m [BlockTx]+getMempoolI DatabaseWriter {databaseWriterState = hm, databaseWriterReader = db} =+ getMempoolH <$> readTVarIO (memoryDatabase hm) >>= \case+ Just xs -> return xs+ Nothing -> withDatabaseReader db getMempool++instance MonadIO m => StoreRead (ReaderT DatabaseWriter m) where+ getBestBlock = R.ask >>= getBestBlockI+ getBlocksAtHeight h = R.ask >>= getBlocksAtHeightI h+ getBlock b = R.ask >>= getBlockI b+ getTxData t = R.ask >>= getTxDataI t+ getSpender p = R.ask >>= getSpenderI p+ getSpenders t = R.ask >>= getSpendersI t+ getOrphanTx h = R.ask >>= getOrphanTxI h+ getUnspent a = R.ask >>= getUnspentI a+ getBalance a = R.ask >>= getBalanceI a+ getMempool = R.ask >>= getMempoolI+ getAddressesTxs = undefined+ getAddressesUnspents = undefined+ getOrphans = undefined+ getMaxGap = R.asks (databaseMaxGap . databaseWriterReader)++instance MonadIO m => StoreWrite (ReaderT DatabaseWriter m) where+ setBest h = R.ask >>= setBestI h+ insertBlock b = R.ask >>= insertBlockI b+ setBlocksAtHeight hs g = R.ask >>= setBlocksAtHeightI hs g+ insertTx t = R.ask >>= insertTxI t+ insertSpender p s = R.ask >>= insertSpenderI p s+ deleteSpender p = R.ask >>= deleteSpenderI p+ insertAddrTx a t = R.ask >>= insertAddrTxI a t+ deleteAddrTx a t = R.ask >>= deleteAddrTxI a t+ insertAddrUnspent a u = R.ask >>= insertAddrUnspentI a u+ deleteAddrUnspent a u = R.ask >>= deleteAddrUnspentI a u+ setMempool xs = R.ask >>= setMempoolI xs+ insertOrphanTx t p = R.ask >>= insertOrphanTxI t p+ deleteOrphanTx t = R.ask >>= deleteOrphanTxI t+ insertUnspent u = R.ask >>= insertUnspentI u+ deleteUnspent p = R.ask >>= deleteUnspentI p+ setBalance b = R.ask >>= setBalanceI b
+ src/Haskoin/Store/Logic.hs view
@@ -0,0 +1,902 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+module Haskoin.Store.Logic+ ( ImportException+ , initBest+ , getOldOrphans+ , getOldMempool+ , importOrphan+ , revertBlock+ , importBlock+ , newMempoolTx+ , deleteTx+ ) where++import Control.Monad (forM, forM_, unless, void, when,+ zipWithM_)+import Control.Monad.Except (MonadError, catchError,+ throwError)+import Control.Monad.Logger (MonadLogger, logErrorS,+ 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, sort)+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 Haskoin.Store.Common (Balance (..), BlockData (..),+ BlockRef (..), BlockTx (..),+ Prev (..), Spender (..),+ StoreInput (..),+ StoreOutput (..),+ StoreRead (..), StoreWrite (..),+ Transaction (..), TxData (..),+ UnixTime, Unspent (..),+ confirmed, fromTransaction,+ isCoinbase, nullBalance,+ sortTxs, toTransaction,+ transactionData)+import Network.Haskoin.Block.Headers (computeSubsidy)+import UnliftIO (Exception)++data ImportException+ = PrevBlockNotBest !Text+ | UnconfirmedCoinbase !Text+ | BestBlockUnknown+ | BestBlockNotFound !Text+ | BlockNotBest !Text+ | OrphanTx !Text+ | TxNotFound !Text+ | NoUnspent !Text+ | TxInvalidOp !Text+ | TxDeleted !Text+ | TxDoubleSpend !Text+ | AlreadyUnspent !Text+ | TxConfirmed !Text+ | OutputOutOfRange !Text+ | BalanceNotFound !Text+ | InsufficientBalance !Text+ | InsufficientZeroBalance !Text+ | InsufficientOutputs !Text+ | InsufficientFunds !Text+ | DuplicatePrevOutput !Text+ deriving (Show, Read, Eq, Ord, Exception)++initBest ::+ ( StoreRead m+ , StoreWrite m+ , MonadLogger m+ , MonadError ImportException m+ )+ => Network+ -> m ()+initBest net = do+ m <- getBestBlock+ when+ (isNothing m)+ (void (importBlock net (genesisBlock net) (genesisNode net)))++getOldOrphans :: StoreRead m => UnixTime -> m [TxHash]+getOldOrphans now =+ map (txHash . snd) . filter ((< now - 600) . fst) <$> getOrphans++getOldMempool :: StoreRead m => UnixTime -> m [TxHash]+getOldMempool now =+ map blockTxHash . filter ((< now - 3600 * 72) . memRefTime . blockTxBlock) <$>+ getMempool++importOrphan ::+ ( StoreRead m+ , StoreWrite m+ , MonadLogger m+ , MonadError ImportException m+ )+ => Network+ -> UnixTime+ -> Tx+ -> m (Maybe [TxHash]) -- ^ deleted transactions or nothing if import failed+importOrphan net t tx = do+ go `catchError` ex+ where+ go = do+ maybetxids <-+ newMempoolTx net tx t >>= \case+ Just ths -> return (Just ths)+ Nothing -> return Nothing+ deleteOrphanTx (txHash tx)+ return maybetxids+ ex (OrphanTx _) = do+ return Nothing+ ex _ = do+ $(logWarnS) "BlockStore" $+ "Deleted bad orphan tx: " <> txHashToHex (txHash tx)+ deleteOrphanTx (txHash tx)+ return Nothing++newMempoolTx ::+ ( StoreRead m+ , StoreWrite m+ , MonadLogger m+ , MonadError ImportException m+ )+ => Network+ -> Tx+ -> UnixTime+ -> m (Maybe [TxHash]) -- ^ deleted transactions or nothing if import failed+newMempoolTx net tx w =+ getTxData (txHash tx) >>= \case+ Just x+ | not (txDataDeleted x) -> return Nothing+ _ -> go+ where+ go = do+ orp <-+ any isNothing <$>+ mapM (getTxData . outPointHash . prevOutput) (txIn tx)+ if orp+ then do+ $(logWarnS) "BlockStore" $ "Orphan tx: " <> txHashToHex (txHash tx)+ insertOrphanTx tx w+ throwError $ OrphanTx (txHashToHex (txHash tx))+ else f+ f = do+ us <-+ forM (txIn tx) $ \TxIn {prevOutput = op} -> do+ t <- getImportTx (outPointHash op)+ getTxOutput (outPointIndex op) t+ let ds = map spenderHash (mapMaybe outputSpender us)+ if null ds+ then do+ ths <- importTx net (MemRef w) w tx+ return (Just ths)+ else g ds+ g ds = do+ rbf <-+ if getReplaceByFee net+ then and <$> mapM isrbf ds+ else return False+ if rbf+ then r ds+ else n+ r ds = do+ $(logWarnS) "BlockStore" $ "Replace by fee tx: " <> txHashToHex (txHash tx)+ ths <- concat <$> forM ds (deleteTx net True)+ dts <- importTx net (MemRef w) w tx+ return (Just (nub (ths <> dts)))+ n = do+ $(logWarnS) "BlockStore" $ "Conflicting tx: " <> txHashToHex (txHash tx)+ insertDeletedMempoolTx tx w+ return Nothing+ isrbf th = transactionRBF <$> getImportTx th++revertBlock ::+ ( StoreRead m+ , StoreWrite m+ , MonadLogger m+ , MonadError ImportException m+ )+ => Network+ -> BlockHash+ -> m [TxHash]+revertBlock net bh = do+ bd <-+ getBestBlock >>= \case+ Nothing -> do+ $(logErrorS) "BlockStore" "Best block unknown"+ throwError BestBlockUnknown+ Just h ->+ getBlock h >>= \case+ Nothing -> do+ $(logErrorS) "BlockStore" "Best block not found"+ throwError (BestBlockNotFound (blockHashToHex h))+ Just b+ | h == bh -> return b+ | otherwise -> do+ $(logErrorS) "BlockStore" $+ "Cannot delete block that is not head: " <>+ blockHashToHex h+ throwError (BlockNotBest (blockHashToHex bh))+ txs <- mapM (fmap transactionData . getImportTx) (blockDataTxs bd)+ 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+ , StoreWrite m+ , MonadLogger m+ , MonadError ImportException m+ )+ => Network+ -> Block+ -> BlockNode+ -> m [TxHash] -- ^ deleted transactions+importBlock net b n = do+ mp <- filter (`elem` bths) . map blockTxHash <$> getMempool+ getBestBlock >>= \case+ Nothing+ | isGenesis n -> return ()+ | otherwise -> do+ $(logErrorS) "BlockStore" $+ "Cannot import non-genesis block at this point: " <>+ blockHashToHex (headerHash (blockHeader b))+ throwError BestBlockUnknown+ Just h+ | prevBlock (blockHeader b) == h -> return ()+ | otherwise -> do+ $(logErrorS) "BlockStore" $+ "Block does not build on head: " <>+ blockHashToHex (headerHash (blockHeader b))+ throwError $+ PrevBlockNotBest (blockHashToHex (prevBlock (nodeHeader n)))+ insertBlock+ BlockData+ { blockDataHeight = nodeHeight n+ , blockDataMainChain = True+ , blockDataWork = nodeWork n+ , blockDataHeader = nodeHeader n+ , blockDataSize = fromIntegral (B.length (encode b))+ , blockDataTxs = map txHash (blockTxns b)+ , blockDataWeight = fromIntegral w+ , blockDataSubsidy = subsidy (nodeHeight n)+ , blockDataFees = cb_out_val - subsidy (nodeHeight n)+ , blockDataOutputs = ts_out_val+ }+ bs <- getBlocksAtHeight (nodeHeight n)+ setBlocksAtHeight (nub (headerHash (nodeHeader n) : bs)) (nodeHeight n)+ setBest (headerHash (nodeHeader n))+ ths <-+ nub . concat <$>+ mapM (uncurry (import_or_confirm mp)) (sortTxs (blockTxns b))+ 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 >> return []+ Nothing -> do+ $(logErrorS) "BlockStore" $+ "Cannot get data for mempool tx: " <>+ txHashToHex (txHash tx)+ throwError $ TxNotFound (txHashToHex (txHash tx))+ else importTx+ net+ (br x)+ (fromIntegral (blockTimestamp (nodeHeader n)))+ tx+ subsidy = computeSubsidy net+ cb_out_val = sum (map outValue (txOut (head (blockTxns b))))+ ts_out_val = sum (map (sum . map outValue . txOut) (tail (blockTxns b)))+ br pos = BlockRef {blockRefHeight = nodeHeight n, blockRefPos = pos}+ w =+ let s =+ B.length+ (encode+ b+ { blockTxns =+ map (\t -> t {txWitness = []}) (blockTxns b)+ })+ x = B.length (encode b)+ in s * 3 + x++importTx ::+ ( StoreRead m+ , StoreWrite m+ , MonadLogger m+ , MonadError ImportException m+ )+ => Network+ -> BlockRef+ -> Word64 -- ^ unix time+ -> Tx+ -> m [TxHash] -- ^ deleted transactions+importTx net br tt tx = do+ when (length (nub (map prevOutput (txIn tx))) < length (txIn tx)) $ do+ $(logErrorS) "BlockStore" $+ "Transaction spends same output twice: " <> txHashToHex (txHash tx)+ throwError (DuplicatePrevOutput (txHashToHex (txHash tx)))+ when (iscb && not (confirmed br)) $ do+ $(logErrorS) "BlockStore" $+ "Coinbase cannot be imported into mempool: " <>+ txHashToHex (txHash tx)+ throwError (UnconfirmedCoinbase (txHashToHex (txHash tx)))+ 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+ $(logErrorS) "BlockStore" $+ "Insufficient funds for tx: " <> txHashToHex (txHash tx)+ throwError (InsufficientFunds (txHashToHex th))+ zipWithM_ (spendOutput net br (txHash tx)) [0 ..] us+ zipWithM_+ (\i o -> newOutput net br (OutPoint (txHash tx) i) o)+ [0 ..]+ (txOut tx)+ rbf <- getrbf+ let t =+ Transaction+ { transactionBlock = br+ , transactionVersion = txVersion tx+ , transactionLockTime = txLockTime tx+ , transactionInputs =+ if iscb+ then zipWith mkcb (txIn tx) ws+ else zipWith3 mkin us (txIn tx) ws+ , transactionOutputs = map mkout (txOut tx)+ , transactionDeleted = False+ , transactionRBF = rbf+ , transactionTime = tt+ }+ let (d, _) = fromTransaction t+ 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, [])+ Nothing -> do+ $(logWarnS) "BlockStore" $+ "Unspent output not found: " <>+ txHashToHex (outPointHash op) <>+ " " <>+ fromString (show (outPointIndex op))+ getSpender op >>= \case+ Nothing -> do+ $(logErrorS) "BlockStore" $+ "Output not found: " <>+ txHashToHex (outPointHash op) <>+ " " <>+ fromString (show (outPointIndex op))+ throwError (NoUnspent (cs (show op)))+ Just Spender {spenderHash = s} -> do+ ths <- deleteTx net True s+ getUnspent op >>= \case+ Nothing -> do+ $(logErrorS) "BlockStore" $+ "Cannot unspend output: " <>+ txHashToHex (outPointHash op) <>+ " " <>+ fromString (show (outPointIndex op))+ throwError (NoUnspent (cs (show op)))+ Just u -> return (u, ths)+ th = txHash tx+ iscb = all (== nullOutPoint) (map prevOutput (txIn tx))+ ws = map Just (txWitness tx) <> repeat Nothing+ getrbf+ | iscb = return False+ | any ((< 0xffffffff - 1) . txInSequence) (txIn tx) = return True+ | confirmed br = return False+ | otherwise =+ let hs = nub $ map (outPointHash . prevOutput) (txIn tx)+ in fmap or . forM hs $ \h ->+ getTxData h >>= \case+ Nothing -> throwError (TxNotFound (txHashToHex h))+ Just t+ | confirmed (txDataBlock t) -> return False+ | txDataRBF t -> return True+ | otherwise -> return False+ mkcb ip w =+ StoreCoinbase+ { inputPoint = prevOutput ip+ , inputSequence = txInSequence ip+ , inputSigScript = scriptInput ip+ , inputWitness = w+ }+ mkin u ip w =+ StoreInput+ { inputPoint = prevOutput ip+ , inputSequence = txInSequence ip+ , inputSigScript = scriptInput ip+ , inputPkScript = B.Short.fromShort (unspentScript u)+ , inputAmount = unspentAmount u+ , inputWitness = w+ }+ mkout o =+ StoreOutput+ { outputAmount = outValue o+ , outputScript = scriptOutput o+ , outputSpender = Nothing+ }++confirmTx ::+ ( StoreRead m+ , StoreWrite m+ , MonadLogger m+ , MonadError ImportException m+ )+ => Network+ -> TxData+ -> BlockRef+ -> Tx+ -> m ()+confirmTx net t br tx = do+ forM_ (txDataPrevs t) $ \p ->+ case scriptToAddressBS (prevScript p) of+ Left _ -> return ()+ Right a -> do+ deleteAddrTx+ a+ BlockTx+ {blockTxBlock = txDataBlock t, blockTxHash = txHash tx}+ insertAddrTx+ a+ BlockTx {blockTxBlock = br, blockTxHash = txHash tx}+ forM_ (zip [0 ..] (txOut tx)) $ \(n, o) -> do+ let op = OutPoint (txHash tx) n+ s <- getSpender (OutPoint (txHash tx) n)+ when (isNothing s) $ do+ deleteUnspent op+ insertUnspent+ Unspent+ { unspentBlock = br+ , unspentPoint = op+ , unspentAmount = outValue o+ , unspentScript = B.Short.toShort (scriptOutput o)+ }+ case scriptToAddressBS (scriptOutput o) of+ Left _ -> return ()+ Right a -> do+ deleteAddrTx+ a+ BlockTx+ {blockTxBlock = txDataBlock t, blockTxHash = txHash tx}+ insertAddrTx+ a+ BlockTx {blockTxBlock = br, blockTxHash = txHash tx}+ when (isNothing s) $ do+ deleteAddrUnspent+ a+ Unspent+ { unspentBlock = txDataBlock t+ , unspentPoint = op+ , unspentAmount = outValue o+ , unspentScript = B.Short.toShort (scriptOutput o)+ }+ insertAddrUnspent+ a+ Unspent+ { unspentBlock = br+ , unspentPoint = op+ , unspentAmount = outValue o+ , unspentScript = B.Short.toShort (scriptOutput o)+ }+ reduceBalance net False False a (outValue o)+ increaseBalance True False a (outValue o)+ insertTx t {txDataBlock = br}+ deleteFromMempool (txHash tx)++deleteFromMempool :: (Monad m, StoreRead m, StoreWrite m) => TxHash -> m ()+deleteFromMempool th = do+ mp <- getMempool+ setMempool $ filter ((/= th) . blockTxHash) mp++insertIntoMempool :: (Monad m, StoreRead m, StoreWrite m) => TxHash -> UnixTime -> m ()+insertIntoMempool th unixtime = do+ mp <- getMempool+ setMempool . reverse . sort $+ BlockTx {blockTxBlock = MemRef unixtime, blockTxHash = th} : mp++deleteTx ::+ ( StoreRead m+ , StoreWrite m+ , MonadLogger m+ , MonadError ImportException m+ )+ => Network+ -> Bool -- ^ only delete transaction if unconfirmed+ -> TxHash+ -> m [TxHash] -- ^ deleted transactions+deleteTx net mo h = do+ getTxData h >>= \case+ Nothing -> do+ $(logErrorS) "BlockStore" $ "Cannot find tx to delete: " <> txHashToHex h+ throwError (TxNotFound (txHashToHex h))+ Just t+ | txDataDeleted t -> do+ $(logWarnS) "BlockStore" $ "Already deleted tx: " <> txHashToHex h+ return []+ | mo && confirmed (txDataBlock t) -> do+ $(logErrorS) "BlockStore" $+ "Will not delete confirmed tx: " <> txHashToHex h+ throwError (TxConfirmed (txHashToHex h))+ | otherwise -> go t+ where+ go t = do+ ss <- nub . map spenderHash . I.elems <$> getSpenders h+ 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)))+ mapM_ (unspendOutput net) ps+ unless (confirmed (txDataBlock t)) $ deleteFromMempool h+ insertTx t {txDataDeleted = True}+ updateAddressCounts net (txDataAddresses t) (subtract 1)+ return $ nub (h : ths)++insertDeletedMempoolTx ::+ ( StoreRead m+ , StoreWrite m+ , MonadLogger m+ , MonadError ImportException m+ )+ => Tx+ -> UnixTime+ -> m ()+insertDeletedMempoolTx tx w = do+ us <-+ forM (txIn tx) $ \TxIn {prevOutput = op} ->+ getImportTx (outPointHash op) >>= getTxOutput (outPointIndex op)+ rbf <- getrbf+ let (d, _) =+ fromTransaction+ Transaction+ { transactionBlock = MemRef w+ , transactionVersion = txVersion tx+ , transactionLockTime = txLockTime tx+ , transactionInputs = zipWith3 mkin us (txIn tx) ws+ , transactionOutputs = map mkout (txOut tx)+ , transactionDeleted = True+ , transactionRBF = rbf+ , transactionTime = w+ }+ insertTx d+ where+ ws = map Just (txWitness tx) <> repeat Nothing+ getrbf+ | any ((< 0xffffffff - 1) . txInSequence) (txIn tx) = return True+ | otherwise =+ let hs = nub $ map (outPointHash . prevOutput) (txIn tx)+ in fmap or . forM hs $ \h ->+ getTxData h >>= \case+ Nothing -> do+ $(logErrorS) "BlockStore" $+ "Tx not found: " <> txHashToHex h+ throwError (TxNotFound (txHashToHex h))+ Just t+ | confirmed (txDataBlock t) -> return False+ | txDataRBF t -> return True+ | otherwise -> return False+ mkin u ip wit =+ StoreInput+ { inputPoint = prevOutput ip+ , inputSequence = txInSequence ip+ , inputSigScript = scriptInput ip+ , inputPkScript = outputScript u+ , inputAmount = outputAmount u+ , inputWitness = wit+ }+ mkout o =+ StoreOutput+ { outputAmount = outValue o+ , outputScript = scriptOutput o+ , outputSpender = Nothing+ }++newOutput ::+ ( StoreRead m+ , StoreWrite m+ , MonadLogger m+ )+ => Network+ -> BlockRef+ -> OutPoint+ -> TxOut+ -> m ()+newOutput _ br op to = do+ insertUnspent u+ case scriptToAddressBS (scriptOutput to) of+ Left _ -> return ()+ Right a -> do+ insertAddrUnspent a u+ insertAddrTx+ a+ BlockTx {blockTxHash = outPointHash op, blockTxBlock = br}+ increaseBalance (confirmed br) True a (outValue to)+ where+ u =+ Unspent+ { unspentBlock = br+ , unspentAmount = outValue to+ , unspentScript = B.Short.toShort (scriptOutput to)+ , unspentPoint = op+ }++delOutput ::+ ( StoreRead m+ , StoreWrite m+ , MonadLogger m+ , MonadError ImportException m+ )+ => Network+ -> OutPoint+ -> m ()+delOutput net op = do+ t <- getImportTx (outPointHash op)+ u <- getTxOutput (outPointIndex op) t+ deleteUnspent op+ case scriptToAddressBS (outputScript u) of+ Left _ -> return ()+ Right a -> do+ deleteAddrUnspent+ a+ Unspent+ { unspentScript = B.Short.toShort (outputScript u)+ , unspentBlock = transactionBlock t+ , unspentPoint = op+ , unspentAmount = outputAmount u+ }+ deleteAddrTx+ a+ BlockTx+ { blockTxHash = outPointHash op+ , blockTxBlock = transactionBlock t+ }+ reduceBalance+ net+ (confirmed (transactionBlock t))+ True+ a+ (outputAmount u)++getImportTx ::+ (StoreRead m, MonadLogger m, MonadError ImportException m)+ => TxHash+ -> m Transaction+getImportTx th =+ getTxData th >>= \case+ Nothing -> do+ $(logErrorS) "BlockStore" $ "Tx not found: " <> txHashToHex th+ throwError $ TxNotFound (txHashToHex th)+ Just d+ | txDataDeleted d -> do+ $(logErrorS) "BlockStore" $ "Tx deleted: " <> txHashToHex th+ throwError $ TxDeleted (txHashToHex th)+ | otherwise -> do+ sm <- getSpenders th+ return $ toTransaction d sm++getTxOutput ::+ (MonadLogger m, MonadError ImportException m)+ => Word32+ -> Transaction+ -> m StoreOutput+getTxOutput i tx = do+ unless (fromIntegral i < length (transactionOutputs tx)) $ do+ $(logErrorS) "BlockStore" $+ "Output out of range: " <> txHashToHex (txHash (transactionData tx)) <>+ " " <>+ fromString (show i)+ throwError . OutputOutOfRange . cs $+ show+ OutPoint+ { outPointHash = txHash (transactionData tx)+ , outPointIndex = i+ }+ return $ transactionOutputs tx !! fromIntegral i++spendOutput ::+ ( StoreRead m+ , StoreWrite m+ , MonadLogger m+ , MonadError ImportException m+ )+ => Network+ -> BlockRef+ -> TxHash+ -> Word32+ -> Unspent+ -> m ()+spendOutput net br th ix u = do+ insertSpender (unspentPoint u) Spender {spenderHash = th, spenderIndex = ix}+ case scriptToAddressBS (B.Short.fromShort (unspentScript u)) of+ Left _ -> return ()+ Right a -> do+ reduceBalance+ net+ (confirmed (unspentBlock u))+ False+ a+ (unspentAmount u)+ deleteAddrUnspent a u+ insertAddrTx a BlockTx {blockTxHash = th, blockTxBlock = br}+ deleteUnspent (unspentPoint u)++unspendOutput ::+ ( StoreRead m+ , StoreWrite m+ , MonadLogger m+ , MonadError ImportException m+ )+ => Network+ -> OutPoint+ -> m ()+unspendOutput _ op = do+ t <- getImportTx (outPointHash op)+ o <- getTxOutput (outPointIndex op) t+ s <-+ case outputSpender o of+ Nothing -> do+ $(logErrorS) "BlockStore" $+ "Output already unspent: " <> txHashToHex (outPointHash op) <>+ " " <>+ fromString (show (outPointIndex op))+ throwError (AlreadyUnspent (cs (show op)))+ Just s -> return s+ x <- getImportTx (spenderHash s)+ deleteSpender op+ let u =+ Unspent+ { unspentAmount = outputAmount o+ , unspentBlock = transactionBlock t+ , unspentScript = B.Short.toShort (outputScript o)+ , unspentPoint = op+ }+ insertUnspent u+ case scriptToAddressBS (outputScript o) of+ Left _ -> return ()+ Right a -> do+ insertAddrUnspent a u+ deleteAddrTx+ a+ BlockTx+ { blockTxHash = spenderHash s+ , blockTxBlock = transactionBlock x+ }+ increaseBalance+ (confirmed (unspentBlock u))+ False+ a+ (outputAmount o)++reduceBalance ::+ ( StoreRead m+ , StoreWrite m+ , MonadLogger m+ , MonadError ImportException m+ )+ => Network+ -> Bool -- ^ spend or delete confirmed output+ -> Bool -- ^ reduce total received+ -> Address+ -> Word64+ -> m ()+reduceBalance net c t a v =+ getBalance a >>= \b ->+ if nullBalance b+ then do+ $(logErrorS) "BlockStore" $+ "Address balance not found: " <> addrText net a+ throwError (BalanceNotFound (addrText net a))+ else do+ when (v > amnt b) $ do+ $(logErrorS) "BlockStore" $+ "Insufficient " <> conf <> " balance: " <>+ addrText net a <>+ " (needs: " <>+ cs (show v) <>+ ", has: " <>+ cs (show (amnt b)) <>+ ")"+ throwError $+ if c+ then InsufficientBalance (addrText net a)+ else InsufficientZeroBalance (addrText net a)+ setBalance+ b+ { balanceAmount =+ balanceAmount b -+ if c+ then v+ else 0+ , balanceZero =+ balanceZero b -+ if c+ then 0+ else v+ , balanceUnspentCount = balanceUnspentCount b - 1+ , balanceTotalReceived =+ balanceTotalReceived b -+ if t+ then v+ else 0+ }+ where+ amnt =+ if c+ then balanceAmount+ else balanceZero+ conf =+ if c+ then "confirmed"+ else "unconfirmed"++increaseBalance ::+ ( StoreRead m+ , StoreWrite m+ , MonadLogger m+ )+ => Bool -- ^ add confirmed output+ -> Bool -- ^ increase total received+ -> Address+ -> Word64+ -> m ()+increaseBalance c t a v = do+ b <- getBalance a+ setBalance+ b+ { balanceAmount =+ balanceAmount b ++ if c+ then v+ else 0+ , balanceZero =+ balanceZero b ++ if c+ then 0+ else v+ , balanceUnspentCount = balanceUnspentCount b + 1+ , balanceTotalReceived =+ balanceTotalReceived b ++ if t+ then v+ else 0+ }++updateAddressCounts ::+ (StoreWrite m, StoreRead m, Monad m, MonadError ImportException m)+ => Network+ -> [Address]+ -> (Word64 -> Word64)+ -> m ()+updateAddressCounts net as f =+ forM_ as $ \a -> do+ b <-+ getBalance a >>= \b -> if nullBalance b+ then throwError (BalanceNotFound (addrText net a))+ else return b+ setBalance b {balanceTxCount = f (balanceTxCount b)}++txAddresses :: Transaction -> [Address]+txAddresses t =+ nub . rights $+ map (scriptToAddressBS . inputPkScript)+ (filter (not . isCoinbase) (transactionInputs t)) <>+ map (scriptToAddressBS . outputScript) (transactionOutputs t)++txDataAddresses :: TxData -> [Address]+txDataAddresses t =+ nub . rights $+ map (scriptToAddressBS . prevScript) (I.elems (txDataPrevs t)) <>+ map (scriptToAddressBS . scriptOutput) (txOut (txData t))++addrText :: Network -> Address -> Text+addrText net a = fromMaybe "???" $ addrToString net a
+ src/Haskoin/Store/Manager.hs view
@@ -0,0 +1,221 @@+module Haskoin.Store.Manager+ ( StoreConfig(..)+ , Store(..)+ , withStore+ ) where++import Control.Monad (forever, unless, when)+import Control.Monad.Logger (MonadLoggerIO)+import Data.Serialize (decode)+import Data.Word (Word32)+import Haskoin (BlockHash (..), Inv (..),+ InvType (..), InvVector (..),+ Message (..),+ MessageCommand (..), Network,+ NetworkAddress (..),+ NotFound (..), Pong (..),+ Reject (..), TxHash (..),+ VarString (..),+ sockToHostAddress)+import Haskoin.Node (Chain, ChainEvent (..),+ HostPort, Manager,+ NodeConfig (..), NodeEvent (..),+ PeerEvent (..), node)+import Haskoin.Store.BlockStore (BlockStoreConfig (..),+ blockStore)+import Haskoin.Store.Cache (CacheConfig (..), CacheWriter,+ CacheWriterMessage (..),+ cacheWriter, connectRedis)+import Haskoin.Store.Common (BlockStore,+ BlockStoreMessage (..),+ StoreEvent (..))+import Haskoin.Store.Database.Reader (DatabaseReader (..),+ connectRocksDB,+ withDatabaseReader)+import Network.Socket (SockAddr (..))+import NQE (Inbox, Listen, Process (..),+ Publisher,+ PublisherMessage (Event),+ inboxToMailbox, newInbox,+ receive, send, sendSTM,+ withProcess, withPublisher,+ withSubscription)+import UnliftIO (MonadIO, MonadUnliftIO, link,+ withAsync)++-- | Store mailboxes.+data Store =+ Store+ { storeManager :: !Manager+ , storeChain :: !Chain+ , storeBlock :: !BlockStore+ , storeDB :: !DatabaseReader+ , storeCache :: !(Maybe CacheConfig)+ , storePublisher :: !(Publisher StoreEvent)+ , storeNetwork :: !Network+ }++-- | 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 :: !FilePath+ -- ^ RocksDB database path+ , storeConfNetwork :: !Network+ -- ^ network constants+ , storeConfCache :: !(Maybe String)+ -- ^ Redis cache configuration+ , storeConfGap :: !Word32+ -- ^ gap for extended public keys+ , storeConfCacheMin :: !Int+ -- ^ cache xpubs with more than this many used addresses+ , storeConfMaxKeys :: !Integer+ -- ^ maximum number of keys in Redis cache+ }++withStore ::+ (MonadLoggerIO m, MonadUnliftIO m)+ => StoreConfig+ -> (Store -> m a)+ -> m a+withStore cfg action = do+ chaininbox <- newInbox+ let chain = inboxToMailbox chaininbox+ maybecacheconn <-+ case storeConfCache cfg of+ Nothing -> return Nothing+ Just redisurl -> Just <$> connectRedis redisurl+ db <- connectRocksDB (storeConfGap cfg) (storeConfDB cfg)+ case maybecacheconn of+ Nothing -> launch db Nothing chaininbox+ Just cacheconn -> do+ let cachecfg =+ CacheConfig+ { cacheConn = cacheconn+ , cacheGap = storeConfGap cfg+ , cacheMin = storeConfCacheMin cfg+ , cacheChain = chain+ , cacheMax = storeConfMaxKeys cfg+ }+ withProcess (withDatabaseReader db . cacheWriter cachecfg) $ \p ->+ launch db (Just (cachecfg, getProcessMailbox p)) chaininbox+ where+ launch db maybecache chaininbox =+ withPublisher $ \pub -> do+ managerinbox <- newInbox+ blockstoreinbox <- newInbox+ let blockstore = inboxToMailbox blockstoreinbox+ manager = inboxToMailbox managerinbox+ chain = inboxToMailbox chaininbox+ let nodeconfig =+ NodeConfig+ { nodeConfMaxPeers = storeConfMaxPeers cfg+ , nodeConfDB = databaseHandle db+ , nodeConfPeers = storeConfInitPeers cfg+ , nodeConfDiscover = storeConfDiscover cfg+ , nodeConfEvents =+ storeDispatch blockstore ((`sendSTM` pub) . Event)+ , nodeConfNetAddr =+ NetworkAddress+ 0+ (sockToHostAddress (SockAddrInet 0 0))+ , nodeConfNet = storeConfNetwork cfg+ , nodeConfTimeout = 10+ }+ withAsync (node nodeconfig managerinbox chaininbox) $ \nodeasync -> do+ link nodeasync+ let blockstoreconfig =+ BlockStoreConfig+ { blockConfChain = chain+ , blockConfManager = manager+ , blockConfListener = (`sendSTM` pub) . Event+ , blockConfDB = db+ , blockConfNet = storeConfNetwork cfg+ }+ runaction =+ action+ Store+ { storeManager = manager+ , storeChain = chain+ , storeBlock = blockstore+ , storeDB = db+ , storeCache = fst <$> maybecache+ , storePublisher = pub+ , storeNetwork = storeConfNetwork cfg+ }+ case maybecache of+ Nothing ->+ launch2 blockstoreconfig blockstoreinbox runaction+ Just (_, cache) ->+ withSubscription pub $ \evts ->+ withAsync (cacheWriterEvents evts cache) $ \evtsasync ->+ link evtsasync >>+ launch2+ blockstoreconfig+ blockstoreinbox+ runaction+ launch2 blockstoreconfig blockstoreinbox runaction =+ withAsync (blockStore blockstoreconfig blockstoreinbox) $ \blockstoreasync ->+ link blockstoreasync >> runaction++cacheWriterEvents :: MonadIO m => Inbox StoreEvent -> CacheWriter -> m ()+cacheWriterEvents evts cwm = forever $ receive evts >>= (`cacheWriterDispatch` cwm)++cacheWriterDispatch :: MonadIO m => StoreEvent -> CacheWriter -> m ()+cacheWriterDispatch (StoreBestBlock _) = send CacheNewBlock+cacheWriterDispatch (StoreMempoolNew txh) = send (CacheNewTx txh)+cacheWriterDispatch (StoreTxDeleted txh) = send (CacheDelTx txh)+cacheWriterDispatch _ = const (return ())++-- | Dispatcher of node events.+storeDispatch :: BlockStore -> Listen StoreEvent -> Listen NodeEvent++storeDispatch b pub (PeerEvent (PeerConnected p a)) = do+ pub (StorePeerConnected p a)+ BlockPeerConnect p a `sendSTM` b++storeDispatch b pub (PeerEvent (PeerDisconnected p a)) = do+ pub (StorePeerDisconnected p a)+ BlockPeerDisconnect p a `sendSTM` b++storeDispatch b _ (ChainEvent (ChainBestBlock bn)) =+ BlockNewBest bn `sendSTM` b++storeDispatch _ _ (ChainEvent _) = return ()++storeDispatch _ pub (PeerEvent (PeerMessage p (MPong (Pong n)))) =+ pub (StorePeerPong p n)++storeDispatch b _ (PeerEvent (PeerMessage p (MBlock block))) =+ BlockReceived p block `sendSTM` b++storeDispatch b _ (PeerEvent (PeerMessage p (MTx tx))) =+ BlockTxReceived p tx `sendSTM` b++storeDispatch b _ (PeerEvent (PeerMessage p (MNotFound (NotFound is)))) = do+ let blocks =+ [ BlockHash h+ | InvVector t h <- is+ , t == InvBlock || t == InvWitnessBlock+ ]+ unless (null blocks) $ BlockNotFound p blocks `sendSTM` b++storeDispatch b pub (PeerEvent (PeerMessage p (MInv (Inv is)))) = do+ let txs = [TxHash h | InvVector t h <- is, t == InvTx || t == InvWitnessTx]+ pub (StoreTxAvailable p txs)+ unless (null txs) $ BlockTxAvailable p txs `sendSTM` b++storeDispatch _ pub (PeerEvent (PeerMessage p (MReject r))) =+ when (rejectMessage r == MCTx) $+ case decode (rejectData r) of+ Left _ -> return ()+ Right th ->+ pub $+ StoreTxReject p th (rejectCode r) (getVarString (rejectReason r))++storeDispatch _ _ (PeerEvent _) = return ()
+ src/Haskoin/Store/Web.hs view
@@ -0,0 +1,1178 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+module Haskoin.Store.Web+ ( Except (..)+ , WebConfig (..)+ , WebLimits (..)+ , WebTimeouts (..)+ , runWeb+ ) where++import Conduit ()+import Control.Applicative ((<|>))+import Control.Monad (forever, guard, mzero, unless,+ when, (<=<))+import Control.Monad.Logger (MonadLogger, MonadLoggerIO,+ askLoggerIO, logInfoS,+ monadLoggerLog)+import Control.Monad.Reader (ReaderT, asks, runReaderT)+import Control.Monad.Trans (lift)+import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)+import Data.Aeson (ToJSON (..), object, (.=))+import Data.Aeson.Encoding (encodingToLazyByteString)+import qualified Data.ByteString as B+import Data.ByteString.Builder (lazyByteString)+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Lazy.Char8 as C+import Data.Char (isSpace)+import Data.Default (Default (..))+import Data.List (nub)+import Data.Maybe (catMaybes, fromMaybe, isJust,+ 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 (..), Message (..),+ Network (..), OutPoint (..), Tx,+ TxHash (..), VarString (..),+ Version (..), decodeHex,+ eitherToMaybe, headerHash,+ hexToBlockHash, hexToTxHash,+ sockToHostAddress, stringToAddr,+ txHash, xPubImport)+import Haskoin.Node (Chain, Manager, OnlinePeer (..),+ chainGetBest, managerGetPeers,+ sendMessage)+import Haskoin.Store.Cache (CacheT, withCache)+import Haskoin.Store.Common (BinSerial (..), BlockData (..),+ BlockRef (..), BlockTx (..),+ DeriveType (..), Event (..),+ HealthCheck (..),+ JsonSerial (..), Limit, Offset,+ PeerInformation (..),+ PubExcept (..), StoreEvent (..),+ StoreInput (..), StoreRead (..),+ Transaction (..),+ TxAfterHeight (..), TxData (..),+ TxId (..), UnixTime, Unspent,+ XPubBal (..), XPubSpec (..),+ applyOffset, blockAtOrBefore,+ getTransaction, isCoinbase,+ nullBalance, transactionData)+import Haskoin.Store.Database.Reader (DatabaseReader (..),+ DatabaseReaderT,+ withDatabaseReader)+import Haskoin.Store.Manager (Store (..))+import Network.HTTP.Types (Status (..), status400,+ status403, 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, MonadIO,+ MonadUnliftIO, askRunInIO,+ liftIO, timeout)+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 WebConfig m)++data Except+ = ThingNotFound+ | ServerError+ | BadRequest+ | UserError String+ | StringError String+ | BlockTooLarge+ deriving Eq++instance Show Except where+ show ThingNotFound = "not found"+ show ServerError = "you made me kill a unicorn"+ show BadRequest = "bad request"+ show (UserError s) = s+ show (StringError _) = "you killed the dragon with your bare hands"+ show BlockTooLarge = "block too large"++instance Exception Except++instance ScottyError Except where+ stringError = StringError+ showError = T.Lazy.pack . show++instance ToJSON Except where+ toJSON e = object ["error" .= T.pack (show e)]++instance JsonSerial Except where+ jsonSerial _ = toEncoding+ jsonValue _ = toJSON++instance BinSerial Except where+ binSerial _ ex =+ case ex of+ ThingNotFound -> putWord8 0+ ServerError -> putWord8 1+ BadRequest -> putWord8 2+ UserError s -> putWord8 3 >> Serialize.put s+ StringError s -> putWord8 4 >> Serialize.put s+ BlockTooLarge -> putWord8 5+ binDeserial _ =+ getWord8 >>= \case+ 0 -> return ThingNotFound+ 1 -> return ServerError+ 2 -> return BadRequest+ 3 -> UserError <$> Serialize.get+ 4 -> StringError <$> Serialize.get+ _ -> mzero++data WebConfig =+ WebConfig+ { webPort :: !Int+ , webStore :: !Store+ , webMaxLimits :: !WebLimits+ , webReqLog :: !Bool+ , webWebTimeouts :: !WebTimeouts+ }++data WebLimits =+ WebLimits+ { maxLimitCount :: !Word32+ , maxLimitFull :: !Word32+ , maxLimitOffset :: !Word32+ , maxLimitDefault :: !Word32+ , maxLimitGap :: !Word32+ }+ deriving (Eq, Show)++instance Default WebLimits where+ def =+ WebLimits+ { maxLimitCount = 20000+ , maxLimitFull = 5000+ , maxLimitOffset = 50000+ , maxLimitDefault = 2000+ , maxLimitGap = 32+ }++data WebTimeouts =+ WebTimeouts+ { txTimeout :: !Word64+ , blockTimeout :: !Word64+ }+ deriving (Eq, Show)++instance Default WebTimeouts where+ def = WebTimeouts {txTimeout = 300, blockTimeout = 7200}++newtype MyBlockHash =+ MyBlockHash BlockHash++newtype MyTxHash =+ MyTxHash TxHash++instance Parsable MyBlockHash where+ parseParam =+ maybe (Left "could not decode block hash") (Right . MyBlockHash) . hexToBlockHash . cs++instance Parsable MyTxHash where+ parseParam =+ maybe (Left "could not decode tx hash") (Right . MyTxHash) . hexToTxHash . cs++data StartParam+ = StartParamHash+ { startParamHash :: !Hash256}+ | StartParamHeight+ { startParamHeight :: !Word32}+ | StartParamTime+ { startParamTime :: !UnixTime}++instance Parsable StartParam where+ parseParam s = maybe (Left "could not decode start") Right (h <|> g <|> t)+ where+ h = do+ x <- fmap B.reverse (decodeHex (cs s)) >>= eitherToMaybe . decode+ return StartParamHash {startParamHash = x}+ g = do+ x <- readMaybe (cs s) :: Maybe Integer+ guard $ 0 <= x && x <= 1230768000+ return StartParamHeight {startParamHeight = fromIntegral x}+ t = do+ x <- readMaybe (cs s)+ guard $ x > 1230768000+ return StartParamTime {startParamTime = x}++runInWebReader ::+ MonadIO m+ => DatabaseReaderT m a+ -> CacheT (DatabaseReaderT m) a+ -> ReaderT WebConfig m a+runInWebReader bf cf = do+ bdb <- asks (storeDB . webStore)+ mc <- asks (storeCache . webStore)+ lift $ withDatabaseReader bdb $+ case mc of+ Nothing -> bf+ Just c -> withCache c cf++instance MonadLoggerIO m => StoreRead (ReaderT WebConfig m) where+ getBestBlock = runInWebReader getBestBlock getBestBlock+ getBlocksAtHeight height =+ runInWebReader (getBlocksAtHeight height) (getBlocksAtHeight height)+ getBlock bh = runInWebReader (getBlock bh) (getBlock bh)+ getTxData th = runInWebReader (getTxData th) (getTxData th)+ getSpender op = runInWebReader (getSpender op) (getSpender op)+ getSpenders th = runInWebReader (getSpenders th) (getSpenders th)+ getOrphanTx th = runInWebReader (getOrphanTx th) (getOrphanTx th)+ getUnspent op = runInWebReader (getUnspent op) (getUnspent op)+ getBalance a = runInWebReader (getBalance a) (getBalance a)+ getBalances as = runInWebReader (getBalances as) (getBalances as)+ getMempool = runInWebReader getMempool getMempool+ getAddressesTxs addrs start limit =+ runInWebReader+ (getAddressesTxs addrs start limit)+ (getAddressesTxs addrs start limit)+ getAddressesUnspents addrs start limit =+ runInWebReader+ (getAddressesUnspents addrs start limit)+ (getAddressesUnspents addrs start limit)+ getOrphans = runInWebReader getOrphans getOrphans+ xPubBals xpub = runInWebReader (xPubBals xpub) (xPubBals xpub)+ xPubSummary xpub =+ runInWebReader (xPubSummary xpub) (xPubSummary xpub)+ xPubUnspents xpub start offset limit =+ runInWebReader+ (xPubUnspents xpub start offset limit)+ (xPubUnspents xpub start offset limit)+ xPubTxs xpub start offset limit =+ runInWebReader+ (xPubTxs xpub start offset limit)+ (xPubTxs xpub start offset limit)++instance MonadLoggerIO m => StoreRead (WebT m) where+ getBestBlock = lift getBestBlock+ getBlocksAtHeight = lift . getBlocksAtHeight+ getBlock = lift . getBlock+ getTxData = lift . getTxData+ getSpender = lift . getSpender+ getSpenders = lift . getSpenders+ 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)+ getOrphans = lift getOrphans+ xPubBals = lift . xPubBals+ xPubSummary = lift . xPubSummary+ xPubUnspents xpub start offset limit =+ lift (xPubUnspents xpub start offset limit)+ xPubTxs xpub start offset limit = lift (xPubTxs xpub start offset limit)+ getMaxGap = lift $ asks (maxLimitGap . webMaxLimits)++defHandler :: Monad m => Except -> WebT m ()+defHandler e = do+ proto <- setupBin+ case e of+ ThingNotFound -> S.status status404+ BadRequest -> S.status status400+ UserError _ -> S.status status400+ StringError _ -> S.status status400+ ServerError -> S.status status500+ BlockTooLarge -> S.status status403+ protoSerial proto e++maybeSerial ::+ (Monad m, JsonSerial a, BinSerial a)+ => Bool -- ^ binary+ -> Maybe a+ -> WebT m ()+maybeSerial _ Nothing = S.raise ThingNotFound+maybeSerial proto (Just x) = do+ net <- lift $ asks (storeNetwork . webStore)+ S.raw (serialAny net proto x)++protoSerial ::+ (Monad m, JsonSerial a, BinSerial a)+ => Bool+ -> a+ -> WebT m ()+protoSerial proto x = do+ net <- lift $ asks (storeNetwork . webStore)+ S.raw (serialAny net proto x)++scottyBestBlock ::+ (MonadLoggerIO m, MonadIO m) => Bool -> WebT m ()+scottyBestBlock raw = do+ limits <- lift $ asks webMaxLimits+ setHeaders+ n <- parseNoTx+ proto <- setupBin+ bm <-+ runMaybeT $ do+ h <- MaybeT getBestBlock+ MaybeT $ getBlock h+ b <-+ case bm of+ Nothing -> S.raise ThingNotFound+ Just b -> return b+ if raw+ then do+ refuseLargeBlock limits b+ rawBlock b >>= protoSerial proto+ else protoSerial proto (pruneTx n b)++scottyBlock :: MonadLoggerIO m => Bool -> WebT m ()+scottyBlock raw = do+ limits <- lift $ asks webMaxLimits+ setHeaders+ MyBlockHash block <- S.param "block"+ n <- parseNoTx+ proto <- setupBin+ b <-+ getBlock block >>= \case+ Nothing -> S.raise ThingNotFound+ Just b -> return b+ if raw+ then do+ refuseLargeBlock limits b+ rawBlock b >>= protoSerial proto+ else protoSerial proto (pruneTx n b)++scottyBlockHeight ::+ MonadLoggerIO m => Bool -> WebT m ()+scottyBlockHeight raw = do+ limits <- lift $ asks webMaxLimits+ setHeaders+ height <- S.param "height"+ n <- parseNoTx+ proto <- setupBin+ hs <- getBlocksAtHeight height+ if raw+ then do+ blocks <- catMaybes <$> mapM getBlock hs+ mapM_ (refuseLargeBlock limits) blocks+ rawblocks <- mapM rawBlock blocks+ protoSerial proto rawblocks+ else do+ blocks <- catMaybes <$> mapM getBlock hs+ let blocks' = map (pruneTx n) blocks+ protoSerial proto blocks'++scottyBlockTime :: MonadLoggerIO m => Bool -> WebT m ()+scottyBlockTime raw = do+ limits <- lift $ asks webMaxLimits+ setHeaders+ q <- S.param "time"+ n <- parseNoTx+ proto <- setupBin+ m <- fmap (pruneTx n) <$> blockAtOrBefore q+ if raw+ then maybeSerial proto =<<+ case m of+ Nothing -> return Nothing+ Just d -> do+ refuseLargeBlock limits d+ Just <$> rawBlock d+ else maybeSerial proto m++scottyBlockHeights :: MonadLoggerIO m => WebT m ()+scottyBlockHeights = do+ setHeaders+ heights <- S.param "heights"+ n <- parseNoTx+ proto <- setupBin+ bhs <- concat <$> mapM getBlocksAtHeight (heights :: [BlockHeight])+ blocks <- map (pruneTx n) . catMaybes <$> mapM getBlock bhs+ protoSerial proto blocks++scottyBlockLatest :: MonadLoggerIO m => WebT m ()+scottyBlockLatest = do+ setHeaders+ n <- parseNoTx+ proto <- setupBin+ getBestBlock >>= \case+ Just h -> do+ blocks <- reverse <$> go 100 n h+ protoSerial proto blocks+ Nothing -> S.raise ThingNotFound+ where+ go 0 _ _ = return []+ go i n h =+ getBlock h >>= \case+ Nothing -> return []+ Just b ->+ let b' = pruneTx n b+ i' = i - 1 :: Int+ prev = prevBlock (blockDataHeader b)+ in if blockDataHeight b <= 0+ then return []+ else (b' :) <$> go i' n prev+++scottyBlocks :: MonadLoggerIO m => WebT m ()+scottyBlocks = do+ setHeaders+ bhs <- map (\(MyBlockHash h) -> h) <$> S.param "blocks"+ n <- parseNoTx+ proto <- setupBin+ bks <- map (pruneTx n) . catMaybes <$> mapM getBlock (nub bhs)+ protoSerial proto bks++scottyMempool :: MonadLoggerIO m => WebT m ()+scottyMempool = do+ setHeaders+ proto <- setupBin+ txs <- map blockTxHash <$> getMempool+ protoSerial proto txs++scottyTransaction :: MonadLoggerIO m => WebT m ()+scottyTransaction = do+ setHeaders+ MyTxHash txid <- S.param "txid"+ proto <- setupBin+ res <- getTransaction txid+ maybeSerial proto res++scottyRawTransaction :: MonadLoggerIO m => WebT m ()+scottyRawTransaction = do+ setHeaders+ MyTxHash txid <- S.param "txid"+ proto <- setupBin+ res <- fmap transactionData <$> getTransaction txid+ maybeSerial proto res++scottyTxAfterHeight :: MonadLoggerIO m => WebT m ()+scottyTxAfterHeight = do+ setHeaders+ MyTxHash txid <- S.param "txid"+ height <- S.param "height"+ proto <- setupBin+ res <- cbAfterHeight 10000 height txid+ protoSerial proto res++scottyTransactions :: MonadLoggerIO m => WebT m ()+scottyTransactions = do+ setHeaders+ txids <- map (\(MyTxHash h) -> h) <$> S.param "txids"+ proto <- setupBin+ txs <- catMaybes <$> mapM getTransaction (nub txids)+ protoSerial proto txs++scottyBlockTransactions :: MonadLoggerIO m => WebT m ()+scottyBlockTransactions = do+ limits <- lift $ asks webMaxLimits+ setHeaders+ MyBlockHash h <- S.param "block"+ proto <- setupBin+ getBlock h >>= \case+ Just b -> do+ refuseLargeBlock limits b+ let ths = blockDataTxs b+ txs <- catMaybes <$> mapM getTransaction ths+ protoSerial proto txs+ Nothing -> S.raise ThingNotFound++scottyRawTransactions ::+ MonadLoggerIO m => WebT m ()+scottyRawTransactions = do+ setHeaders+ txids <- map (\(MyTxHash h) -> h) <$> S.param "txids"+ proto <- setupBin+ txs <- map transactionData . catMaybes <$> mapM getTransaction (nub txids)+ protoSerial proto txs++rawBlock :: (Monad m, StoreRead m) => BlockData -> m Block+rawBlock b = do+ let h = blockDataHeader b+ ths = blockDataTxs b+ txs <- map transactionData . catMaybes <$> mapM getTransaction ths+ return Block {blockHeader = h, blockTxns = txs}++scottyRawBlockTransactions ::+ MonadLoggerIO m => WebT m ()+scottyRawBlockTransactions = do+ limits <- lift $ asks webMaxLimits+ setHeaders+ MyBlockHash h <- S.param "block"+ proto <- setupBin+ getBlock h >>= \case+ Just b -> do+ refuseLargeBlock limits b+ let ths = blockDataTxs b+ txs <- map transactionData . catMaybes <$> mapM getTransaction ths+ protoSerial proto txs+ Nothing -> S.raise ThingNotFound++scottyAddressTxs :: MonadLoggerIO m => Bool -> WebT m ()+scottyAddressTxs full = do+ setHeaders+ a <- parseAddress+ s <- getStart+ o <- getOffset+ l <- getLimit full+ proto <- setupBin+ if full+ then do+ getAddressTxsFull o l s a >>= protoSerial proto+ else do+ getAddressTxsLimit o l s a >>= protoSerial proto++scottyAddressesTxs ::+ MonadLoggerIO m => Bool -> WebT m ()+scottyAddressesTxs full = do+ setHeaders+ as <- parseAddresses+ s <- getStart+ l <- getLimit full+ proto <- setupBin+ if full+ then getAddressesTxsFull l s as >>= protoSerial proto+ else getAddressesTxsLimit l s as >>= protoSerial proto++scottyAddressUnspent :: MonadLoggerIO m => WebT m ()+scottyAddressUnspent = do+ setHeaders+ a <- parseAddress+ s <- getStart+ o <- getOffset+ l <- getLimit False+ proto <- setupBin+ uns <- getAddressUnspentsLimit o l s a+ protoSerial proto uns++scottyAddressesUnspent :: MonadLoggerIO m => WebT m ()+scottyAddressesUnspent = do+ setHeaders+ as <- parseAddresses+ s <- getStart+ l <- getLimit False+ proto <- setupBin+ uns <- getAddressesUnspentsLimit l s as+ protoSerial proto uns++scottyAddressBalance :: MonadLoggerIO m => WebT m ()+scottyAddressBalance = do+ setHeaders+ a <- parseAddress+ proto <- setupBin+ res <- getBalance a+ protoSerial proto res++scottyAddressesBalances :: MonadLoggerIO m => WebT m ()+scottyAddressesBalances = do+ setHeaders+ as <- parseAddresses+ proto <- setupBin+ res <- getBalances as+ protoSerial proto res++scottyXpubBalances :: MonadLoggerIO m => WebT m ()+scottyXpubBalances = do+ setHeaders+ xpub <- parseXpub+ proto <- setupBin+ res <- filter (not . nullBalance . xPubBal) <$> xPubBals xpub+ protoSerial proto res++scottyXpubTxs :: MonadLoggerIO m => Bool -> WebT m ()+scottyXpubTxs full = do+ setHeaders+ xpub <- parseXpub+ start <- getStart+ limit <- getLimit full+ proto <- setupBin+ txs <- xPubTxs xpub start 0 limit+ if full+ then do+ txs' <- catMaybes <$> mapM (getTransaction . blockTxHash) txs+ protoSerial proto txs'+ else protoSerial proto txs++scottyXpubUnspents :: MonadLoggerIO m => WebT m ()+scottyXpubUnspents = do+ setHeaders+ xpub <- parseXpub+ proto <- setupBin+ start <- getStart+ limit <- getLimit False+ uns <- xPubUnspents xpub start 0 limit+ protoSerial proto uns++scottyXpubSummary :: MonadLoggerIO m => WebT m ()+scottyXpubSummary = do+ setHeaders+ xpub <- parseXpub+ proto <- setupBin+ res <- xPubSummary xpub+ protoSerial proto res++scottyPostTx ::+ (MonadUnliftIO m, MonadLoggerIO m)+ => WebT m ()+scottyPostTx = do+ net <- lift $ asks (storeNetwork . webStore)+ pub <- lift $ asks (storePublisher . webStore)+ mgr <- lift $ asks (storeManager . webStore)+ setHeaders+ proto <- setupBin+ b <- S.body+ let bin = eitherToMaybe . Serialize.decode+ hex = bin <=< decodeHex . cs . C.filter (not . isSpace)+ tx <-+ case hex b <|> bin (L.toStrict b) of+ Nothing -> S.raise $ UserError "decode tx fail"+ Just x -> return x+ lift (publishTx net pub mgr tx) >>= \case+ Right () -> do+ protoSerial proto (TxId (txHash tx))+ Left e -> do+ case e of+ PubNoPeers -> S.status status500+ PubTimeout -> S.status status500+ PubPeerDisconnected -> S.status status500+ PubReject _ -> S.status status400+ protoSerial proto (UserError (show e))+ S.finish++scottyDbStats :: MonadLoggerIO m => WebT m ()+scottyDbStats = do+ setHeaders+ db <- lift $ asks (databaseHandle . storeDB . webStore)+ stats <- lift (getProperty db Stats)+ case stats of+ Nothing -> do+ S.text "Could not get stats"+ Just txt -> do+ S.text $ cs txt++scottyEvents :: MonadLoggerIO m => WebT m ()+scottyEvents = do+ net <- lift $ asks (storeNetwork . webStore)+ pub <- lift $ asks (storePublisher . webStore)+ setHeaders+ proto <- setupBin+ S.stream $ \io flush' ->+ withSubscription pub $ \sub ->+ forever $+ flush' >> receive sub >>= \se -> do+ let me =+ case se of+ 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 ->+ let bs =+ serialAny net proto e <>+ if proto+ then mempty+ else "\n"+ in io (lazyByteString bs)++scottyPeers :: MonadLoggerIO m => WebT m ()+scottyPeers = do+ mgr <- lift $ asks (storeManager . webStore)+ setHeaders+ proto <- setupBin+ ps <- getPeersInformation mgr+ protoSerial proto ps++scottyHealth ::+ (MonadUnliftIO m, MonadLoggerIO m)+ => WebT m ()+scottyHealth = do+ net <- lift $ asks (storeNetwork . webStore)+ mgr <- lift $ asks (storeManager . webStore)+ chn <- lift $ asks (storeChain . webStore)+ tos <- lift $ asks webWebTimeouts+ setHeaders+ proto <- setupBin+ h <- lift $ healthCheck net mgr chn tos+ when (not (healthOK h) || not (healthSynced h)) $ S.status status503+ protoSerial proto h++runWeb :: (MonadLoggerIO m, MonadUnliftIO m) => WebConfig -> m ()+runWeb cfg@WebConfig {webPort = port, webReqLog = reqlog} = do+ req_logger <-+ if reqlog+ then Just <$> logIt+ else return Nothing+ runner <- askRunInIO+ S.scottyT port (runner . (`runReaderT` cfg)) $ do+ case req_logger of+ Just m -> S.middleware m+ Nothing -> return ()+ S.defaultHandler defHandler+ S.get "/block/best" $ scottyBestBlock False+ S.get "/block/best/raw" $ scottyBestBlock True+ S.get "/block/:block" $ scottyBlock False+ S.get "/block/:block/raw" $ scottyBlock True+ S.get "/block/height/:height" $ scottyBlockHeight False+ S.get "/block/height/:height/raw" $ scottyBlockHeight True+ S.get "/block/time/:time" $ scottyBlockTime False+ S.get "/block/time/:time/raw" $ scottyBlockTime True+ S.get "/block/heights" scottyBlockHeights+ S.get "/block/latest" scottyBlockLatest+ S.get "/blocks" scottyBlocks+ S.get "/mempool" scottyMempool+ S.get "/transaction/:txid" scottyTransaction+ S.get "/transaction/:txid/raw" scottyRawTransaction+ S.get "/transaction/:txid/after/:height" scottyTxAfterHeight+ S.get "/transactions" scottyTransactions+ S.get "/transactions/raw" scottyRawTransactions+ S.get "/transactions/block/:block" scottyBlockTransactions+ S.get "/transactions/block/:block/raw" scottyRawBlockTransactions+ S.get "/address/:address/transactions" $ scottyAddressTxs False+ S.get "/address/:address/transactions/full" $ scottyAddressTxs True+ S.get "/address/transactions" $ scottyAddressesTxs False+ S.get "/address/transactions/full" $ scottyAddressesTxs True+ S.get "/address/:address/unspent" scottyAddressUnspent+ S.get "/address/unspent" scottyAddressesUnspent+ S.get "/address/:address/balance" scottyAddressBalance+ S.get "/address/balances" scottyAddressesBalances+ S.get "/xpub/:xpub/balances" scottyXpubBalances+ S.get "/xpub/:xpub/transactions" $ scottyXpubTxs False+ S.get "/xpub/:xpub/transactions/full" $ scottyXpubTxs True+ S.get "/xpub/:xpub/unspent" scottyXpubUnspents+ S.get "/xpub/:xpub" scottyXpubSummary+ S.post "/transactions" scottyPostTx+ S.get "/dbstats" scottyDbStats+ S.get "/events" scottyEvents+ S.get "/peers" scottyPeers+ S.get "/health" scottyHealth+ S.notFound $ S.raise ThingNotFound++getStart :: MonadLoggerIO m => WebT m (Maybe BlockRef)+getStart =+ runMaybeT $ do+ s <- MaybeT $ (Just <$> S.param "height") `S.rescue` const (return Nothing)+ do case s of+ StartParamHash {startParamHash = h} ->+ start_tx h <|> start_block h+ StartParamHeight {startParamHeight = h} -> start_height h+ StartParamTime {startParamTime = q} -> start_time q+ where+ start_height h = return $ BlockRef h maxBound+ start_block h = do+ b <- MaybeT $ getBlock (BlockHash h)+ let g = blockDataHeight b+ return $ BlockRef g maxBound+ start_tx h = do+ t <- MaybeT $ getTxData (TxHash h)+ return $ txDataBlock t+ start_time q = do+ d <- MaybeT getBestBlock >>= MaybeT . getBlock+ if q <= fromIntegral (blockTimestamp (blockDataHeader d))+ then do+ b <- MaybeT $ blockAtOrBefore q+ let g = blockDataHeight b+ return $ BlockRef g maxBound+ else return $ MemRef q++getOffset :: Monad m => WebT m Offset+getOffset = do+ limits <- lift $ asks webMaxLimits+ o <- S.param "offset" `S.rescue` const (return 0)+ when (maxLimitOffset limits > 0 && o > maxLimitOffset limits) .+ S.raise . UserError $+ "offset exceeded: " <> show o <> " > " <> show (maxLimitOffset limits)+ return o++getLimit ::+ Monad m+ => Bool+ -> WebT m (Maybe Limit)+getLimit full = do+ limits <- lift $ asks webMaxLimits+ l <- (Just <$> S.param "limit") `S.rescue` const (return Nothing)+ let m =+ if full+ then if maxLimitFull limits > 0+ then maxLimitFull limits+ else maxLimitCount limits+ else maxLimitCount limits+ let d = maxLimitDefault limits+ return $+ case l of+ Nothing ->+ if d > 0 || m > 0+ then Just (min m d)+ else Nothing+ Just n ->+ if m > 0+ then Just (min m n)+ else Just n++parseAddress :: Monad m => WebT m Address+parseAddress = do+ net <- lift $ asks (storeNetwork . webStore)+ address <- S.param "address"+ case stringToAddr net address of+ Nothing -> S.next+ Just a -> return a++parseAddresses :: Monad m => WebT m [Address]+parseAddresses = do+ net <- lift $ asks (storeNetwork . webStore)+ addresses <- S.param "addresses"+ let as = mapMaybe (stringToAddr net) addresses+ unless (length as == length addresses) S.next+ return as++parseXpub :: Monad m => WebT m XPubSpec+parseXpub = do+ net <- lift $ asks (storeNetwork . webStore)+ t <- S.param "xpub"+ d <- parseDeriveAddrs+ case xPubImport net t of+ Nothing -> S.next+ Just x -> return XPubSpec {xPubSpecKey = x, xPubDeriveType = d}++parseDeriveAddrs ::+ Monad m => WebT m DeriveType+parseDeriveAddrs =+ lift (asks (storeNetwork . webStore)) >>= \case+ net+ | getSegWit net -> do+ t <- S.param "derive" `S.rescue` const (return "standard")+ return $+ case (t :: Text) of+ "segwit" -> DeriveP2WPKH+ "compat" -> DeriveP2SH+ _ -> DeriveNormal+ | otherwise -> return DeriveNormal++parseNoTx :: (Monad m, ScottyError e) => ActionT e m Bool+parseNoTx = S.param "notx" `S.rescue` const (return False)++pruneTx :: Bool -> BlockData -> BlockData+pruneTx False b = b+pruneTx True b = b {blockDataTxs = take 1 (blockDataTxs b)}++setHeaders :: (Monad m, ScottyError e) => ActionT e m ()+setHeaders = do+ S.setHeader "Access-Control-Allow-Origin" "*"++serialAny ::+ (JsonSerial a, BinSerial a)+ => Network+ -> Bool -- ^ binary+ -> a+ -> L.ByteString+serialAny net True = runPutLazy . binSerial net+serialAny net False = encodingToLazyByteString . jsonSerial net++setupBin :: Monad m => ActionT Except m Bool+setupBin =+ let p = do+ S.setHeader "Content-Type" "application/octet-stream"+ return True+ j = do+ S.setHeader "Content-Type" "application/json"+ return False+ in S.header "accept" >>= \case+ Nothing -> j+ Just x ->+ if is_binary x+ then p+ else j+ where+ is_binary = (== "application/octet-stream")++instance MonadLoggerIO m => MonadLoggerIO (WebT m) where+ askLoggerIO = lift askLoggerIO++instance MonadLogger m => MonadLogger (WebT m) where+ monadLoggerLog loc src lvl = lift . monadLoggerLog loc src lvl++healthCheck ::+ (MonadUnliftIO m, StoreRead m)+ => Network+ -> Manager+ -> Chain+ -> WebTimeouts+ -> m HealthCheck+healthCheck net mgr ch tos = do+ cb <- chain_best+ bb <- block_best+ pc <- peer_count+ tm <- get_current_time+ ml <- get_mempool_last+ let ck = block_ok cb+ bk = block_ok bb+ pk = peer_count_ok pc+ bd = block_time_delta tm cb+ td = tx_time_delta tm bd ml+ lk = timeout_ok (blockTimeout tos) bd+ tk = timeout_ok (txTimeout tos) td+ sy = in_sync bb cb+ ok = ck && bk && pk && lk && (tk || not sy)+ return+ HealthCheck+ { healthBlockBest = block_hash <$> bb+ , healthBlockHeight = block_height <$> bb+ , healthHeaderBest = node_hash <$> cb+ , healthHeaderHeight = node_height <$> cb+ , healthPeers = pc+ , healthNetwork = getNetworkName net+ , healthOK = ok+ , healthSynced = sy+ , healthLastBlock = bd+ , healthLastTx = td+ }+ where+ block_hash = headerHash . blockDataHeader+ block_height = blockDataHeight+ node_hash = headerHash . nodeHeader+ node_height = nodeHeight+ get_mempool_last = listToMaybe <$> getMempool+ get_current_time = fromIntegral . systemSeconds <$> liftIO getSystemTime+ peer_count_ok pc = fromMaybe 0 pc > 0+ block_ok = isJust+ node_timestamp = fromIntegral . blockTimestamp . nodeHeader+ in_sync bb cb = fromMaybe False $ do+ bh <- blockDataHeight <$> bb+ nh <- nodeHeight <$> cb+ return $ compute_delta bh nh <= 1+ block_time_delta tm cb = do+ bt <- node_timestamp <$> cb+ return $ compute_delta bt tm+ tx_time_delta tm bd ml = do+ bd' <- bd+ tt <- memRefTime . blockTxBlock <$> ml <|> bd+ return $ min (compute_delta tt tm) bd'+ timeout_ok to td = fromMaybe False $ do+ td' <- td+ return $+ getAllowMinDifficultyBlocks net ||+ to == 0 ||+ td' <= to+ peer_count = fmap length <$> timeout 500000 (managerGetPeers mgr)+ block_best = runMaybeT $ do+ h <- MaybeT getBestBlock+ MaybeT $ getBlock h+ chain_best = timeout 500000 $ chainGetBest ch+ compute_delta a b = if b > a then b - a else 0++-- | Obtain information about connected peers from peer manager process.+getPeersInformation :: MonadIO m => Manager -> m [PeerInformation]+getPeersInformation mgr = mapMaybe toInfo <$> managerGetPeers mgr+ where+ toInfo op = do+ ver <- onlinePeerVersion op+ let as = onlinePeerAddress op+ ua = getVarString $ userAgent ver+ vs = version ver+ sv = services ver+ rl = relay ver+ return+ PeerInformation+ { peerUserAgent = ua+ , peerAddress = sockToHostAddress as+ , peerVersion = vs+ , peerServices = sv+ , peerRelay = rl+ }++-- | Check if any of the ancestors of this transaction is a coinbase after the+-- specified height. Returns 'Nothing' if answer cannot be computed before+-- hitting limits.+cbAfterHeight ::+ (MonadIO m, StoreRead m)+ => Int -- ^ how many ancestors to test before giving up+ -> BlockHeight+ -> TxHash+ -> m TxAfterHeight+cbAfterHeight d h t+ | d <= 0 = return $ TxAfterHeight Nothing+ | otherwise = do+ x <- fmap snd <$> tst d t+ return $ TxAfterHeight x+ where+ tst e x+ | e <= 0 = return Nothing+ | otherwise = do+ let e' = e - 1+ getTransaction x >>= \case+ Nothing -> return Nothing+ Just tx ->+ if any isCoinbase (transactionInputs tx)+ then return $+ Just (e', blockRefHeight (transactionBlock tx) > h)+ else case transactionBlock tx of+ BlockRef {blockRefHeight = b}+ | b <= h -> return $ Just (e', False)+ _ ->+ r e' . nub $+ map+ (outPointHash . inputPoint)+ (transactionInputs tx)+ r e [] = return $ Just (e, False)+ r e (n:ns) =+ tst e n >>= \case+ Nothing -> return Nothing+ Just (e', s) ->+ if s+ then return $ Just (e', True)+ else r e' ns++getAddressTxsLimit ::+ (Monad m, StoreRead m)+ => Offset+ -> Maybe Limit+ -> Maybe BlockRef+ -> Address+ -> m [BlockTx]+getAddressTxsLimit offset limit start addr =+ applyOffset offset <$> getAddressTxs addr start ((offset +) <$> limit)++getAddressTxsFull ::+ (Monad m, StoreRead m)+ => Offset+ -> Maybe Limit+ -> Maybe BlockRef+ -> Address+ -> m [Transaction]+getAddressTxsFull offset limit start addr = do+ txs <- getAddressTxsLimit offset limit start addr+ catMaybes <$> mapM (getTransaction . blockTxHash) txs++getAddressesTxsLimit ::+ (Monad m, StoreRead m)+ => Maybe Limit+ -> Maybe BlockRef+ -> [Address]+ -> m [BlockTx]+getAddressesTxsLimit limit start addrs =+ getAddressesTxs addrs start limit++getAddressesTxsFull ::+ (Monad m, StoreRead m)+ => Maybe Limit+ -> Maybe BlockRef+ -> [Address]+ -> m [Transaction]+getAddressesTxsFull limit start addrs =+ fmap catMaybes $+ getAddressesTxsLimit limit start addrs >>=+ mapM (getTransaction . blockTxHash)++getAddressUnspentsLimit ::+ (Monad m, StoreRead m)+ => Offset+ -> Maybe Limit+ -> Maybe BlockRef+ -> Address+ -> m [Unspent]+getAddressUnspentsLimit offset limit start addr =+ applyOffset offset <$> getAddressUnspents addr start ((offset +) <$> limit)++getAddressesUnspentsLimit ::+ (Monad m, StoreRead m)+ => Maybe Limit+ -> Maybe BlockRef+ -> [Address]+ -> m [Unspent]+getAddressesUnspentsLimit limit start addrs =+ getAddressesUnspents addrs start limit++-- | Publish a new transaction to the network.+publishTx ::+ (MonadUnliftIO m, StoreRead m)+ => Network+ -> Publisher StoreEvent+ -> Manager+ -> Tx+ -> m (Either PubExcept ())+publishTx net pub mgr tx =+ withSubscription pub $ \s ->+ getTransaction (txHash tx) >>= \case+ Just _ -> return $ Right ()+ Nothing -> go s+ where+ go s =+ managerGetPeers mgr >>= \case+ [] -> return $ Left PubNoPeers+ OnlinePeer {onlinePeerMailbox = p}:_ -> do+ MTx tx `sendMessage` p+ let v =+ if getSegWit net+ then InvWitnessTx+ else InvTx+ sendMessage+ (MGetData (GetData [InvVector v (getTxHash (txHash tx))]))+ p+ f p s+ t = 5 * 1000 * 1000+ f p s =+ liftIO (timeout t (g p s)) >>= \case+ Nothing -> return $ Left PubTimeout+ Just (Left e) -> return $ Left e+ Just (Right ()) -> return $ Right ()+ g p s =+ receive s >>= \case+ StoreTxReject p' h' c _+ | p == p' && h' == txHash tx -> return . Left $ PubReject c+ StorePeerDisconnected p' _+ | p == p' -> return $ Left PubPeerDisconnected+ StoreMempoolNew h'+ | h' == txHash tx -> return $ Right ()+ _ -> g p s++logIt :: (MonadUnliftIO m, MonadLoggerIO m) => m Middleware+logIt = do+ runner <- askRunInIO+ return $ \app req respond -> do+ t1 <- getCurrentTime+ app req $ \res -> do+ t2 <- getCurrentTime+ let d = diffUTCTime t2 t1+ s = responseStatus res+ runner $+ $(logInfoS) "Web" $+ fmtReq req <> " [" <> fmtStatus s <> " / " <> fmtDiff d <> "]"+ respond res++fmtReq :: Request -> Text+fmtReq req =+ let m = requestMethod req+ v = httpVersion req+ p = rawPathInfo req+ q = rawQueryString req+ in T.decodeUtf8 $ m <> " " <> p <> q <> " " <> cs (show v)++fmtDiff :: NominalDiffTime -> Text+fmtDiff d =+ cs (printf "%0.3f" (realToFrac (d * 1000) :: Double) :: String) <> " ms"++fmtStatus :: Status -> Text+fmtStatus s = cs (show (statusCode s)) <> " " <> cs (statusMessage s)++refuseLargeBlock :: Monad m => WebLimits -> BlockData -> ActionT Except m ()+refuseLargeBlock WebLimits {maxLimitFull = f} BlockData {blockDataTxs = txs} =+ when (length txs > fromIntegral f) $ S.raise BlockTooLarge
− src/Network/Haskoin/Store/BlockStore.hs
@@ -1,537 +0,0 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TupleSections #-}-module Network.Haskoin.Store.BlockStore where--import Control.Applicative ((<|>))-import Control.Monad (forM, 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 (MaybeT (MaybeT),- runMaybeT)-import Data.Maybe (catMaybes,- isNothing,- listToMaybe)-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 Haskoin.Node (Chain, Manager)-import Network.Haskoin.Store.Common (BlockStore, BlockStoreMessage (..),- StoreEvent (..),- StoreRead (..),- StoreWrite (..),- UnixTime)-import Network.Haskoin.Store.Data.DatabaseReader (DatabaseReader)-import Network.Haskoin.Store.Data.DatabaseWriter (DatabaseWriter,- runDatabaseWriter)-import Network.Haskoin.Store.Logic (ImportException,- deleteTx,- getOldMempool,- getOldOrphans,- importBlock,- importOrphan,- initBest,- newMempoolTx,- revertBlock)-import NQE (Inbox, Listen,- 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- | Uninitialized- | AncestorNotInChain !BlockHeight- !BlockHash- deriving (Show, Eq, Ord, Exception)--data Syncing = Syncing- { syncingPeer :: !Peer- , syncingTime :: !UnixTime- , syncingHead :: !BlockNode- }---- | Block store process state.-data BlockRead = BlockRead- { mySelf :: !BlockStore- , myConfig :: !BlockStoreConfig- , myPeer :: !(TVar (Maybe Syncing))- }---- | Configuration for a block store.-data BlockStoreConfig =- BlockStoreConfig- { blockConfManager :: !Manager- -- ^ peer manager from running node- , blockConfChain :: !Chain- -- ^ chain from a running node- , blockConfListener :: !(Listen StoreEvent)- -- ^ listener for store events- , blockConfDB :: !DatabaseReader- -- ^ RocksDB database handle- , blockConfNet :: !Network- -- ^ network constants- }--type BlockT m = ReaderT BlockRead m--runImport ::- MonadLoggerIO m- => ReaderT DatabaseWriter (ExceptT ImportException m) a- -> ReaderT BlockRead m (Either ImportException a)-runImport f =- ReaderT $ \r -> runExceptT (runDatabaseWriter (blockConfDB (myConfig r)) f)--runRocksDB :: ReaderT DatabaseReader m a -> ReaderT BlockRead m a-runRocksDB f =- ReaderT $ \BlockRead {myConfig = BlockStoreConfig {blockConfDB = db}} ->- runReaderT f db--instance MonadIO m => StoreRead (ReaderT BlockRead m) where- 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)- getOrphans = runRocksDB getOrphans- getAddressUnspents a s = runRocksDB . getAddressUnspents a s- getAddressTxs a s = runRocksDB . getAddressTxs a s---- | Run block store process.-blockStore ::- (MonadUnliftIO m, MonadLoggerIO m)- => BlockStoreConfig- -> Inbox BlockStoreMessage- -> m ()-blockStore cfg inbox = do- pb <- newTVarIO Nothing- runReaderT- (ini >> run)- BlockRead {mySelf = inboxToMailbox inbox, myConfig = cfg, myPeer = pb}- where- ini = do- net <- asks (blockConfNet . myConfig)- runImport (initBest net) >>= \case- Left e -> do- $(logErrorS) "BlockStore" $- "Could not initialize block store: " <> fromString (show e)- throwIO e- Right () -> return ()- run =- withAsync (pingMe (inboxToMailbox inbox)) . const . forever $ do- receive inbox >>= \x ->- ReaderT $ \r -> runReaderT (processBlockStoreMessage x) r--isInSync ::- (MonadLoggerIO m, StoreRead m, MonadReader BlockRead m)- => m Bool-isInSync =- getBestBlock >>= \case- Nothing -> do- $(logErrorS) "BlockStore" "Block database uninitialized"- throwIO Uninitialized- Just bb ->- asks (blockConfChain . myConfig) >>= chainGetBest >>= \cb ->- return (headerHash (nodeHeader cb) == bb)--mempool :: MonadLoggerIO m => Peer -> m ()-mempool p = do- $(logDebugS) "BlockStore" "Requesting mempool from network peer"- MMempool `sendMessage` p--processBlock ::- (MonadUnliftIO m, MonadLoggerIO m)- => Peer- -> Block- -> ReaderT BlockRead m ()-processBlock peer block = do- void . runMaybeT $ do- checkpeer- blocknode <- getblocknode- net <- asks (blockConfNet . myConfig)- lift (runImport (importBlock net block blocknode)) >>= \case- Right deletedtxids -> do- listener <- asks (blockConfListener . myConfig)- $(logInfoS) "BlockStore" $ "Best block indexed: " <> hexhash- atomically $ do- mapM_ (listener . StoreTxDeleted) deletedtxids- listener (StoreBestBlock blockhash)- lift (syncMe peer)- Left e -> do- $(logErrorS) "BlockStore" $- "Error importing block: " <> hexhash <> ": " <>- fromString (show e)- killPeer (PeerMisbehaving (show e)) peer- where- header = blockHeader block- blockhash = headerHash header- hexhash = blockHashToHex blockhash- checkpeer =- getSyncingState >>= \case- Just Syncing {syncingPeer = syncingpeer}- | peer == syncingpeer -> return ()- _ -> do- $(logErrorS) "BlockStore" $ "Peer sent unexpected block: " <> hexhash- killPeer (PeerMisbehaving "Sent unpexpected block") peer- mzero- getblocknode =- asks (blockConfChain . myConfig) >>= chainGetBlock blockhash >>= \case- Nothing -> do- $(logErrorS) "BlockStore" $ "Block header not found: " <> hexhash- killPeer (PeerMisbehaving "Sent unknown block") peer- mzero- Just n -> return n--processNoBlocks ::- (MonadUnliftIO m, MonadLoggerIO m)- => Peer- -> [BlockHash]- -> ReaderT BlockRead m ()-processNoBlocks p _bs = do- $(logErrorS) "BlockStore" (cs m)- killPeer (PeerMisbehaving m) p- where- m = "I do not like peers that cannot find them blocks"--processTx :: (MonadUnliftIO m, MonadLoggerIO m) => Peer -> Tx -> BlockT m ()-processTx _p tx =- isInSync >>= \sync ->- when sync $ do- now <- fromIntegral . systemSeconds <$> liftIO getSystemTime- net <- asks (blockConfNet . myConfig)- runImport (newMempoolTx net tx now) >>= \case- Right (Just deleted) -> do- l <- blockConfListener <$> asks myConfig- $(logInfoS) "BlockStore" $- "New mempool tx: " <> txHashToHex (txHash tx)- atomically $ do- mapM_ (l . StoreTxDeleted) deleted- l (StoreMempoolNew (txHash tx))- _ -> return ()--processOrphans ::- (MonadUnliftIO m, MonadLoggerIO m) => BlockT m ()-processOrphans =- isInSync >>= \sync ->- when sync $ do- now <- fromIntegral . systemSeconds <$> liftIO getSystemTime- net <- asks (blockConfNet . myConfig)- old <- getOldOrphans now- case old of- [] -> return ()- _ -> do- $(logInfoS) "BlockStore" $- "Removing " <> cs (show (length old)) <>- " expired orphan transactions"- void . runImport $ mapM_ deleteOrphanTx old- orphans <- getOrphans- case orphans of- [] -> return ()- _ ->- $(logInfoS) "BlockStore" $- "Attempting to import " <> cs (show (length orphans)) <>- " orphan transactions"- ops <-- zip (map snd orphans) <$>- mapM (runImport . uncurry (importOrphan net)) orphans- 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---processTxs ::- (MonadUnliftIO m, MonadLoggerIO m)- => Peer- -> [TxHash]- -> ReaderT BlockRead m ()-processTxs p hs =- isInSync >>= \sync ->- when sync $ do- xs <-- fmap catMaybes . forM hs $ \h ->- runMaybeT $ do- t <- lift $ getTxData h- guard (isNothing t)- return (getTxHash h)- unless (null xs) $ do- $(logInfoS) "BlockStore" $- "Requesting " <> fromString (show (length xs)) <>- " new transactions"- net <- blockConfNet <$> asks myConfig- let inv =- if getSegWit net- then InvWitnessTx- else InvTx- MGetData (GetData (map (InvVector inv) xs)) `sendMessage` p--checkTime :: (MonadUnliftIO m, MonadLoggerIO m) => ReaderT BlockRead m ()-checkTime =- asks myPeer >>= readTVarIO >>= \case- Nothing -> return ()- Just Syncing {syncingTime = t, syncingPeer = p} -> do- n <- fromIntegral . systemSeconds <$> liftIO getSystemTime- when (n > t + 60) $ do- $(logErrorS) "BlockStore" "Syncing peer timeout"- resetPeer- killPeer PeerTimeout p--processDisconnect ::- (MonadUnliftIO m, MonadLoggerIO m)- => Peer- -> ReaderT BlockRead m ()-processDisconnect p =- asks myPeer >>= readTVarIO >>= \case- Nothing -> return ()- Just Syncing {syncingPeer = p'}- | p == p' -> do- resetPeer- getPeer >>= \case- Nothing ->- $(logWarnS)- "BlockStore"- "No peers available after syncing peer disconnected"- Just peer -> do- $(logWarnS) "BlockStore" "Selected another peer to sync"- syncMe peer- | otherwise -> return ()--pruneMempool :: (MonadUnliftIO m, MonadLoggerIO m) => BlockT m ()-pruneMempool =- isInSync >>= \sync ->- when sync $ do- now <- fromIntegral . systemSeconds <$> liftIO getSystemTime- getOldMempool now >>= \case- [] -> return ()- old -> deletetxs old- where- deletetxs old = do- $(logInfoS) "BlockStore" $- "Removing " <> cs (show (length old)) <> " old mempool transactions"- net <- asks (blockConfNet . myConfig)- forM_ old $ \txid ->- runImport (deleteTx net True txid) >>= \case- Left _ -> return ()- Right txids -> do- listener <- asks (blockConfListener . myConfig)- atomically $ mapM_ (listener . StoreTxDeleted) txids--syncMe :: (MonadUnliftIO m, MonadLoggerIO m) => Peer -> BlockT m ()-syncMe peer =- void . runMaybeT $ do- checksyncingpeer- reverttomainchain- syncbest <- syncbestnode- bestblock <- bestblocknode- chainbest <- chainbestnode- end syncbest bestblock chainbest- blocknodes <- selectblocks chainbest syncbest- setPeer peer (last blocknodes)- net <- asks (blockConfNet . myConfig)- let inv =- if getSegWit net- then InvWitnessBlock- else InvBlock- vectors =- map- (InvVector inv . getBlockHash . headerHash . nodeHeader)- blocknodes- $(logInfoS) "BlockStore" $- "Requesting " <> fromString (show (length vectors)) <> " blocks"- MGetData (GetData vectors) `sendMessage` peer- where- checksyncingpeer =- getSyncingState >>= \case- Nothing -> return ()- Just Syncing {syncingPeer = p}- | p == peer -> return ()- | otherwise -> do- $(logInfoS) "BlockStore" "Already syncing against another peer"- mzero- chainbestnode = chainGetBest =<< asks (blockConfChain . myConfig)- bestblocknode = do- bb <-- lift getBestBlock >>= \case- Nothing -> do- $(logErrorS) "BlockStore" "No best block set"- throwIO Uninitialized- Just b -> return b- ch <- asks (blockConfChain . myConfig)- chainGetBlock bb ch >>= \case- Nothing -> do- $(logErrorS) "BlockStore" $- "Header not found for best block: " <> blockHashToHex bb- throwIO (BlockNotInChain bb)- Just x -> return x- syncbestnode =- asks myPeer >>= readTVarIO >>= \case- Just Syncing {syncingHead = b} -> return b- Nothing -> bestblocknode- end syncbest bestblock chainbest- | nodeHeader bestblock == nodeHeader chainbest = do- resetPeer >> mempool peer >> mzero- | nodeHeader syncbest == nodeHeader chainbest = do mzero- | otherwise =- when (nodeHeight syncbest > nodeHeight bestblock + 500) mzero- selectblocks chainbest syncbest = do- synctop <-- top- chainbest- (maxsyncheight (nodeHeight chainbest) (nodeHeight syncbest))- ch <- asks (blockConfChain . myConfig)- parents <- chainGetParents (nodeHeight syncbest + 1) synctop ch- return $- if length parents < 500- then parents <> [chainbest]- else parents- maxsyncheight chainheight syncbestheight- | chainheight <= syncbestheight + 501 = chainheight- | otherwise = syncbestheight + 501- top chainbest syncheight = do- ch <- asks (blockConfChain . myConfig)- if syncheight == nodeHeight chainbest- then return chainbest- else chainGetAncestor syncheight chainbest ch >>= \case- Just x -> return x- Nothing -> do- $(logErrorS) "BlockStore" $- "Could not find header for ancestor of block: " <>- blockHashToHex (headerHash (nodeHeader chainbest))- throwIO $- AncestorNotInChain- syncheight- (headerHash (nodeHeader chainbest))- reverttomainchain = do- bestblockhash <- headerHash . nodeHeader <$> bestblocknode- ch <- asks (blockConfChain . myConfig)- chainBlockMain bestblockhash ch >>= \y ->- unless y $ do- $(logErrorS) "BlockStore" $- "Reverting best block: " <> blockHashToHex bestblockhash- resetPeer- net <- asks (blockConfNet . myConfig)- lift (runImport (revertBlock net bestblockhash)) >>= \case- Left e -> do- $(logErrorS) "BlockStore" $- "Could not revert best block: " <> cs (show e)- throwIO e- Right txids -> do- listener <- asks (blockConfListener . myConfig)- atomically $ do- mapM_ (listener . StoreTxDeleted) txids- listener (StoreBlockReverted bestblockhash)- reverttomainchain--resetPeer :: (MonadLoggerIO m, MonadReader BlockRead m) => m ()-resetPeer = do- box <- asks myPeer- atomically $ writeTVar box Nothing--setPeer :: (MonadIO m, MonadReader BlockRead m) => Peer -> BlockNode -> m ()-setPeer p b = do- box <- asks myPeer- now <- fromIntegral . systemSeconds <$> liftIO getSystemTime- atomically . writeTVar box $- Just Syncing {syncingPeer = p, syncingHead = b, syncingTime = now}--getPeer :: (MonadIO m, MonadReader BlockRead m) => m (Maybe Peer)-getPeer = runMaybeT $ MaybeT syncingpeer <|> MaybeT onlinepeer- where- syncingpeer = fmap syncingPeer <$> getSyncingState- onlinepeer =- listToMaybe . map onlinePeerMailbox <$>- (managerGetPeers =<< asks (blockConfManager . myConfig))--getSyncingState :: (MonadIO m, MonadReader BlockRead m) => m (Maybe Syncing)-getSyncingState = readTVarIO =<< asks myPeer--processBlockStoreMessage ::- (MonadUnliftIO m, MonadLoggerIO m)- => BlockStoreMessage- -> BlockT m ()-processBlockStoreMessage (BlockNewBest _) = do- getPeer >>= \case- Nothing -> do- $(logDebugS)- "BlockStore"- "New best block event received but no peers available"- Just p -> syncMe p-processBlockStoreMessage (BlockPeerConnect p _) = syncMe p-processBlockStoreMessage (BlockPeerDisconnect p _sa) = processDisconnect p-processBlockStoreMessage (BlockReceived p b) = processBlock p b-processBlockStoreMessage (BlockNotFound p bs) = processNoBlocks p bs-processBlockStoreMessage (BlockTxReceived p tx) = processTx p tx-processBlockStoreMessage (BlockTxAvailable p ts) = processTxs p ts-processBlockStoreMessage (BlockPing r) = do- processOrphans- checkTime- pruneMempool- atomically (r ())--pingMe :: MonadLoggerIO m => BlockStore -> m ()-pingMe mbox =- forever $ do- threadDelay =<< liftIO (randomRIO (5 * 1000 * 1000, 10 * 1000 * 1000))- BlockPing `query` mbox
− src/Network/Haskoin/Store/CacheWriter.hs
@@ -1,568 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TupleSections #-}-module Network.Haskoin.Store.CacheWriter where--import Control.Monad (forM, forM_, forever,- void, when)-import Control.Monad.Logger (MonadLoggerIO,- logErrorS, logInfoS,- logWarnS)-import Control.Monad.Reader (ReaderT (..), asks)-import Control.Monad.Trans (lift)-import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)-import Data.ByteString (ByteString)-import qualified Data.IntMap.Strict as IntMap-import Data.List (nub, (\\))-import qualified Data.Map.Strict as Map-import Data.Maybe (catMaybes, mapMaybe)-import Data.Serialize (decode, encode)-import Data.String.Conversions (cs)-import Database.Redis (RedisCtx, hmset,- runRedis, zadd, zrem)-import qualified Database.Redis as Redis-import Haskoin (Address, BlockHash,- BlockHeader (..),- BlockNode (..),- DerivPathI (..),- KeyIndex, Network,- OutPoint (..), Tx (..),- TxHash, TxIn (..),- TxOut (..),- blockHashToHex,- derivePubPath,- eitherToMaybe,- headerHash, pathToList,- scriptToAddressBS,- txHash, txHashToHex)-import Haskoin.Node (Chain,- chainGetAncestor,- chainGetBlock,- chainGetSplitBlock)-import Network.Haskoin.Store.Common (Balance (..),- BlockData (..),- BlockRef (..),- BlockTx (..),- CacheWriterMessage (..),- Prev (..),- StoreRead (..),- TxData (..),- Unspent (..),- XPubBal (..),- XPubSpec (..),- XPubUnspent (..),- nullBalance, sortTxs,- xPubAddrFunction,- xPubBals, xPubTxs,- xPubUnspents)-import Network.Haskoin.Store.Data.CacheReader (AddressXPub (..),- CacheError (..),- CacheReaderConfig (..),- CacheReaderT, addrPfx,- balancesPfx,- blockRefScore,- cacheGetXPubBalances,- getFromSortedSet,- redisGetAddrInfo,- scoreBlockRef,- txSetPfx, utxoPfx,- withCacheReader)-import NQE (Inbox, receive)-import UnliftIO (MonadIO, MonadUnliftIO,- liftIO, throwIO)-type CacheWriterInbox = Inbox CacheWriterMessage--data CacheWriterConfig =- CacheWriterConfig- { cacheWriterReader :: !CacheReaderConfig- , cacheWriterChain :: !Chain- , cacheWriterMailbox :: !CacheWriterInbox- , cacheWriterNetwork :: !Network- , cacheWriterMin :: !Int- }--type CacheWriterT = ReaderT CacheWriterConfig--instance (MonadLoggerIO m, StoreRead m) => StoreRead (CacheWriterT m) where- getBestBlock = lift getBestBlock- getBlocksAtHeight = lift . getBlocksAtHeight- getBlock = lift . getBlock- getTxData = lift . getTxData- getOrphanTx = lift . getOrphanTx- getOrphans = lift getOrphans- getSpenders = lift . getSpenders- getSpender = lift . getSpender- getBalance = lift . getBalance- getBalances = lift . getBalances- getAddressesTxs addrs start = lift . getAddressesTxs addrs start- getAddressTxs addr start = lift . getAddressTxs addr start- getUnspent = lift . getUnspent- getAddressUnspents addr start = lift . getAddressUnspents addr start- getAddressesUnspents addrs start = lift . getAddressesUnspents addrs start- getMempool = lift getMempool- xPubBals = runCacheReaderT . xPubBals- xPubSummary = runCacheReaderT . xPubSummary- xPubUnspents xpub start offset limit =- runCacheReaderT (xPubUnspents xpub start offset limit)- xPubTxs xpub start offset limit =- runCacheReaderT (xPubTxs xpub start offset limit)- getMaxGap = asks (cacheReaderGap . cacheWriterReader)---- Ordered set of transaction ids in mempool-mempoolSetKey :: ByteString-mempoolSetKey = "mempool"---- Best block indexed-bestBlockKey :: ByteString-bestBlockKey = "head"--runCacheReaderT :: StoreRead m => CacheReaderT m a -> CacheWriterT m a-runCacheReaderT f =- ReaderT (\CacheWriterConfig {cacheWriterReader = r} -> withCacheReader r f)--cacheWriter ::- (MonadUnliftIO m, MonadLoggerIO m, StoreRead m)- => CacheWriterConfig- -> m ()-cacheWriter cfg@CacheWriterConfig {cacheWriterMailbox = inbox} =- runReaderT (newBlockC >> forever (receive inbox >>= cacheWriterReact)) cfg--cacheWriterReact ::- (MonadUnliftIO m, MonadLoggerIO m, StoreRead m)- => CacheWriterMessage- -> CacheWriterT m ()-cacheWriterReact CacheNewBlock = newBlockC-cacheWriterReact (CacheXPub xpub) = newXPubC xpub-cacheWriterReact (CacheNewTx txh) = newTxC txh-cacheWriterReact (CacheDelTx txh) = newTxC txh--newXPubC ::- (MonadLoggerIO m, MonadUnliftIO m, StoreRead m)- => XPubSpec- -> CacheWriterT m ()-newXPubC xpub = do- empty <- null <$> runCacheReaderT (cacheGetXPubBalances xpub)- x <- asks cacheWriterMin- when empty $ do- bals <- lift $ xPubBals xpub- let l = length $ filter (not . nullBalance . xPubBal) bals- when (x <= l) (go bals)- where- go bals = do- utxo <- lift $ xPubUnspents xpub Nothing 0 Nothing- xtxs <- lift $ xPubTxs xpub Nothing 0 Nothing- cacheAddXPubBalances xpub bals- cacheAddXPubUnspents- xpub- (map ((\u -> (unspentPoint u, unspentBlock u)) . xPubUnspent) utxo)- cacheAddXPubTxs xpub xtxs--newBlockC :: (MonadLoggerIO m, StoreRead m) => CacheWriterT m ()-newBlockC =- lift getBestBlock >>= \case- Nothing -> $(logErrorS) "Cache" "Best block not set yet"- Just newhead -> do- cacheGetHead >>= \case- Nothing -> do- $(logInfoS) "Cache" "Cache has no best block set"- importBlockC newhead- Just cachehead -> go newhead cachehead- where- go newhead cachehead- | cachehead == newhead = return ()- | otherwise = do- ch <- asks cacheWriterChain- chainGetBlock newhead ch >>= \case- Nothing -> do- $(logErrorS) "Cache" $- "No header for new head: " <> blockHashToHex newhead- throwIO . LogicError . cs $- "No header for new head: " <> blockHashToHex newhead- Just newheadnode ->- chainGetBlock cachehead ch >>= \case- Nothing -> do- $(logErrorS) "Cache" $- "No header for cache head: " <>- blockHashToHex cachehead- Just cacheheadnode -> go2 newheadnode cacheheadnode- go2 newheadnode cacheheadnode- | nodeHeight cacheheadnode > nodeHeight newheadnode = do- $(logErrorS) "Cache" $- "Cache head is above new best block: " <>- blockHashToHex (headerHash (nodeHeader newheadnode))- | otherwise = do- ch <- asks cacheWriterChain- split <- chainGetSplitBlock cacheheadnode newheadnode ch- if split == cacheheadnode- then if prevBlock (nodeHeader newheadnode) ==- headerHash (nodeHeader cacheheadnode)- then importBlockC (headerHash (nodeHeader newheadnode))- else go3 newheadnode cacheheadnode- else removeHeadC >> newBlockC- go3 newheadnode cacheheadnode = do- ch <- asks cacheWriterChain- chainGetAncestor (nodeHeight cacheheadnode + 1) newheadnode ch >>= \case- Nothing -> do- $(logErrorS) "Cache" $- "Could not get expected ancestor block at height " <>- cs (show (nodeHeight cacheheadnode + 1)) <>- " for: " <>- blockHashToHex (headerHash (nodeHeader newheadnode))- throwIO $ LogicError "Could not get expected ancestor block"- Just a -> do- importBlockC (headerHash (nodeHeader a))- newBlockC--newTxC :: (MonadLoggerIO m, StoreRead m) => TxHash -> CacheWriterT m ()-newTxC th =- lift (getTxData th) >>= \case- Just txd -> importTxC txd- Nothing ->- $(logErrorS) "Cache" $ "Transaction not found: " <> txHashToHex th-------------------- Importing --------------------importBlockC :: (StoreRead m, MonadLoggerIO m) => BlockHash -> CacheWriterT m ()-importBlockC bh =- lift (getBlock bh) >>= \case- Nothing -> do- $(logErrorS) "Cache" $ "Could not get block: " <> blockHashToHex bh- throwIO . LogicError . cs $- "Could not get block: " <> blockHashToHex bh- Just bd -> do- $(logInfoS) "Cache" $ "Importing block: " <> blockHashToHex bh- go bd- where- go bd = do- let ths = blockDataTxs bd- tds <- sortTxData . catMaybes <$> mapM (lift . getTxData) ths- forM_ tds importTxC- cacheSetHead bh--removeHeadC :: (StoreRead m, MonadLoggerIO m) => CacheWriterT m ()-removeHeadC =- void . runMaybeT $ do- bh <- MaybeT cacheGetHead- bd <- MaybeT (lift (getBlock bh))- lift $ do- tds <-- sortTxData . catMaybes <$>- mapM (lift . getTxData) (blockDataTxs bd)- $(logWarnS) "Cache" $ "Reverting head: " <> blockHashToHex bh- forM_ (reverse (map (txHash . txData) tds)) newTxC- cacheSetHead (prevBlock (blockDataHeader bd))- syncMempoolC--importTxC :: (StoreRead m, MonadLoggerIO m) => TxData -> CacheWriterT m ()-importTxC txd = do- updateAddressesC addrs- is <- mapM cacheGetAddrInfo addrs- let aim = Map.fromList (catMaybes (zipWith (\a i -> (a, ) <$> i) addrs is))- dus = mapMaybe (\(a, p) -> (, p) <$> Map.lookup a aim) spnts- ius = mapMaybe (\(a, p) -> (, p) <$> Map.lookup a aim) utxos- if txDataDeleted txd- then do- forM_ aim $ \i ->- cacheRemXPubTxs (addressXPubSpec i) [txHash (txData txd)]- case txDataBlock txd of- b@MemRef {} ->- cacheAddToMempool- BlockTx- { blockTxHash = txHash (txData txd)- , blockTxBlock = b- }- _ -> cacheRemFromMempool (txHash (txData txd))- else do- forM_ aim $ \i ->- cacheAddXPubTxs- (addressXPubSpec i)- [ BlockTx- { blockTxHash = txHash (txData txd)- , blockTxBlock = txDataBlock txd- }- ]- cacheRemFromMempool (txHash (txData txd))- forM_ (dus <> ius) $ \(i, p) -> do- lift (getUnspent p) >>= \case- Nothing -> cacheRemXPubUnspents (addressXPubSpec i) [p]- Just u ->- cacheAddXPubUnspents (addressXPubSpec i) [(p, unspentBlock u)]- where- spnts = txInputs txd- utxos = txOutputs txd- addrs = nub (map fst spnts <> map fst utxos)--updateAddressesC ::- (StoreRead m, MonadLoggerIO m) => [Address] -> CacheWriterT m ()-updateAddressesC as = do- is <- mapM cacheGetAddrInfo as- let ais = catMaybes (zipWith (\a i -> (a, ) <$> i) as is)- forM_ ais $ \(a, i) -> do- updateBalanceC a i- updateAddressGapC i- let as' = as \\ map fst ais- when (length as /= length as') (updateAddressesC as')--updateAddressGapC ::- (StoreRead m, MonadLoggerIO m)- => AddressXPub- -> CacheWriterT m ()-updateAddressGapC i = do- bals <- runCacheReaderT (cacheGetXPubBalances (addressXPubSpec i))- gap <- getMaxGap- let ns = addrsToAddC gap i bals- mapM_ (uncurry updateBalanceC) ns--updateBalanceC ::- (StoreRead m, MonadLoggerIO m)- => Address- -> AddressXPub- -> CacheWriterT m ()-updateBalanceC a i = do- b <- lift (getBalance a)- cacheAddXPubBalances- (addressXPubSpec i)- [XPubBal {xPubBalPath = addressXPubPath i, xPubBal = b}]--syncMempoolC :: (MonadLoggerIO m, StoreRead m) => CacheWriterT m ()-syncMempoolC = do- nodepool <- map blockTxHash <$> lift getMempool- cachepool <- map blockTxHash <$> cacheGetMempool- let deltxs = cachepool \\ nodepool- deltds <- reverse . sortTxData . catMaybes <$> mapM (lift . getTxData) deltxs- forM_ deltds importTxC- let addtxs = nodepool \\ cachepool- addtds <- sortTxData . catMaybes <$> mapM (lift . getTxData) addtxs- forM_ addtds importTxC--cacheAddXPubTxs :: MonadIO m => XPubSpec -> [BlockTx] -> CacheWriterT m ()-cacheAddXPubTxs xpub txs = do- conn <- asks (cacheReaderConn . cacheWriterReader)- liftIO (runRedis conn (redisAddXPubTxs xpub txs)) >>= \case- Left e -> throwIO (RedisError e)- Right () -> return ()--cacheRemXPubTxs :: MonadIO m => XPubSpec -> [TxHash] -> CacheWriterT m ()-cacheRemXPubTxs xpub ths = do- conn <- asks (cacheReaderConn . cacheWriterReader)- liftIO (runRedis conn (redisRemXPubTxs xpub ths)) >>= \case- Left e -> throwIO (RedisError e)- Right () -> return ()--cacheAddXPubUnspents ::- MonadIO m => XPubSpec -> [(OutPoint, BlockRef)] -> CacheWriterT m ()-cacheAddXPubUnspents xpub ops = do- conn <- asks (cacheReaderConn . cacheWriterReader)- liftIO (runRedis conn (redisAddXPubUnspents xpub ops)) >>= \case- Left e -> throwIO (RedisError e)- Right () -> return ()--cacheRemXPubUnspents :: MonadIO m => XPubSpec -> [OutPoint] -> CacheWriterT m ()-cacheRemXPubUnspents xpub ops = do- conn <- asks (cacheReaderConn . cacheWriterReader)- liftIO (runRedis conn (redisRemXPubUnspents xpub ops)) >>= \case- Left e -> throwIO (RedisError e)- Right () -> return ()--cacheAddXPubBalances :: MonadIO m => XPubSpec -> [XPubBal] -> CacheWriterT m ()-cacheAddXPubBalances xpub bals = do- conn <- asks (cacheReaderConn . cacheWriterReader)- liftIO (runRedis conn (redisAddXPubBalances xpub bals)) >>= \case- Left e -> throwIO (RedisError e)- Right () -> return ()--cacheGetMempool :: MonadIO m => CacheWriterT m [BlockTx]-cacheGetMempool = do- conn <- asks (cacheReaderConn . cacheWriterReader)- liftIO (runRedis conn redisGetMempool) >>= \case- Left e -> do- throwIO (RedisError e)- Right mem -> return mem--cacheGetHead :: MonadIO m => CacheWriterT m (Maybe BlockHash)-cacheGetHead = do- conn <- asks (cacheReaderConn . cacheWriterReader)- liftIO (runRedis conn redisGetHead) >>= \case- Left e ->- throwIO (RedisError e)- Right h -> return h--cacheSetHead :: MonadIO m => BlockHash -> CacheWriterT m ()-cacheSetHead bh = do- conn <- asks (cacheReaderConn . cacheWriterReader)- liftIO (runRedis conn (redisSetHead bh)) >>= \case- Left e -> throwIO (RedisError e)- Right () -> return ()--cacheAddToMempool :: MonadIO m => BlockTx -> CacheWriterT m ()-cacheAddToMempool btx = do- conn <- asks (cacheReaderConn . cacheWriterReader)- liftIO (runRedis conn (redisAddToMempool btx)) >>= \case- Left e -> throwIO (RedisError e)- Right () -> return ()--cacheRemFromMempool :: MonadIO m => TxHash -> CacheWriterT m ()-cacheRemFromMempool th = do- conn <- asks (cacheReaderConn . cacheWriterReader)- liftIO (runRedis conn (redisRemFromMempool th)) >>= \case- Left e -> throwIO (RedisError e)- Right () -> return ()--cacheGetAddrInfo :: MonadIO m => Address -> CacheWriterT m (Maybe AddressXPub)-cacheGetAddrInfo a = do- conn <- asks (cacheReaderConn . cacheWriterReader)- liftIO (runRedis conn (redisGetAddrInfo a)) >>= \case- Left e -> throwIO (RedisError e)- Right i -> return i--redisAddToMempool :: (Monad m, Monad f, RedisCtx m f) => BlockTx -> m (f ())-redisAddToMempool btx = do- f <-- zadd- mempoolSetKey- [(blockRefScore (blockTxBlock btx), encode (blockTxHash btx))]- return $ f >> return ()--redisRemFromMempool :: (Monad m, Monad f, RedisCtx m f) => TxHash -> m (f ())-redisRemFromMempool th = do- f <- zrem mempoolSetKey [encode th]- return $ f >> return ()--redisSetAddrInfo ::- (Monad f, RedisCtx m f) => Address -> AddressXPub -> m (f ())-redisSetAddrInfo a i = do- f <- Redis.set (addrPfx <> encode a) (encode i)- return $ f >> return ()--redisAddXPubTxs :: (Monad f, RedisCtx m f) => XPubSpec -> [BlockTx] -> m (f ())-redisAddXPubTxs xpub btxs = do- let entries =- map- (\t -> (blockRefScore (blockTxBlock t), encode (blockTxHash t)))- btxs- if null entries- then return (return ())- else do- f <- zadd (txSetPfx <> encode xpub) entries- return $ f >> return ()--redisRemXPubTxs :: (Monad f, RedisCtx m f) => XPubSpec -> [TxHash] -> m (f ())-redisRemXPubTxs xpub txhs = do- f <- zrem (txSetPfx <> encode xpub) (map encode txhs)- return $ f >> return ()--redisAddXPubUnspents ::- (Monad f, RedisCtx m f) => XPubSpec -> [(OutPoint, BlockRef)] -> m (f ())-redisAddXPubUnspents xpub utxo = do- let entries = map (\(p, r) -> (blockRefScore r, encode p)) utxo- if null entries- then return (return ())- else do- f <- zadd (utxoPfx <> encode xpub) entries- return $ f >> return ()--redisRemXPubUnspents ::- (Monad f, RedisCtx m f) => XPubSpec -> [OutPoint] -> m (f ())-redisRemXPubUnspents xpub ops = do- f <- zrem (utxoPfx <> encode xpub) (map encode ops)- return $ f >> return ()--redisAddXPubBalances ::- (Monad f, RedisCtx m f) => XPubSpec -> [XPubBal] -> m (f ())-redisAddXPubBalances xpub bals = do- let entries =- map (\b -> (encode (xPubBalPath b), encode (xPubBal b))) bals- if null entries- then return (return ())- else do- f <- hmset (balancesPfx <> encode xpub) entries- gs <-- forM bals $ \b ->- redisSetAddrInfo- (balanceAddress (xPubBal b))- AddressXPub- { addressXPubSpec = xpub- , addressXPubPath = xPubBalPath b- }- return $ f >> sequence gs >> return ()--redisSetHead :: (Monad m, Monad f, RedisCtx m f) => BlockHash -> m (f ())-redisSetHead bh = do- f <- Redis.set bestBlockKey (encode bh)- return $ f >> return ()--addrsToAddC ::- KeyIndex- -> AddressXPub- -> [XPubBal]- -> [(Address, AddressXPub)]-addrsToAddC gap i bals =- let headi = head (addressXPubPath i)- maxi =- maximum $- map (head . tail . xPubBalPath) $- filter ((== headi) . head . xPubBalPath) bals- xpub = addressXPubSpec i- newi = head (tail (addressXPubPath i))- genixs =- if maxi - newi < gap- then [maxi + 1 .. newi + gap]- else []- paths = map (Deriv :/ headi :/) genixs- keys = map (\p -> derivePubPath p (xPubSpecKey xpub)) paths- list = map pathToList paths- xpubf = xPubAddrFunction (xPubDeriveType xpub)- addrs = map xpubf keys- in zipWith- (\a p ->- (a, AddressXPub {addressXPubSpec = xpub, addressXPubPath = p}))- addrs- list--sortTxData :: [TxData] -> [TxData]-sortTxData tds =- let txm = Map.fromList (map (\d -> (txHash (txData d), d)) tds)- ths = map (txHash . snd) (sortTxs (map txData tds))- in mapMaybe (\h -> Map.lookup h txm) ths--txInputs :: TxData -> [(Address, OutPoint)]-txInputs td =- let is = txIn (txData td)- ps = IntMap.toAscList (txDataPrevs td)- as = map (scriptToAddressBS . prevScript . snd) ps- f (Right a) i = Just (a, prevOutput i)- f (Left _) _ = Nothing- in catMaybes (zipWith f as is)--txOutputs :: TxData -> [(Address, OutPoint)]-txOutputs td =- let ps =- zipWith- (\i _ ->- OutPoint- {outPointHash = txHash (txData td), outPointIndex = i})- [0 ..]- (txOut (txData td))- as = map (scriptToAddressBS . scriptOutput) (txOut (txData td))- f (Right a) p = Just (a, p)- f (Left _) _ = Nothing- in catMaybes (zipWith f as ps)--redisGetHead :: (Monad m, Monad f, RedisCtx m f) => m (f (Maybe BlockHash))-redisGetHead = do- f <- Redis.get bestBlockKey- return $ (eitherToMaybe . decode =<<) <$> f--redisGetMempool :: (Monad m, Monad f, RedisCtx m f) => m (f [BlockTx])-redisGetMempool = do- f <- getFromSortedSet mempoolSetKey Nothing 0 Nothing- return $ do- bts <- f- return- (map (\(t, s) ->- BlockTx {blockTxBlock = scoreBlockRef s, blockTxHash = t})- bts)
− src/Network/Haskoin/Store/Common.hs
@@ -1,1472 +0,0 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-module Network.Haskoin.Store.Common where--import Conduit (ConduitT, dropC, mapC, takeC)-import Control.Applicative ((<|>))-import Control.DeepSeq (NFData)-import Control.Exception (Exception)-import Control.Monad (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.Function (on)-import Data.Hashable (Hashable)-import qualified Data.IntMap as I-import Data.IntMap.Strict (IntMap)-import Data.List (nub, partition, sortBy)-import Data.Maybe (catMaybes, isJust, listToMaybe,- mapMaybe)-import Data.Serialize (Get, Put, Putter, Serialize (..),- getListOf, getShortByteString,- getWord32be, getWord64be, getWord8,- putListOf, putShortByteString,- putWord32be, putWord64be, putWord8)-import qualified Data.Serialize as S-import Data.String.Conversions (cs)-import qualified Data.Text.Encoding as T-import Data.Word (Word32, Word64)-import GHC.Generics (Generic)-import Haskoin (Address, Block, BlockHash,- BlockHeader (..), BlockHeight,- BlockNode, BlockWork, HostAddress,- KeyIndex, Network (..),- NetworkAddress (..), OutPoint (..),- PubKeyI (..), RejectCode (..),- Tx (..), TxHash (..), TxIn (..),- TxOut (..), WitnessStack,- XPubKey (..), addrToJSON,- addrToString, deriveAddr,- deriveCompatWitnessAddr,- deriveWitnessAddr, eitherToMaybe,- encodeHex, headerHash,- hostToSockAddr, pubSubKey,- scriptToAddressBS, stringToAddr,- txHash, wrapPubKey, xPubAddr,- xPubCompatWitnessAddr,- xPubWitnessAddr)-import Haskoin.Node (Chain, Manager, Peer)-import Network.Socket (SockAddr)-import NQE (Listen, Mailbox, send)-import qualified Paths_haskoin_store as P-import UnliftIO (MonadIO)--data DeriveType- = DeriveNormal- | DeriveP2SH- | DeriveP2WPKH- deriving (Show, Eq, Generic, NFData, Serialize)---- | Messages for block store actor.-data BlockStoreMessage- = 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---- | Mailbox for block store.-type BlockStore = Mailbox BlockStoreMessage---- | Store mailboxes.-data Store =- Store- { storeManager :: !Manager- -- ^ peer manager mailbox- , storeChain :: !Chain- -- ^ chain header process mailbox- , storeBlock :: !BlockStore- -- ^ block storage mailbox- }--data XPubSpec =- XPubSpec- { xPubSpecKey :: !XPubKey- , xPubDeriveType :: !DeriveType- } deriving (Show, Eq, Generic, NFData)--instance Serialize XPubSpec where- put XPubSpec {xPubSpecKey = k, xPubDeriveType = t} = do- put (xPubDepth k)- put (xPubParent k)- put (xPubIndex k)- put (xPubChain k)- put (wrapPubKey True (xPubKey k))- put t- get = do- d <- get- p <- get- i <- get- c <- get- k <- get- t <- get- let x =- XPubKey- { xPubDepth = d- , xPubParent = p- , xPubIndex = i- , xPubChain = c- , xPubKey = pubKeyPoint k- }- return XPubSpec {xPubSpecKey = x, xPubDeriveType = t}--type DeriveAddr = XPubKey -> KeyIndex -> Address--type UnixTime = Word64-type BlockPos = Word32--type Offset = Word32-type Limit = Word32--data CacheWriterMessage- = CacheXPub !XPubSpec- | CacheNewTx !TxHash- | CacheDelTx !TxHash- | CacheNewBlock- deriving (Show, Eq, Generic, NFData)--type CacheWriter = Mailbox CacheWriterMessage--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))- getOrphans :: m [(UnixTime, Tx)]- getSpenders :: TxHash -> m (IntMap Spender)- getSpender :: OutPoint -> m (Maybe Spender)- getBalance :: Address -> m Balance- getBalance a = head <$> getBalances [a]- getBalances :: [Address] -> m [Balance]- getBalances as = mapM getBalance as- getAddressesTxs :: [Address] -> Maybe BlockRef -> Maybe Limit -> m [BlockTx]- getAddressTxs :: Address -> Maybe BlockRef -> Maybe Limit -> m [BlockTx]- getAddressTxs a = getAddressesTxs [a]- getUnspent :: OutPoint -> m (Maybe Unspent)- getAddressUnspents ::- Address -> Maybe BlockRef -> Maybe Limit -> m [Unspent]- getAddressUnspents a = getAddressesUnspents [a]- getAddressesUnspents ::- [Address] -> Maybe BlockRef -> Maybe Limit -> m [Unspent]- getMempool :: m [BlockTx]- xPubBals :: XPubSpec -> m [XPubBal]- xPubBals xpub = do- gap <- getMaxGap- ext <-- derive_until_gap- gap- 0- (deriveAddresses- (deriveFunction (xPubDeriveType xpub))- (pubSubKey (xPubSpecKey xpub) 0)- 0)- chg <-- derive_until_gap- gap- 1- (deriveAddresses- (deriveFunction (xPubDeriveType xpub))- (pubSubKey (xPubSpecKey xpub) 1)- 0)- return (ext ++ chg)- where- xbalance m b n = XPubBal {xPubBalPath = [m, n], xPubBal = b}- derive_until_gap _ _ [] = return []- derive_until_gap gap m as = do- let (as1, as2) = splitAt (fromIntegral gap) as- bs <- getBalances (map snd as1)- let xbs = zipWith (xbalance m) bs (map fst as1)- if all nullBalance bs- then return xbs- else (xbs <>) <$> derive_until_gap gap m as2- xPubSummary :: XPubSpec -> m XPubSummary- xPubSummary xpub = do- bs <- filter (not . nullBalance . xPubBal) <$> xPubBals xpub- let ex = foldl max 0 [i | XPubBal {xPubBalPath = [0, i]} <- bs]- ch = foldl max 0 [i | XPubBal {xPubBalPath = [1, i]} <- bs]- uc =- sum- [ c- | XPubBal {xPubBal = Balance {balanceUnspentCount = c}} <-- bs- ]- xt = [b | b@XPubBal {xPubBalPath = [0, _]} <- bs]- rx =- sum- [ r- | XPubBal {xPubBal = Balance {balanceTotalReceived = r}} <-- xt- ]- return- XPubSummary- { xPubSummaryConfirmed = sum (map (balanceAmount . xPubBal) bs)- , xPubSummaryZero = sum (map (balanceZero . xPubBal) bs)- , xPubSummaryReceived = rx- , xPubUnspentCount = uc- , xPubChangeIndex = ch- , xPubExternalIndex = ex- }- xPubUnspents ::- XPubSpec- -> Maybe BlockRef- -> Offset- -> Maybe Limit- -> m [XPubUnspent]- xPubUnspents xpub start offset limit = do- xs <- filter positive <$> xPubBals xpub- applyOffsetLimit offset limit <$> go xs- where- positive XPubBal {xPubBal = Balance {balanceUnspentCount = c}} = c > 0- go [] = return []- go (XPubBal {xPubBalPath = p, xPubBal = Balance {balanceAddress = a}}:xs) = do- uns <- getAddressUnspents a start limit- let xuns =- map- (\t ->- XPubUnspent {xPubUnspentPath = p, xPubUnspent = t})- uns- (xuns <>) <$> go xs- xPubTxs ::- XPubSpec -> Maybe BlockRef -> Offset -> Maybe Limit -> m [BlockTx]- xPubTxs xpub start offset limit = do- bs <- xPubBals xpub- let as = map (balanceAddress . xPubBal) bs- ts <- concat <$> mapM (\a -> getAddressTxs a start limit) as- let ts' = nub $ sortBy (flip compare `on` blockTxBlock) ts- return $ applyOffsetLimit offset limit ts'- getMaxGap :: m Word32- getMaxGap = return 32--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 :: [BlockTx] -> m ()- insertOrphanTx :: Tx -> UnixTime -> m ()- deleteOrphanTx :: TxHash -> m ()- setBalance :: Balance -> m ()- insertUnspent :: Unspent -> m ()- deleteUnspent :: OutPoint -> m ()--deriveAddresses :: DeriveAddr -> XPubKey -> Word32 -> [(Word32, Address)]-deriveAddresses derive xpub start = map (\i -> (i, derive xpub i)) [start ..]--deriveFunction :: DeriveType -> DeriveAddr-deriveFunction DeriveNormal i = fst . deriveAddr i-deriveFunction DeriveP2SH i = fst . deriveCompatWitnessAddr i-deriveFunction DeriveP2WPKH i = fst . deriveWitnessAddr i--xPubAddrFunction :: DeriveType -> XPubKey -> Address-xPubAddrFunction DeriveNormal = xPubAddr-xPubAddrFunction DeriveP2SH = xPubCompatWitnessAddr-xPubAddrFunction DeriveP2WPKH = xPubWitnessAddr--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--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- }--nullBalance :: Balance -> Bool-nullBalance Balance { balanceAmount = 0- , balanceUnspentCount = 0- , balanceZero = 0- , balanceTxCount = 0- , balanceTotalReceived = 0- } = True-nullBalance _ = False---- | 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, Ord, 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, Serialize, 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- }- deriving (Eq, Show, Generic, Serialize, NFData)--xPubSummaryPairs :: A.KeyValue kv => XPubSummary -> [kv]-xPubSummaryPairs XPubSummary { xPubSummaryConfirmed = c- , xPubSummaryZero = z- , xPubSummaryReceived = r- , xPubUnspentCount = u- , xPubExternalIndex = ext- , xPubChangeIndex = ch- } =- [ "balance" .=- object- ["confirmed" .= c, "unconfirmed" .= z, "received" .= r, "utxo" .= u]- , "indices" .= object ["change" .= ch, "external" .= ext]- ]--xPubSummaryToJSON :: XPubSummary -> Value-xPubSummaryToJSON = object . xPubSummaryPairs--xPubSummaryToEncoding :: XPubSummary -> Encoding-xPubSummaryToEncoding = pairs . mconcat . xPubSummaryPairs--instance ToJSON XPubSummary where- toJSON = xPubSummaryToJSON- toEncoding = xPubSummaryToEncoding--instance JsonSerial XPubSummary where- jsonSerial _ = xPubSummaryToEncoding- jsonValue _ = xPubSummaryToJSON--instance BinSerial XPubSummary where- binSerial _ = put- binDeserial _ = get--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- }---- | 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 :: Offset -> Maybe Limit -> [a] -> [a]-applyOffsetLimit offset limit = applyLimit limit . applyOffset offset--applyOffset :: Offset -> [a] -> [a]-applyOffset = drop . fromIntegral--applyLimit :: Maybe Limit -> [a] -> [a]-applyLimit Nothing = id-applyLimit (Just l) = take (fromIntegral l)--applyOffsetLimitC :: Monad m => Offset -> Maybe Limit -> ConduitT i i m ()-applyOffsetLimitC offset limit = applyOffsetC offset >> applyLimitC limit--applyOffsetC :: Monad m => Offset -> ConduitT i i m ()-applyOffsetC = dropC . fromIntegral--applyLimitC :: Monad m => Maybe Limit -> ConduitT i i m ()-applyLimitC Nothing = mapC id-applyLimitC (Just l) = takeC (fromIntegral l)--sortTxs :: [Tx] -> [(Word32, Tx)]-sortTxs txs = go $ zip [0 ..] txs- where- go [] = []- go ts =- let (is, ds) =- partition- (all ((`notElem` map (txHash . snd) ts) .- outPointHash . prevOutput) .- txIn . snd)- ts- in is <> go ds--cacheXPub :: MonadIO m => CacheWriter -> XPubSpec -> m ()-cacheXPub cache xpub = CacheXPub xpub `send` cache--cacheNewTx :: MonadIO m => CacheWriter -> TxHash -> m ()-cacheNewTx cache tx = CacheNewTx tx `send` cache--cacheDelTx :: MonadIO m => CacheWriter -> TxHash -> m ()-cacheDelTx cache tx = CacheDelTx tx `send` cache--cacheNewBlock :: MonadIO m => CacheWriter -> m ()-cacheNewBlock = send CacheNewBlock
− src/Network/Haskoin/Store/Data/CacheReader.hs
@@ -1,331 +0,0 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeSynonymInstances #-}-module Network.Haskoin.Store.Data.CacheReader where--import Control.DeepSeq (NFData)-import Control.Monad.Logger (MonadLoggerIO)-import Control.Monad.Reader (ReaderT (..), asks)-import Control.Monad.Trans (lift)-import Data.Bits (shift, (.&.), (.|.))-import Data.ByteString (ByteString)-import qualified Data.ByteString.Short as BSS-import Data.Either (rights)-import Data.List (sort)-import qualified Data.Map.Strict as Map-import Data.Maybe (catMaybes, mapMaybe)-import Data.Serialize (Serialize, decode, encode)-import Data.Word (Word32, Word64)-import Database.Redis (Connection, RedisCtx, Reply,- hgetall, runRedis,- zrangeWithscores,- zrangebyscoreWithscoresLimit)-import qualified Database.Redis as Redis-import GHC.Generics (Generic)-import Haskoin (Address, KeyIndex, OutPoint (..),- scriptToAddressBS)-import Network.Haskoin.Store.Common (Balance (..), BlockRef (..),- BlockTx (..), CacheWriter, Limit,- Offset, StoreRead (..),- Unspent (..), XPubBal (..),- XPubSpec (..), XPubUnspent (..),- cacheXPub)-import UnliftIO (Exception, MonadIO, liftIO,- throwIO)--data CacheReaderConfig =- CacheReaderConfig- { cacheReaderConn :: !Connection- , cacheReaderWriter :: !CacheWriter- , cacheReaderGap :: !Word32- }---data AddressXPub =- AddressXPub- { addressXPubSpec :: !XPubSpec- , addressXPubPath :: ![KeyIndex]- } deriving (Show, Eq, Generic, NFData, Serialize)--type CacheReaderT = ReaderT CacheReaderConfig--data CacheError- = RedisError Reply- | LogicError String- deriving (Show, Eq, Generic, NFData, Exception)--instance (MonadLoggerIO m, StoreRead m) => StoreRead (CacheReaderT m) where- getBestBlock = lift getBestBlock- getBlocksAtHeight = lift . getBlocksAtHeight- getBlock = lift . getBlock- getTxData = lift . getTxData- getOrphanTx = lift . getOrphanTx- getOrphans = lift getOrphans- getSpenders = lift . getSpenders- getSpender = lift . getSpender- getBalance = lift . getBalance- getBalances = lift . getBalances- getAddressesTxs addrs start = lift . getAddressesTxs addrs start- getAddressTxs addr start = lift . getAddressTxs addr start- getUnspent = lift . getUnspent- getAddressUnspents addr start = lift . getAddressUnspents addr start- getAddressesUnspents addrs start = lift . getAddressesUnspents addrs start- getMempool = lift getMempool- xPubBals = getXPubBalances- xPubUnspents = getXPubUnspents- xPubTxs = getXPubTxs- getMaxGap = asks cacheReaderGap--withCacheReader :: StoreRead m => CacheReaderConfig -> CacheReaderT m a -> m a-withCacheReader s f = runReaderT f s---- Ordered set of balances for an extended public key-balancesPfx :: ByteString-balancesPfx = "b"---- Ordered set of transactions for an extended public key-txSetPfx :: ByteString-txSetPfx = "t"---- Ordered set of unspent outputs for an extended pulic key-utxoPfx :: ByteString-utxoPfx = "u"---- Extended public key info for an address-addrPfx :: ByteString-addrPfx = "a"--getXPubTxs ::- (MonadIO m, StoreRead m)- => XPubSpec- -> Maybe BlockRef- -> Offset- -> Maybe Limit- -> CacheReaderT m [BlockTx]-getXPubTxs xpub start offset limit = do- cacheGetXPubTxs xpub start offset limit >>= \case- [] -> do- cache <- asks cacheReaderWriter- cacheXPub cache xpub- lift (xPubTxs xpub start offset limit)- txs -> return txs--getXPubUnspents ::- (MonadLoggerIO m, StoreRead m)- => XPubSpec- -> Maybe BlockRef- -> Offset- -> Maybe Limit- -> CacheReaderT m [XPubUnspent]-getXPubUnspents xpub start offset limit =- cacheGetXPubBalances xpub >>= \case- [] -> do- cache <- asks cacheReaderWriter- cacheXPub cache xpub- lift (xPubUnspents xpub start offset limit)- bals -> do- ops <- map snd <$> cacheGetXPubUnspents xpub start offset limit- uns <- catMaybes <$> mapM getUnspent ops- let addrmap =- Map.fromList $- map (\b -> (balanceAddress (xPubBal b), xPubBalPath b)) bals- addrutxo =- mapMaybe- (\u ->- either- (const Nothing)- (\a -> Just (a, u))- (scriptToAddressBS- (BSS.fromShort (unspentScript u))))- uns- xpubutxo =- mapMaybe- (\(a, u) ->- (\p -> XPubUnspent p u) <$> Map.lookup a addrmap)- addrutxo- return xpubutxo--getXPubBalances ::- (MonadIO m, StoreRead m)- => XPubSpec- -> CacheReaderT m [XPubBal]-getXPubBalances xpub = do- cacheGetXPubBalances xpub >>= \case- [] -> do- cache <- asks cacheReaderWriter- cacheXPub cache xpub- lift (xPubBals xpub)- bals -> return bals--cacheGetXPubBalances :: MonadIO m => XPubSpec -> CacheReaderT m [XPubBal]-cacheGetXPubBalances xpub = do- conn <- asks cacheReaderConn- liftIO (runRedis conn (redisGetXPubBalances xpub)) >>= \case- Left e -> throwIO (RedisError e)- Right bals -> return bals--cacheGetXPubTxs ::- MonadIO m- => XPubSpec- -> Maybe BlockRef- -> Offset- -> Maybe Limit- -> CacheReaderT m [BlockTx]-cacheGetXPubTxs xpub start offset limit = do- conn <- asks cacheReaderConn- liftIO (runRedis conn (redisGetXPubTxs xpub start offset limit)) >>= \case- Left e -> throwIO (RedisError e)- Right bts -> return bts--cacheGetXPubUnspents ::- MonadIO m- => XPubSpec- -> Maybe BlockRef- -> Offset- -> Maybe Limit- -> CacheReaderT m [(BlockRef, OutPoint)]-cacheGetXPubUnspents xpub start offset limit = do- conn <- asks cacheReaderConn- liftIO (runRedis conn (redisGetXPubUnspents xpub start offset limit)) >>= \case- Left e -> throwIO (RedisError e)- Right ops -> return ops--redisGetAddrInfo :: (Monad f, RedisCtx m f) => Address -> m (f (Maybe AddressXPub))-redisGetAddrInfo a = do- f <- Redis.get (addrPfx <> encode a)- return $ do- m <- f- case m of- Nothing -> return Nothing- Just x -> case decode x of- Left e -> error e- Right i -> return (Just i)--redisGetXPubBalances :: (Monad f, RedisCtx m f) => XPubSpec -> m (f [XPubBal])-redisGetXPubBalances xpub = do- fxs <- getAllFromMap (balancesPfx <> encode xpub)- return $ do- xs <- fxs- return (sort $ map (uncurry f) xs)- where- f p b = XPubBal {xPubBalPath = p, xPubBal = b}--redisGetXPubTxs ::- (Monad f, RedisCtx m f)- => XPubSpec- -> Maybe BlockRef- -> Offset- -> Maybe Limit- -> m (f [BlockTx])-redisGetXPubTxs xpub start offset limit = do- xs <-- getFromSortedSet- (txSetPfx <> encode xpub)- (blockRefScore <$> start)- (fromIntegral offset)- (fromIntegral <$> limit)- return $ do- xs' <- xs- return (map (uncurry f) xs')- where- f t s = BlockTx {blockTxHash = t, blockTxBlock = scoreBlockRef s}--redisGetXPubUnspents ::- (Monad f, RedisCtx m f)- => XPubSpec- -> Maybe BlockRef- -> Offset- -> Maybe Limit- -> m (f [(BlockRef, OutPoint)])-redisGetXPubUnspents xpub start offset limit = do- xs <-- getFromSortedSet- (utxoPfx <> encode xpub)- (blockRefScore <$> start)- (fromIntegral offset)- (fromIntegral <$> limit)- return $ do- xs' <- xs- return (map (uncurry f) xs')- where- f o s = (scoreBlockRef s, o)--blockRefScore :: BlockRef -> Double-blockRefScore BlockRef {blockRefHeight = h, blockRefPos = p} =- fromIntegral (0x001fffffffffffff - (h' .|. p'))- where- h' = (fromIntegral h .&. 0x07ffffff) `shift` 26 :: Word64- p' = (fromIntegral p .&. 0x03ffffff) :: Word64-blockRefScore MemRef {memRefTime = t} = 0 - t'- where- t' = fromIntegral (t .&. 0x001fffffffffffff)--scoreBlockRef :: Double -> BlockRef-scoreBlockRef s- | s < 0 = MemRef {memRefTime = n}- | otherwise = BlockRef {blockRefHeight = h, blockRefPos = p}- where- n = truncate (abs s) :: Word64- m = 0x001fffffffffffff - n- h = fromIntegral (m `shift` (-26))- p = fromIntegral (m .&. 0x03ffffff)--getFromSortedSet ::- (Monad f, RedisCtx m f, Serialize a)- => ByteString- -> Maybe Double- -> Integer- -> Maybe Integer- -> m (f [(a, Double)])-getFromSortedSet key Nothing offset Nothing = do- xs <- zrangeWithscores key offset (-1)- return $ do- ys <- map (\(x, s) -> (, s) <$> decode x) <$> xs- return (rights ys)-getFromSortedSet key Nothing offset (Just count) = do- xs <- zrangeWithscores key offset (offset + count - 1)- return $ do- ys <- map (\(x, s) -> (, s) <$> decode x) <$> xs- return (rights ys)-getFromSortedSet key (Just score) offset Nothing = do- xs <-- zrangebyscoreWithscoresLimit- key- score- (2 ^ (53 :: Integer) - 1)- offset- (-1)- return $ do- ys <- map (\(x, s) -> (, s) <$> decode x) <$> xs- return (rights ys)-getFromSortedSet key (Just score) offset (Just count) = do- xs <-- zrangebyscoreWithscoresLimit- key- score- (2 ^ (53 :: Integer) - 1)- offset- count- return $ do- ys <- map (\(x, s) -> (, s) <$> decode x) <$> xs- return (rights ys)--getAllFromMap ::- (Monad f, RedisCtx m f, Serialize k, Serialize v)- => ByteString- -> m (f [(k, v)])-getAllFromMap n = do- fxs <- hgetall n- return $ do- xs <- fxs- return- [ (k, v)- | (k', v') <- xs- , let Right k = decode k'- , let Right v = decode v'- ]
− src/Network/Haskoin/Store/Data/DatabaseReader.hs
@@ -1,266 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-}-module Network.Haskoin.Store.Data.DatabaseReader where--import Conduit (ConduitT, MonadResource,- mapC, runConduit,- runResourceT, sinkList, (.|))-import Control.Monad.Except (runExceptT, throwError)-import Control.Monad.Reader (ReaderT, ask, asks,- 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 (Word32)-import Database.RocksDB (Compression (..), DB,- Options (..), ReadOptions,- defaultOptions,- defaultReadOptions, open)-import Database.RocksDB.Query (insert, matching,- matchingAsList, matchingSkip,- retrieve)-import Haskoin (Address, BlockHash,- BlockHeight, OutPoint (..),- Tx, TxHash)-import Network.Haskoin.Store.Common (Balance, BlockData,- BlockRef (..), BlockTx (..),- Limit, Spender,- StoreRead (..), TxData,- UnixTime, Unspent (..),- UnspentVal (..), applyLimit,- applyLimitC, valToBalance,- valToUnspent, zeroBalance)-import Network.Haskoin.Store.Data.Types (AddrOutKey (..),- AddrTxKey (..), BalKey (..),- BestKey (..), BlockKey (..),- HeightKey (..), MemKey (..),- OldMemKey (..),- OrphanKey (..),- SpenderKey (..), TxKey (..),- UnspentKey (..),- VersionKey (..), toUnspent)-import UnliftIO (MonadIO, liftIO)--type DatabaseReaderT = ReaderT DatabaseReader--data DatabaseReader =- DatabaseReader- { databaseHandle :: !DB- , databaseReadOptions :: !ReadOptions- , databaseMaxGap :: !Word32- }--dataVersion :: Word32-dataVersion = 16--connectRocksDB :: MonadIO m => Word32 -> FilePath -> m DatabaseReader-connectRocksDB gap dir = do- bdb <-- open- dir- defaultOptions- { createIfMissing = True- , compression = SnappyCompression- , maxOpenFiles = -1- , writeBufferSize = 2 ^ (30 :: Integer)- } >>= \db ->- return- DatabaseReader- { databaseReadOptions = defaultReadOptions- , databaseHandle = db- , databaseMaxGap = gap- }- initRocksDB bdb- return bdb--withDatabaseReader :: MonadIO m => DatabaseReader -> DatabaseReaderT m a -> m a-withDatabaseReader = flip runReaderT--initRocksDB :: MonadIO m => DatabaseReader -> m ()-initRocksDB bdb@DatabaseReader {databaseReadOptions = opts, databaseHandle = 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 => DatabaseReader -> m ()-migrate15to16 DatabaseReader {databaseReadOptions = opts, databaseHandle = 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)--setInitRocksDB :: MonadIO m => DB -> m ()-setInitRocksDB db = insert db VersionKey dataVersion--getBestDatabaseReader :: MonadIO m => DatabaseReader -> m (Maybe BlockHash)-getBestDatabaseReader DatabaseReader {databaseReadOptions = opts, databaseHandle = db} =- retrieve db opts BestKey--getBlocksAtHeightDB :: MonadIO m => BlockHeight -> DatabaseReader -> m [BlockHash]-getBlocksAtHeightDB h DatabaseReader {databaseReadOptions = opts, databaseHandle = db} =- retrieve db opts (HeightKey h) >>= \case- Nothing -> return []- Just ls -> return ls--getDatabaseReader :: MonadIO m => BlockHash -> DatabaseReader -> m (Maybe BlockData)-getDatabaseReader h DatabaseReader {databaseReadOptions = opts, databaseHandle = db} =- retrieve db opts (BlockKey h)--getTxDataDB ::- MonadIO m => TxHash -> DatabaseReader -> m (Maybe TxData)-getTxDataDB th DatabaseReader {databaseReadOptions = opts, databaseHandle = db} =- retrieve db opts (TxKey th)--getSpenderDB :: MonadIO m => OutPoint -> DatabaseReader -> m (Maybe Spender)-getSpenderDB op DatabaseReader {databaseReadOptions = opts, databaseHandle = db} =- retrieve db opts $ SpenderKey op--getSpendersDB :: MonadIO m => TxHash -> DatabaseReader -> m (IntMap Spender)-getSpendersDB th DatabaseReader {databaseReadOptions = opts, databaseHandle = db} =- I.fromList . map (uncurry f) <$>- liftIO (matchingAsList db opts (SpenderKeyS th))- where- f (SpenderKey op) s = (fromIntegral (outPointIndex op), s)- f _ _ = undefined--getBalanceDB :: MonadIO m => Address -> DatabaseReader -> m Balance-getBalanceDB a DatabaseReader {databaseReadOptions = opts, databaseHandle = db} =- fromMaybe (zeroBalance a) . fmap (valToBalance a) <$>- retrieve db opts (BalKey a)--getMempoolDB :: MonadIO m => DatabaseReader -> m [BlockTx]-getMempoolDB DatabaseReader {databaseReadOptions = opts, databaseHandle = db} =- fmap f . fromMaybe [] <$> retrieve db opts MemKey- where- f (t, h) = BlockTx {blockTxBlock = MemRef t, blockTxHash = h}--getOrphansDB ::- MonadIO m- => DatabaseReader- -> m [(UnixTime, Tx)]-getOrphansDB DatabaseReader {databaseReadOptions = opts, databaseHandle = db} =- liftIO . runResourceT . runConduit $- matching db opts OrphanKeyS .| mapC snd .| sinkList--getOrphanTxDB :: MonadIO m => TxHash -> DatabaseReader -> m (Maybe (UnixTime, Tx))-getOrphanTxDB h DatabaseReader {databaseReadOptions = opts, databaseHandle = db} =- retrieve db opts (OrphanKey h)--getAddressesTxsDB ::- MonadIO m- => [Address]- -> Maybe BlockRef- -> Maybe Limit- -> DatabaseReader- -> m [BlockTx]-getAddressesTxsDB addrs start limit db = do- ts <- concat <$> mapM (\a -> getAddressTxsDB a start limit db) addrs- let ts' = nub $ sortBy (flip compare `on` blockTxBlock) ts- return $ applyLimit limit ts'--getAddressTxsDB ::- MonadIO m- => Address- -> Maybe BlockRef- -> Maybe Limit- -> DatabaseReader- -> m [BlockTx]-getAddressTxsDB a start limit DatabaseReader {databaseReadOptions = opts, databaseHandle = db} =- liftIO . runResourceT . runConduit $- x .| applyLimitC limit .| mapC (uncurry f) .| sinkList- where- x =- case start of- Nothing -> matching db opts (AddrTxKeyA a)- Just br -> matchingSkip db opts (AddrTxKeyA a) (AddrTxKeyB a br)- f AddrTxKey {addrTxKeyT = t} () = t- f _ _ = undefined--getAddressBalancesDB ::- (MonadIO m, MonadResource m)- => DatabaseReader- -> ConduitT i Balance m ()-getAddressBalancesDB DatabaseReader {databaseReadOptions = opts, databaseHandle = db} =- matching db opts BalKeyS .| mapC (\(BalKey a, b) -> valToBalance a b)--getUnspentsDB ::- (MonadIO m, MonadResource m)- => DatabaseReader- -> ConduitT i Unspent m ()-getUnspentsDB DatabaseReader {databaseReadOptions = opts, databaseHandle = db} =- matching db opts UnspentKeyB .|- mapC (\(UnspentKey k, v) -> unspentFromDB k v)--getUnspentDB :: MonadIO m => OutPoint -> DatabaseReader -> m (Maybe Unspent)-getUnspentDB p DatabaseReader {databaseReadOptions = opts, databaseHandle = db} =- fmap (valToUnspent p) <$> retrieve db opts (UnspentKey p)--getAddressesUnspentsDB ::- MonadIO m- => [Address]- -> Maybe BlockRef- -> Maybe Limit- -> DatabaseReader- -> m [Unspent]-getAddressesUnspentsDB addrs start limit bdb = do- us <- concat <$> mapM (\a -> getAddressUnspentsDB a start limit bdb) addrs- let us' = nub $ sortBy (flip compare `on` unspentBlock) us- return $ applyLimit limit us'--getAddressUnspentsDB ::- MonadIO m- => Address- -> Maybe BlockRef- -> Maybe Limit- -> DatabaseReader- -> m [Unspent]-getAddressUnspentsDB a start limit DatabaseReader {databaseReadOptions = opts, databaseHandle = db} =- liftIO . runResourceT . runConduit $- x .| applyLimitC limit .| mapC (uncurry toUnspent) .| sinkList- where- x =- case start of- Nothing -> matching db opts (AddrOutKeyA a)- Just br -> matchingSkip db opts (AddrOutKeyA a) (AddrOutKeyB a br)--unspentFromDB :: OutPoint -> UnspentVal -> Unspent-unspentFromDB p UnspentVal { unspentValBlock = b- , unspentValAmount = v- , unspentValScript = s- } =- Unspent- { unspentBlock = b- , unspentAmount = v- , unspentPoint = p- , unspentScript = s- }--instance MonadIO m => StoreRead (DatabaseReaderT m) where- getBestBlock = ask >>= getBestDatabaseReader- getBlocksAtHeight h = ask >>= getBlocksAtHeightDB h- getBlock b = ask >>= getDatabaseReader 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- getOrphans = ask >>= getOrphansDB- getAddressUnspents a b c = ask >>= getAddressUnspentsDB a b c- getAddressTxs a b c = ask >>= getAddressTxsDB a b c- getMaxGap = asks databaseMaxGap
− src/Network/Haskoin/Store/Data/DatabaseWriter.hs
@@ -1,376 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-module Network.Haskoin.Store.Data.DatabaseWriter where--import Control.Applicative ((<|>))-import Control.Monad (join)-import Control.Monad.Except (MonadError)-import Control.Monad.Reader (ReaderT)-import qualified Control.Monad.Reader as R-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 (nub)-import Data.Maybe (fromJust, fromMaybe,- 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.Common (BalVal, Balance,- BlockData,- BlockRef (..),- BlockTx (..),- Spender,- StoreRead (..),- StoreWrite (..),- TxData, UnixTime,- Unspent, UnspentVal,- nullBalance,- zeroBalance)-import Network.Haskoin.Store.Data.DatabaseReader (DatabaseReader (..),- withDatabaseReader)-import Network.Haskoin.Store.Data.MemoryDatabase (MemoryDatabase (..),- MemoryState (..),- emptyMemoryDatabase,- getMempoolH,- getOrphanTxH,- getSpenderH,- getSpendersH,- getUnspentH,- withMemoryDatabase)-import Network.Haskoin.Store.Data.Types (AddrOutKey (..),- AddrTxKey (..),- BalKey (..),- BestKey (..),- BlockKey (..),- HeightKey (..),- MemKey (..),- OrphanKey (..),- OutVal,- SpenderKey (..),- TxKey (..),- UnspentKey (..))-import UnliftIO (MonadIO, newTVarIO,- readTVarIO)--data DatabaseWriter = DatabaseWriter- { databaseWriterReader :: !DatabaseReader- , databaseWriterState :: !MemoryState- }--runDatabaseWriter ::- (MonadIO m, MonadError e m)- => DatabaseReader- -> ReaderT DatabaseWriter m a- -> m a-runDatabaseWriter bdb@DatabaseReader {databaseHandle = db, databaseMaxGap = gap} f = do- hm <- newTVarIO emptyMemoryDatabase- let ms = MemoryState {memoryDatabase = hm, memoryMaxGap = gap}- x <-- R.runReaderT- f- DatabaseWriter- {databaseWriterReader = bdb, databaseWriterState = ms}- ops <- hashMapOps <$> readTVarIO hm- writeBatch db ops- return x--hashMapOps :: MemoryDatabase -> [BatchOp]-hashMapOps db =- bestBlockOp (hBest db) <>- blockHashOps (hBlock db) <>- blockHeightOps (hHeight db) <>- txOps (hTx db) <>- spenderOps (hSpender db) <>- balOps (hBalance db) <>- addrTxOps (hAddrTx db) <>- addrOutOps (hAddrOut db) <>- maybeToList (mempoolOp <$> hMempool db) <>- orphanOps (hOrphans db) <>- unspentOps (hUnspent db)--cacheMapOps :: MemoryDatabase -> [BatchOp]-cacheMapOps db =- balOps (hBalance db) <> maybeToList (mempoolOp <$> hMempool db) <>- addrTxOps (hAddrTx db) <>- unspentOps (hUnspent db)--bestBlockOp :: Maybe BlockHash -> [BatchOp]-bestBlockOp Nothing = []-bestBlockOp (Just b) = [insertOp BestKey b]--blockHashOps :: HashMap BlockHash BlockData -> [BatchOp]-blockHashOps = map (uncurry f) . M.toList- where- f = insertOp . BlockKey--blockHeightOps :: HashMap BlockHeight [BlockHash] -> [BatchOp]-blockHeightOps = map (uncurry f) . M.toList- where- f = insertOp . HeightKey--txOps :: HashMap TxHash TxData -> [BatchOp]-txOps = map (uncurry f) . M.toList- where- f = insertOp . TxKey--spenderOps :: HashMap TxHash (IntMap (Maybe Spender)) -> [BatchOp]-spenderOps = concatMap (uncurry f) . M.toList- where- f h = map (uncurry (g h)) . I.toList- g h i (Just s) = insertOp (SpenderKey (OutPoint h (fromIntegral i))) s- g h i Nothing = deleteOp (SpenderKey (OutPoint h (fromIntegral i)))--balOps :: HashMap Address BalVal -> [BatchOp]-balOps = map (uncurry f) . M.toList- where- f = insertOp . BalKey--addrTxOps ::- HashMap Address (HashMap BlockRef (HashMap TxHash Bool)) -> [BatchOp]-addrTxOps = concat . concatMap (uncurry f) . M.toList- where- f a = map (uncurry (g a)) . M.toList- g a b = map (uncurry (h a b)) . M.toList- h a b t True =- insertOp- (AddrTxKey- { addrTxKeyA = a- , addrTxKeyT =- BlockTx- { blockTxBlock = b- , blockTxHash = t- }- })- ()- h a b t False =- deleteOp- AddrTxKey- { addrTxKeyA = a- , addrTxKeyT =- BlockTx- { blockTxBlock = b- , blockTxHash = t- }- }--addrOutOps ::- HashMap Address (HashMap BlockRef (HashMap OutPoint (Maybe OutVal)))- -> [BatchOp]-addrOutOps = concat . concatMap (uncurry f) . M.toList- where- f a = map (uncurry (g a)) . M.toList- g a b = map (uncurry (h a b)) . M.toList- h a b p (Just l) =- insertOp- (AddrOutKey {addrOutKeyA = a, addrOutKeyB = b, addrOutKeyP = p})- l- h a b p Nothing =- deleteOp AddrOutKey {addrOutKeyA = a, addrOutKeyB = b, addrOutKeyP = p}--mempoolOp :: [BlockTx] -> BatchOp-mempoolOp =- insertOp MemKey .- map (\BlockTx {blockTxBlock = MemRef t, blockTxHash = h} -> (t, h))--orphanOps :: HashMap TxHash (Maybe (UnixTime, Tx)) -> [BatchOp]-orphanOps = map (uncurry f) . M.toList- where- f h (Just x) = insertOp (OrphanKey h) x- f h Nothing = deleteOp (OrphanKey h)--unspentOps :: HashMap TxHash (IntMap (Maybe UnspentVal)) -> [BatchOp]-unspentOps = concatMap (uncurry f) . M.toList- where- f h = map (uncurry (g h)) . I.toList- g h i (Just u) = insertOp (UnspentKey (OutPoint h (fromIntegral i))) u- g h i Nothing = deleteOp (UnspentKey (OutPoint h (fromIntegral i)))--setBestI :: MonadIO m => BlockHash -> DatabaseWriter -> m ()-setBestI bh DatabaseWriter {databaseWriterState = hm} =- withMemoryDatabase hm $ setBest bh--insertBlockI :: MonadIO m => BlockData -> DatabaseWriter -> m ()-insertBlockI b DatabaseWriter {databaseWriterState = hm} =- withMemoryDatabase hm $ insertBlock b--setBlocksAtHeightI :: MonadIO m => [BlockHash] -> BlockHeight -> DatabaseWriter -> m ()-setBlocksAtHeightI hs g DatabaseWriter {databaseWriterState = hm} =- withMemoryDatabase hm $ setBlocksAtHeight hs g--insertTxI :: MonadIO m => TxData -> DatabaseWriter -> m ()-insertTxI t DatabaseWriter {databaseWriterState = hm} =- withMemoryDatabase hm $ insertTx t--insertSpenderI :: MonadIO m => OutPoint -> Spender -> DatabaseWriter -> m ()-insertSpenderI p s DatabaseWriter {databaseWriterState = hm} =- withMemoryDatabase hm $ insertSpender p s--deleteSpenderI :: MonadIO m => OutPoint -> DatabaseWriter -> m ()-deleteSpenderI p DatabaseWriter {databaseWriterState = hm} =- withMemoryDatabase hm $ deleteSpender p--insertAddrTxI :: MonadIO m => Address -> BlockTx -> DatabaseWriter -> m ()-insertAddrTxI a t DatabaseWriter {databaseWriterState = hm} =- withMemoryDatabase hm $ insertAddrTx a t--deleteAddrTxI :: MonadIO m => Address -> BlockTx -> DatabaseWriter -> m ()-deleteAddrTxI a t DatabaseWriter {databaseWriterState = hm} =- withMemoryDatabase hm $ deleteAddrTx a t--insertAddrUnspentI :: MonadIO m => Address -> Unspent -> DatabaseWriter -> m ()-insertAddrUnspentI a u DatabaseWriter {databaseWriterState = hm} =- withMemoryDatabase hm $ insertAddrUnspent a u--deleteAddrUnspentI :: MonadIO m => Address -> Unspent -> DatabaseWriter -> m ()-deleteAddrUnspentI a u DatabaseWriter {databaseWriterState = hm} =- withMemoryDatabase hm $ deleteAddrUnspent a u--setMempoolI :: MonadIO m => [BlockTx] -> DatabaseWriter -> m ()-setMempoolI xs DatabaseWriter {databaseWriterState = hm} = withMemoryDatabase hm $ setMempool xs--insertOrphanTxI :: MonadIO m => Tx -> UnixTime -> DatabaseWriter -> m ()-insertOrphanTxI t p DatabaseWriter {databaseWriterState = hm} =- withMemoryDatabase hm $ insertOrphanTx t p--deleteOrphanTxI :: MonadIO m => TxHash -> DatabaseWriter -> m ()-deleteOrphanTxI t DatabaseWriter {databaseWriterState = hm} =- withMemoryDatabase hm $ deleteOrphanTx t--getBestBlockI :: MonadIO m => DatabaseWriter -> m (Maybe BlockHash)-getBestBlockI DatabaseWriter {databaseWriterState = hm, databaseWriterReader = db} =- runMaybeT $ MaybeT f <|> MaybeT g- where- f = withMemoryDatabase hm getBestBlock- g = withDatabaseReader db getBestBlock--getBlocksAtHeightI :: MonadIO m => BlockHeight -> DatabaseWriter -> m [BlockHash]-getBlocksAtHeightI bh DatabaseWriter {databaseWriterState = hm, databaseWriterReader = db} = do- xs <- withMemoryDatabase hm $ getBlocksAtHeight bh- ys <- withDatabaseReader db $ getBlocksAtHeight bh- return . nub $ xs <> ys--getBlockI :: MonadIO m => BlockHash -> DatabaseWriter -> m (Maybe BlockData)-getBlockI bh DatabaseWriter {databaseWriterReader = db, databaseWriterState = hm} =- runMaybeT $ MaybeT f <|> MaybeT g- where- f = withMemoryDatabase hm $ getBlock bh- g = withDatabaseReader db $ getBlock bh--getTxDataI ::- MonadIO m => TxHash -> DatabaseWriter -> m (Maybe TxData)-getTxDataI th DatabaseWriter {databaseWriterReader = db, databaseWriterState = hm} =- runMaybeT $ MaybeT f <|> MaybeT g- where- f = withMemoryDatabase hm $ getTxData th- g = withDatabaseReader db $ getTxData th--getOrphanTxI :: MonadIO m => TxHash -> DatabaseWriter -> m (Maybe (UnixTime, Tx))-getOrphanTxI h DatabaseWriter {databaseWriterReader = db, databaseWriterState = hm} =- fmap join . runMaybeT $ MaybeT f <|> MaybeT g- where- f = getOrphanTxH h <$> readTVarIO (memoryDatabase hm)- g = Just <$> withDatabaseReader db (getOrphanTx h)--getSpenderI :: MonadIO m => OutPoint -> DatabaseWriter -> m (Maybe Spender)-getSpenderI op DatabaseWriter {databaseWriterReader = db, databaseWriterState = hm} =- fmap join . runMaybeT $ MaybeT f <|> MaybeT g- where- f = getSpenderH op <$> readTVarIO (memoryDatabase hm)- g = Just <$> withDatabaseReader db (getSpender op)--getSpendersI :: MonadIO m => TxHash -> DatabaseWriter -> m (IntMap Spender)-getSpendersI t DatabaseWriter {databaseWriterReader = db, databaseWriterState = hm} = do- hsm <- getSpendersH t <$> readTVarIO (memoryDatabase hm)- dsm <- I.map Just <$> withDatabaseReader db (getSpenders t)- return . I.map fromJust . I.filter isJust $ hsm <> dsm--getBalanceI :: MonadIO m => Address -> DatabaseWriter -> m Balance-getBalanceI a DatabaseWriter {databaseWriterReader = db, databaseWriterState = hm} =- fromMaybe (zeroBalance a) <$> runMaybeT (MaybeT f <|> MaybeT g)- where- f =- withMemoryDatabase hm $- getBalance a >>= \b ->- return $- if nullBalance b- then Nothing- else Just b- g =- withDatabaseReader db $- getBalance a >>= \b ->- return $- if nullBalance b- then Nothing- else Just b--setBalanceI :: MonadIO m => Balance -> DatabaseWriter -> m ()-setBalanceI b DatabaseWriter {databaseWriterState = hm} =- withMemoryDatabase hm $ setBalance b--getUnspentI :: MonadIO m => OutPoint -> DatabaseWriter -> m (Maybe Unspent)-getUnspentI op DatabaseWriter {databaseWriterReader = db, databaseWriterState = hm} =- fmap join . runMaybeT $ MaybeT f <|> MaybeT g- where- f = getUnspentH op <$> readTVarIO (memoryDatabase hm)- g = Just <$> withDatabaseReader db (getUnspent op)--insertUnspentI :: MonadIO m => Unspent -> DatabaseWriter -> m ()-insertUnspentI u DatabaseWriter {databaseWriterState = hm} =- withMemoryDatabase hm $ insertUnspent u--deleteUnspentI :: MonadIO m => OutPoint -> DatabaseWriter -> m ()-deleteUnspentI p DatabaseWriter {databaseWriterState = hm} =- withMemoryDatabase hm $ deleteUnspent p--getMempoolI ::- MonadIO m- => DatabaseWriter- -> m [BlockTx]-getMempoolI DatabaseWriter {databaseWriterState = hm, databaseWriterReader = db} =- getMempoolH <$> readTVarIO (memoryDatabase hm) >>= \case- Just xs -> return xs- Nothing -> withDatabaseReader db getMempool--instance MonadIO m => StoreRead (ReaderT DatabaseWriter m) where- getBestBlock = R.ask >>= getBestBlockI- getBlocksAtHeight h = R.ask >>= getBlocksAtHeightI h- getBlock b = R.ask >>= getBlockI b- getTxData t = R.ask >>= getTxDataI t- getSpender p = R.ask >>= getSpenderI p- getSpenders t = R.ask >>= getSpendersI t- getOrphanTx h = R.ask >>= getOrphanTxI h- getUnspent a = R.ask >>= getUnspentI a- getBalance a = R.ask >>= getBalanceI a- getMempool = R.ask >>= getMempoolI- getAddressesTxs = undefined- getAddressesUnspents = undefined- getOrphans = undefined- getMaxGap = R.asks (databaseMaxGap . databaseWriterReader)--instance MonadIO m => StoreWrite (ReaderT DatabaseWriter m) where- setBest h = R.ask >>= setBestI h- insertBlock b = R.ask >>= insertBlockI b- setBlocksAtHeight hs g = R.ask >>= setBlocksAtHeightI hs g- insertTx t = R.ask >>= insertTxI t- insertSpender p s = R.ask >>= insertSpenderI p s- deleteSpender p = R.ask >>= deleteSpenderI p- insertAddrTx a t = R.ask >>= insertAddrTxI a t- deleteAddrTx a t = R.ask >>= deleteAddrTxI a t- insertAddrUnspent a u = R.ask >>= insertAddrUnspentI a u- deleteAddrUnspent a u = R.ask >>= deleteAddrUnspentI a u- setMempool xs = R.ask >>= setMempoolI xs- insertOrphanTx t p = R.ask >>= insertOrphanTxI t p- deleteOrphanTx t = R.ask >>= deleteOrphanTxI t- insertUnspent u = R.ask >>= insertUnspentI u- deleteUnspent p = R.ask >>= deleteUnspentI p- setBalance b = R.ask >>= setBalanceI b
− src/Network/Haskoin/Store/Data/MemoryDatabase.hs
@@ -1,403 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-module Network.Haskoin.Store.Data.MemoryDatabase where--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 (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 (nub, sortBy)-import Data.Maybe (catMaybes, fromJust,- fromMaybe, isJust,- maybeToList)-import Data.Word (Word32)-import Haskoin (Address, BlockHash,- BlockHeight, OutPoint (..),- Tx, TxHash, headerHash,- txHash)-import Network.Haskoin.Store.Common (BalVal, Balance,- BlockData (..), BlockRef,- BlockTx (..), Limit, Spender,- StoreRead (..),- StoreWrite (..), TxData (..),- UnixTime, Unspent (..),- UnspentVal, applyLimit,- balanceToVal, unspentToVal,- valToBalance, valToUnspent,- zeroBalance)-import Network.Haskoin.Store.Data.Types (OutVal (..))-import UnliftIO--data MemoryState =- MemoryState- { memoryDatabase :: !(TVar MemoryDatabase)- , memoryMaxGap :: !Word32- }--withMemoryDatabase ::- MonadIO m- => MemoryState- -> ReaderT MemoryState m a- -> m a-withMemoryDatabase = flip R.runReaderT--data MemoryDatabase = MemoryDatabase- { hBest :: !(Maybe BlockHash)- , hBlock :: !(HashMap BlockHash BlockData)- , hHeight :: !(HashMap BlockHeight [BlockHash])- , hTx :: !(HashMap TxHash TxData)- , hSpender :: !(HashMap TxHash (IntMap (Maybe Spender)))- , hUnspent :: !(HashMap TxHash (IntMap (Maybe UnspentVal)))- , hBalance :: !(HashMap Address BalVal)- , hAddrTx :: !(HashMap Address (HashMap BlockRef (HashMap TxHash Bool)))- , hAddrOut :: !(HashMap Address (HashMap BlockRef (HashMap OutPoint (Maybe OutVal))))- , hMempool :: !(Maybe [BlockTx])- , hOrphans :: !(HashMap TxHash (Maybe (UnixTime, Tx)))- } deriving (Eq, Show)--emptyMemoryDatabase :: MemoryDatabase-emptyMemoryDatabase =- MemoryDatabase- { hBest = Nothing- , hBlock = M.empty- , hHeight = M.empty- , hTx = M.empty- , hSpender = M.empty- , hUnspent = M.empty- , hBalance = M.empty- , hAddrTx = M.empty- , hAddrOut = M.empty- , hMempool = Nothing- , hOrphans = M.empty- }--getBestBlockH :: MemoryDatabase -> Maybe BlockHash-getBestBlockH = hBest--getBlocksAtHeightH :: BlockHeight -> MemoryDatabase -> [BlockHash]-getBlocksAtHeightH h = M.lookupDefault [] h . hHeight--getBlockH :: BlockHash -> MemoryDatabase -> Maybe BlockData-getBlockH h = M.lookup h . hBlock--getTxDataH :: TxHash -> MemoryDatabase -> Maybe TxData-getTxDataH t = M.lookup t . hTx--getSpenderH :: OutPoint -> MemoryDatabase -> Maybe (Maybe Spender)-getSpenderH op db = do- m <- M.lookup (outPointHash op) (hSpender db)- I.lookup (fromIntegral (outPointIndex op)) m--getSpendersH :: TxHash -> MemoryDatabase -> IntMap (Maybe Spender)-getSpendersH t = M.lookupDefault I.empty t . hSpender--getBalanceH :: Address -> MemoryDatabase -> Balance-getBalanceH a =- fromMaybe (zeroBalance a) . fmap (valToBalance a) . M.lookup a . hBalance--getMempoolH :: MemoryDatabase -> Maybe [BlockTx]-getMempoolH = hMempool--getOrphansH :: MemoryDatabase -> [(UnixTime, Tx)]-getOrphansH = catMaybes . M.elems . hOrphans--getOrphanTxH :: TxHash -> MemoryDatabase -> Maybe (Maybe (UnixTime, Tx))-getOrphanTxH h = M.lookup h . hOrphans--getUnspentsH :: Monad m => MemoryDatabase -> ConduitT i Unspent m ()-getUnspentsH MemoryDatabase {hUnspent = us} =- yieldMany- [ u- | (h, m) <- M.toList us- , (i, mv) <- I.toList m- , v <- maybeToList mv- , let p = OutPoint h (fromIntegral i)- , let u = valToUnspent p v- ]--getAddressesTxsH ::- [Address] -> Maybe BlockRef -> Maybe Limit -> MemoryDatabase -> [BlockTx]-getAddressesTxsH addrs start limit db = applyLimit limit xs- where- xs =- nub . sortBy (flip compare `on` blockTxBlock) . concat $- map (\a -> getAddressTxsH a start limit db) addrs--getAddressTxsH ::- Address -> Maybe BlockRef -> Maybe Limit -> MemoryDatabase -> [BlockTx]-getAddressTxsH addr start limit db =- applyLimit limit .- dropWhile h .- sortBy (flip compare) . catMaybes . concatMap (uncurry f) . M.toList $- M.lookupDefault M.empty addr (hAddrTx db)- where- f b hm = map (uncurry (g b)) $ M.toList hm- g b h' True = Just BlockTx {blockTxBlock = b, blockTxHash = h'}- g _ _ False = Nothing- h BlockTx {blockTxBlock = b} =- case start of- Nothing -> False- Just br -> b > br--getAddressBalancesH :: Monad m => MemoryDatabase -> ConduitT i Balance m ()-getAddressBalancesH MemoryDatabase {hBalance = bm} =- yieldMany (M.toList bm) .| mapC (uncurry valToBalance)--getAddressesUnspentsH ::- [Address] -> Maybe BlockRef -> Maybe Limit -> MemoryDatabase -> [Unspent]-getAddressesUnspentsH addrs start limit db = applyLimit limit xs- where- xs =- nub . sortBy (flip compare `on` unspentBlock) . concat $- map (\a -> getAddressUnspentsH a start limit db) addrs--getAddressUnspentsH ::- Address -> Maybe BlockRef -> Maybe Limit -> MemoryDatabase -> [Unspent]-getAddressUnspentsH addr start limit db =- applyLimit limit .- dropWhile h .- sortBy (flip compare) . catMaybes . concatMap (uncurry f) . M.toList $- M.lookupDefault M.empty addr (hAddrOut db)- where- f b hm = map (uncurry (g b)) $ M.toList hm- g b p (Just u) =- Just- Unspent- { unspentBlock = b- , unspentAmount = outValAmount u- , unspentScript = B.Short.toShort (outValScript u)- , unspentPoint = p- }- g _ _ Nothing = Nothing- h Unspent {unspentBlock = b} =- case start of- Nothing -> False- Just br -> b > br--setBestH :: BlockHash -> MemoryDatabase -> MemoryDatabase-setBestH h db = db {hBest = Just h}--insertBlockH :: BlockData -> MemoryDatabase -> MemoryDatabase-insertBlockH bd db =- db {hBlock = M.insert (headerHash (blockDataHeader bd)) bd (hBlock db)}--setBlocksAtHeightH :: [BlockHash] -> BlockHeight -> MemoryDatabase -> MemoryDatabase-setBlocksAtHeightH hs g db = db {hHeight = M.insert g hs (hHeight db)}--insertTxH :: TxData -> MemoryDatabase -> MemoryDatabase-insertTxH tx db = db {hTx = M.insert (txHash (txData tx)) tx (hTx db)}--insertSpenderH :: OutPoint -> Spender -> MemoryDatabase -> MemoryDatabase-insertSpenderH op s db =- db- { hSpender =- M.insertWith- (<>)- (outPointHash op)- (I.singleton (fromIntegral (outPointIndex op)) (Just s))- (hSpender db)- }--deleteSpenderH :: OutPoint -> MemoryDatabase -> MemoryDatabase-deleteSpenderH op db =- db- { hSpender =- M.insertWith- (<>)- (outPointHash op)- (I.singleton (fromIntegral (outPointIndex op)) Nothing)- (hSpender db)- }--setBalanceH :: Balance -> MemoryDatabase -> MemoryDatabase-setBalanceH bal db = db {hBalance = M.insert a b (hBalance db)}- where- (a, b) = balanceToVal bal--insertAddrTxH :: Address -> BlockTx -> MemoryDatabase -> MemoryDatabase-insertAddrTxH a btx db =- let s =- M.singleton- a- (M.singleton- (blockTxBlock btx)- (M.singleton (blockTxHash btx) True))- in db {hAddrTx = M.unionWith (M.unionWith M.union) s (hAddrTx db)}--deleteAddrTxH :: Address -> BlockTx -> MemoryDatabase -> MemoryDatabase-deleteAddrTxH a btx db =- let s =- M.singleton- a- (M.singleton- (blockTxBlock btx)- (M.singleton (blockTxHash btx) False))- in db {hAddrTx = M.unionWith (M.unionWith M.union) s (hAddrTx db)}--insertAddrUnspentH :: Address -> Unspent -> MemoryDatabase -> MemoryDatabase-insertAddrUnspentH a u db =- let uns =- OutVal- { outValAmount = unspentAmount u- , outValScript = B.Short.fromShort (unspentScript u)- }- s =- M.singleton- a- (M.singleton- (unspentBlock u)- (M.singleton (unspentPoint u) (Just uns)))- in db {hAddrOut = M.unionWith (M.unionWith M.union) s (hAddrOut db)}--deleteAddrUnspentH :: Address -> Unspent -> MemoryDatabase -> MemoryDatabase-deleteAddrUnspentH a u db =- let s =- M.singleton- a- (M.singleton- (unspentBlock u)- (M.singleton (unspentPoint u) Nothing))- in db {hAddrOut = M.unionWith (M.unionWith M.union) s (hAddrOut db)}--setMempoolH :: [BlockTx] -> MemoryDatabase -> MemoryDatabase-setMempoolH xs db = db {hMempool = Just xs}--insertOrphanTxH :: Tx -> UnixTime -> MemoryDatabase -> MemoryDatabase-insertOrphanTxH tx u db =- db {hOrphans = M.insert (txHash tx) (Just (u, tx)) (hOrphans db)}--deleteOrphanTxH :: TxHash -> MemoryDatabase -> MemoryDatabase-deleteOrphanTxH h db = db {hOrphans = M.insert h Nothing (hOrphans db)}--getUnspentH :: OutPoint -> MemoryDatabase -> Maybe (Maybe Unspent)-getUnspentH op db = do- m <- M.lookup (outPointHash op) (hUnspent db)- fmap (valToUnspent op) <$> I.lookup (fromIntegral (outPointIndex op)) m--insertUnspentH :: Unspent -> MemoryDatabase -> MemoryDatabase-insertUnspentH u db =- db- { hUnspent =- M.insertWith- (<>)- (outPointHash (unspentPoint u))- (I.singleton- (fromIntegral (outPointIndex (unspentPoint u)))- (Just (snd (unspentToVal u))))- (hUnspent db)- }--deleteUnspentH :: OutPoint -> MemoryDatabase -> MemoryDatabase-deleteUnspentH op db =- db- { hUnspent =- M.insertWith- (<>)- (outPointHash op)- (I.singleton (fromIntegral (outPointIndex op)) Nothing)- (hUnspent db)- }--instance MonadIO m => StoreRead (ReaderT MemoryState m) where- getBestBlock = do- v <- R.asks memoryDatabase >>= readTVarIO- return $ getBestBlockH v- getBlocksAtHeight h = do- v <- R.asks memoryDatabase >>= readTVarIO- return $ getBlocksAtHeightH h v- getBlock b = do- v <- R.asks memoryDatabase >>= readTVarIO- return $ getBlockH b v- getTxData t = do- v <- R.asks memoryDatabase >>= readTVarIO- return $ getTxDataH t v- getSpender t = do- v <- R.asks memoryDatabase >>= readTVarIO- return . join $ getSpenderH t v- getSpenders t = do- v <- R.asks memoryDatabase >>= readTVarIO- return . I.map fromJust . I.filter isJust $ getSpendersH t v- getOrphanTx h = do- v <- R.asks memoryDatabase >>= readTVarIO- return . join $ getOrphanTxH h v- getUnspent p = do- v <- R.asks memoryDatabase >>= readTVarIO- return . join $ getUnspentH p v- getBalance a = do- v <- R.asks memoryDatabase >>= readTVarIO- return $ getBalanceH a v- getMempool = do- v <- R.asks memoryDatabase >>= readTVarIO- return . fromMaybe [] $ getMempoolH v- getAddressesTxs addr start limit = do- v <- R.asks memoryDatabase >>= readTVarIO- return $ getAddressesTxsH addr start limit v- getAddressesUnspents addr start limit = do- v <- R.asks memoryDatabase >>= readTVarIO- return $ getAddressesUnspentsH addr start limit v- getOrphans = do- v <- R.asks memoryDatabase >>= readTVarIO- return $ getOrphansH v- getAddressTxs addr start limit = do- v <- R.asks memoryDatabase >>= readTVarIO- return $ getAddressTxsH addr start limit v- getAddressUnspents addr start limit = do- v <- R.asks memoryDatabase >>= readTVarIO- return $ getAddressUnspentsH addr start limit v- getMaxGap = R.asks memoryMaxGap--instance MonadIO m => StoreWrite (ReaderT MemoryState m) where- setBest h = do- v <- R.asks memoryDatabase- atomically $ modifyTVar v (setBestH h)- insertBlock b = do- v <- R.asks memoryDatabase- atomically $ modifyTVar v (insertBlockH b)- setBlocksAtHeight h g = do- v <- R.asks memoryDatabase- atomically $ modifyTVar v (setBlocksAtHeightH h g)- insertTx t = do- v <- R.asks memoryDatabase- atomically $ modifyTVar v (insertTxH t)- insertSpender p s = do- v <- R.asks memoryDatabase- atomically $ modifyTVar v (insertSpenderH p s)- deleteSpender p = do- v <- R.asks memoryDatabase- atomically $ modifyTVar v (deleteSpenderH p)- insertAddrTx a t = do- v <- R.asks memoryDatabase- atomically $ modifyTVar v (insertAddrTxH a t)- deleteAddrTx a t = do- v <- R.asks memoryDatabase- atomically $ modifyTVar v (deleteAddrTxH a t)- insertAddrUnspent a u = do- v <- R.asks memoryDatabase- atomically $ modifyTVar v (insertAddrUnspentH a u)- deleteAddrUnspent a u = do- v <- R.asks memoryDatabase- atomically $ modifyTVar v (deleteAddrUnspentH a u)- setMempool xs = do- v <- R.asks memoryDatabase- atomically $ modifyTVar v (setMempoolH xs)- insertOrphanTx t u = do- v <- R.asks memoryDatabase- atomically $ modifyTVar v (insertOrphanTxH t u)- deleteOrphanTx h = do- v <- R.asks memoryDatabase- atomically $ modifyTVar v (deleteOrphanTxH h)- setBalance b = do- v <- R.asks memoryDatabase- atomically $ modifyTVar v (setBalanceH b)- insertUnspent h = do- v <- R.asks memoryDatabase- atomically $ modifyTVar v (insertUnspentH h)- deleteUnspent p = do- v <- R.asks memoryDatabase- atomically $ modifyTVar v (deleteUnspentH p)
− src/Network/Haskoin/Store/Data/Types.hs
@@ -1,360 +0,0 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-module Network.Haskoin.Store.Data.Types where--import Control.Monad (guard)-import Data.ByteString (ByteString)-import qualified Data.ByteString as BS-import qualified Data.ByteString.Short as BSS-import Data.Hashable (Hashable)-import Data.Serialize (Serialize (..), getBytes,- getWord8, putWord8)-import Data.Word (Word32, Word64)-import Database.RocksDB.Query (Key, KeyValue)-import GHC.Generics (Generic)-import Haskoin (Address, BlockHash, BlockHeight,- OutPoint (..), Tx, TxHash)-import Network.Haskoin.Store.Common (BalVal, BlockData, BlockRef,- BlockTx (..), Spender, TxData,- UnixTime, Unspent (..),- UnspentVal, getUnixTime,- putUnixTime)---- | Database key for an address transaction.-data AddrTxKey- = AddrTxKey { addrTxKeyA :: !Address- , addrTxKeyT :: !BlockTx- }- -- ^ key for a transaction affecting an address- | AddrTxKeyA { addrTxKeyA :: !Address }- -- ^ short key that matches all entries- | AddrTxKeyB { addrTxKeyA :: !Address- , addrTxKeyB :: !BlockRef- }- | AddrTxKeyS- deriving (Show, Eq, Ord, Generic, Hashable)--instance Serialize AddrTxKey- -- 0x05 · Address · BlockRef · TxHash- where- put AddrTxKey { addrTxKeyA = a- , addrTxKeyT = BlockTx { blockTxBlock = b- , blockTxHash = t- }- } = do- putWord8 0x05- put a- put b- put t- -- 0x05 · Address- put AddrTxKeyA {addrTxKeyA = a} = do- putWord8 0x05- put a- -- 0x05 · Address · BlockRef- put AddrTxKeyB {addrTxKeyA = a, addrTxKeyB = b} = do- putWord8 0x05- put a- put b- -- 0x05- put AddrTxKeyS = putWord8 0x05- get = do- guard . (== 0x05) =<< getWord8- a <- get- b <- get- t <- get- return- AddrTxKey- { addrTxKeyA = a- , addrTxKeyT =- BlockTx- { blockTxBlock = b- , blockTxHash = t- }- }--instance Key AddrTxKey-instance KeyValue AddrTxKey ()---- | Database key for an address output.-data AddrOutKey- = AddrOutKey { addrOutKeyA :: !Address- , addrOutKeyB :: !BlockRef- , addrOutKeyP :: !OutPoint }- -- ^ full key- | AddrOutKeyA { addrOutKeyA :: !Address }- -- ^ short key for all spent or unspent outputs- | AddrOutKeyB { addrOutKeyA :: !Address- , addrOutKeyB :: !BlockRef- }- | AddrOutKeyS- deriving (Show, Read, Eq, Ord, Generic, Hashable)--instance Serialize AddrOutKey- -- 0x06 · StoreAddr · BlockRef · OutPoint- where- put AddrOutKey {addrOutKeyA = a, addrOutKeyB = b, addrOutKeyP = p} = do- putWord8 0x06- put a- put b- put p- -- 0x06 · StoreAddr · BlockRef- put AddrOutKeyB {addrOutKeyA = a, addrOutKeyB = b} = do- putWord8 0x06- put a- put b- -- 0x06 · StoreAddr- put AddrOutKeyA {addrOutKeyA = a} = do- putWord8 0x06- put a- -- 0x06- put AddrOutKeyS = putWord8 0x06- get = do- guard . (== 0x06) =<< getWord8- AddrOutKey <$> get <*> get <*> get--instance Key AddrOutKey--data OutVal = OutVal- { outValAmount :: !Word64- , outValScript :: !ByteString- } deriving (Show, Read, Eq, Ord, Generic, Hashable, Serialize)--instance KeyValue AddrOutKey OutVal---- | Transaction database key.-newtype TxKey = TxKey- { txKey :: TxHash- } deriving (Show, Read, Eq, Ord, Generic, Hashable)--instance Serialize TxKey where- -- 0x02 · TxHash- put (TxKey h) = do- putWord8 0x02- put h- get = do- guard . (== 0x02) =<< getWord8- TxKey <$> get--instance Key TxKey-instance KeyValue TxKey TxData--data SpenderKey- = SpenderKey { outputPoint :: !OutPoint }- | SpenderKeyS { outputKeyS :: !TxHash }- deriving (Show, Read, Eq, Ord, Generic, Hashable)--instance Serialize SpenderKey where- -- 0x10 · TxHash · Index- put (SpenderKey OutPoint {outPointHash = h, outPointIndex = i}) = do- putWord8 0x10- put h- put i- put (SpenderKeyS h) = do- putWord8 0x10- put h- get = do- guard . (== 0x10) =<< getWord8- op <- OutPoint <$> get <*> get- return $ SpenderKey op--instance Key SpenderKey-instance KeyValue SpenderKey Spender---- | Unspent output database key.-data UnspentKey- = UnspentKey { unspentKey :: !OutPoint }- | UnspentKeyS { unspentKeyS :: !TxHash }- | UnspentKeyB- deriving (Show, Read, Eq, Ord, Generic, Hashable)--instance Serialize UnspentKey- -- 0x09 · TxHash · Index- where- put UnspentKey {unspentKey = OutPoint {outPointHash = h, outPointIndex = i}} = do- putWord8 0x09- put h- put i- -- 0x09 · TxHash- put UnspentKeyS {unspentKeyS = t} = do- putWord8 0x09- put t- -- 0x09- put UnspentKeyB = putWord8 0x09- get = do- guard . (== 0x09) =<< getWord8- h <- get- i <- get- return $ UnspentKey OutPoint {outPointHash = h, outPointIndex = i}--instance Key UnspentKey-instance KeyValue UnspentKey UnspentVal--toUnspent :: AddrOutKey -> OutVal -> Unspent-toUnspent AddrOutKey {addrOutKeyB = b, addrOutKeyP = p} OutVal { outValAmount = v- , outValScript = s- } =- Unspent- { unspentBlock = b- , unspentAmount = v- , unspentScript = BSS.toShort s- , unspentPoint = p- }-toUnspent _ _ = undefined---- | Mempool transaction database key.-data MemKey =- MemKey- deriving (Show, Read)--instance Serialize MemKey where- -- 0x07- put MemKey = do- putWord8 0x07- get = do- guard . (== 0x07) =<< getWord8- return MemKey--instance Key MemKey-instance KeyValue MemKey [(UnixTime, TxHash)]---- | Orphan pool transaction database key.-data OrphanKey- = OrphanKey- { orphanKey :: !TxHash- }- | OrphanKeyS- deriving (Show, Read, Eq, Ord, Generic, Hashable)--instance Serialize OrphanKey- -- 0x08 · TxHash- where- put (OrphanKey h) = do- putWord8 0x08- put h- -- 0x08- put OrphanKeyS = putWord8 0x08- get = do- guard . (== 0x08) =<< getWord8- OrphanKey <$> get--instance Key OrphanKey-instance KeyValue OrphanKey (UnixTime, Tx)---- | Block entry database key.-newtype BlockKey = BlockKey- { blockKey :: BlockHash- } deriving (Show, Read, Eq, Ord, Generic, Hashable)--instance Serialize BlockKey where- -- 0x01 · BlockHash- put (BlockKey h) = do- putWord8 0x01- put h- get = do- guard . (== 0x01) =<< getWord8- BlockKey <$> get--instance KeyValue BlockKey BlockData---- | Block height database key.-newtype HeightKey = HeightKey- { heightKey :: BlockHeight- } deriving (Show, Read, Eq, Ord, Generic, Hashable)--instance Serialize HeightKey where- -- 0x03 · BlockHeight- put (HeightKey height) = do- putWord8 0x03- put height- get = do- guard . (== 0x03) =<< getWord8- HeightKey <$> get--instance Key HeightKey-instance KeyValue HeightKey [BlockHash]---- | Address balance database key.-data BalKey- = BalKey- { balanceKey :: !Address- }- | BalKeyS- deriving (Show, Read, Eq, Ord, Generic, Hashable)--instance Serialize BalKey where- -- 0x04 · Address- put BalKey {balanceKey = a} = do- putWord8 0x04- put a- -- 0x04- put BalKeyS = putWord8 0x04- get = do- guard . (== 0x04) =<< getWord8- BalKey <$> get--instance Key BalKey-instance KeyValue BalKey BalVal---- | Key for best block in database.-data BestKey =- BestKey- deriving (Show, Read, Eq, Ord, Generic, Hashable)--instance Serialize BestKey where- -- 0x00 × 32- put BestKey = put (BS.replicate 32 0x00)- get = do- guard . (== BS.replicate 32 0x00) =<< getBytes 32- return BestKey--instance Key BestKey-instance KeyValue BestKey BlockHash---- | Key for database version.-data VersionKey =- VersionKey- deriving (Eq, Show, Read, Ord, Generic, Hashable)--instance Serialize VersionKey where- -- 0x0a- put VersionKey = putWord8 0x0a- get = do- guard . (== 0x0a) =<< getWord8- return VersionKey--instance Key VersionKey-instance KeyValue VersionKey Word32----- | Old mempool transaction database key.-data OldMemKey- = OldMemKey- { memTime :: !UnixTime- , memKey :: !TxHash- }- | OldMemKeyT- { memTime :: !UnixTime- }- | OldMemKeyS- deriving (Show, Read, Eq, Ord, Generic, Hashable)--instance Serialize OldMemKey where- -- 0x07 · UnixTime · TxHash- put (OldMemKey t h) = do- putWord8 0x07- putUnixTime t- put h- -- 0x07 · UnixTime- put (OldMemKeyT t) = do- putWord8 0x07- putUnixTime t- -- 0x07- put OldMemKeyS = putWord8 0x07- get = do- guard . (== 0x07) =<< getWord8- OldMemKey <$> getUnixTime <*> get--instance Key OldMemKey-instance KeyValue OldMemKey ()
− src/Network/Haskoin/Store/Logic.hs
@@ -1,904 +0,0 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}-module Network.Haskoin.Store.Logic where--import Control.Monad (forM, forM_, unless, void, when,- zipWithM_)-import Control.Monad.Except (MonadError, catchError,- throwError)-import Control.Monad.Logger (MonadLogger, logErrorS,- 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, sort)-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.Common (Balance (..), BlockData (..),- BlockRef (..), BlockTx (..),- Prev (..), Spender (..),- StoreInput (..),- StoreOutput (..),- StoreRead (..), StoreWrite (..),- Transaction (..), TxData (..),- UnixTime, Unspent (..),- confirmed, fromTransaction,- isCoinbase, nullBalance,- sortTxs, toTransaction,- transactionData)-import UnliftIO (Exception)--data ImportException- = PrevBlockNotBest !Text- | UnconfirmedCoinbase !Text- | BestBlockUnknown- | BestBlockNotFound !Text- | BlockNotBest !Text- | OrphanTx !Text- | TxNotFound !Text- | NoUnspent !Text- | TxInvalidOp !Text- | TxDeleted !Text- | TxDoubleSpend !Text- | AlreadyUnspent !Text- | TxConfirmed !Text- | OutputOutOfRange !Text- | BalanceNotFound !Text- | InsufficientBalance !Text- | InsufficientZeroBalance !Text- | InsufficientOutputs !Text- | InsufficientFunds !Text- | DuplicatePrevOutput !Text- deriving (Show, Read, Eq, Ord, Exception)--initBest ::- ( StoreRead m- , StoreWrite m- , MonadLogger m- , MonadError ImportException m- )- => Network- -> m ()-initBest net = do- m <- getBestBlock- when- (isNothing m)- (void (importBlock net (genesisBlock net) (genesisNode net)))--getOldOrphans :: StoreRead m => UnixTime -> m [TxHash]-getOldOrphans now =- map (txHash . snd) . filter ((< now - 600) . fst) <$> getOrphans--getOldMempool :: StoreRead m => UnixTime -> m [TxHash]-getOldMempool now =- map blockTxHash . filter ((< now - 3600 * 72) . memRefTime . blockTxBlock) <$>- getMempool--importOrphan ::- ( StoreRead m- , StoreWrite m- , MonadLogger m- , MonadError ImportException m- )- => Network- -> UnixTime- -> Tx- -> m (Maybe [TxHash]) -- ^ deleted transactions or nothing if import failed-importOrphan net t tx = do- go `catchError` ex- where- go = do- maybetxids <-- newMempoolTx net tx t >>= \case- Just ths -> return (Just ths)- Nothing -> return Nothing- deleteOrphanTx (txHash tx)- return maybetxids- ex (OrphanTx _) = do- return Nothing- ex _ = do- $(logWarnS) "BlockStore" $- "Deleted bad orphan tx: " <> txHashToHex (txHash tx)- deleteOrphanTx (txHash tx)- return Nothing--newMempoolTx ::- ( StoreRead m- , StoreWrite m- , MonadLogger m- , MonadError ImportException m- )- => Network- -> Tx- -> UnixTime- -> m (Maybe [TxHash]) -- ^ deleted transactions or nothing if import failed-newMempoolTx net tx w =- getTxData (txHash tx) >>= \case- Just x- | not (txDataDeleted x) -> return Nothing- _ -> go- where- go = do- orp <-- any isNothing <$>- mapM (getTxData . outPointHash . prevOutput) (txIn tx)- if orp- then do- $(logWarnS) "BlockStore" $ "Orphan tx: " <> txHashToHex (txHash tx)- insertOrphanTx tx w- throwError $ OrphanTx (txHashToHex (txHash tx))- else f- f = do- us <-- forM (txIn tx) $ \TxIn {prevOutput = op} -> do- t <- getImportTx (outPointHash op)- getTxOutput (outPointIndex op) t- let ds = map spenderHash (mapMaybe outputSpender us)- if null ds- then do- ths <- importTx net (MemRef w) w tx- return (Just ths)- else g ds- g ds = do- rbf <-- if getReplaceByFee net- then and <$> mapM isrbf ds- else return False- if rbf- then r ds- else n- r ds = do- $(logWarnS) "BlockStore" $ "Replace by fee tx: " <> txHashToHex (txHash tx)- ths <- concat <$> forM ds (deleteTx net True)- dts <- importTx net (MemRef w) w tx- return (Just (nub (ths <> dts)))- n = do- $(logWarnS) "BlockStore" $ "Conflicting tx: " <> txHashToHex (txHash tx)- insertDeletedMempoolTx tx w- return Nothing- isrbf th = transactionRBF <$> getImportTx th--revertBlock ::- ( StoreRead m- , StoreWrite m- , MonadLogger m- , MonadError ImportException m- )- => Network- -> BlockHash- -> m [TxHash]-revertBlock net bh = do- bd <-- getBestBlock >>= \case- Nothing -> do- $(logErrorS) "BlockStore" "Best block unknown"- throwError BestBlockUnknown- Just h ->- getBlock h >>= \case- Nothing -> do- $(logErrorS) "BlockStore" "Best block not found"- throwError (BestBlockNotFound (blockHashToHex h))- Just b- | h == bh -> return b- | otherwise -> do- $(logErrorS) "BlockStore" $- "Cannot delete block that is not head: " <>- blockHashToHex h- throwError (BlockNotBest (blockHashToHex bh))- txs <- mapM (fmap transactionData . getImportTx) (blockDataTxs bd)- 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- , StoreWrite m- , MonadLogger m- , MonadError ImportException m- )- => Network- -> Block- -> BlockNode- -> m [TxHash] -- ^ deleted transactions-importBlock net b n = do- mp <- filter (`elem` bths) . map blockTxHash <$> getMempool- getBestBlock >>= \case- Nothing- | isGenesis n -> return ()- | otherwise -> do- $(logErrorS) "BlockStore" $- "Cannot import non-genesis block at this point: " <>- blockHashToHex (headerHash (blockHeader b))- throwError BestBlockUnknown- Just h- | prevBlock (blockHeader b) == h -> return ()- | otherwise -> do- $(logErrorS) "BlockStore" $- "Block does not build on head: " <>- blockHashToHex (headerHash (blockHeader b))- throwError $- PrevBlockNotBest (blockHashToHex (prevBlock (nodeHeader n)))- insertBlock- BlockData- { blockDataHeight = nodeHeight n- , blockDataMainChain = True- , blockDataWork = nodeWork n- , blockDataHeader = nodeHeader n- , blockDataSize = fromIntegral (B.length (encode b))- , blockDataTxs = map txHash (blockTxns b)- , blockDataWeight = fromIntegral w- , blockDataSubsidy = subsidy (nodeHeight n)- , blockDataFees = cb_out_val - subsidy (nodeHeight n)- , blockDataOutputs = ts_out_val- }- bs <- getBlocksAtHeight (nodeHeight n)- setBlocksAtHeight (nub (headerHash (nodeHeader n) : bs)) (nodeHeight n)- setBest (headerHash (nodeHeader n))- ths <-- nub . concat <$>- mapM (uncurry (import_or_confirm mp)) (sortTxs (blockTxns b))- 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 >> return []- Nothing -> do- $(logErrorS) "BlockStore" $- "Cannot get data for mempool tx: " <>- txHashToHex (txHash tx)- throwError $ TxNotFound (txHashToHex (txHash tx))- else importTx- net- (br x)- (fromIntegral (blockTimestamp (nodeHeader n)))- tx- subsidy = computeSubsidy net- cb_out_val = sum (map outValue (txOut (head (blockTxns b))))- ts_out_val = sum (map (sum . map outValue . txOut) (tail (blockTxns b)))- br pos = BlockRef {blockRefHeight = nodeHeight n, blockRefPos = pos}- w =- let s =- B.length- (encode- b- { blockTxns =- map (\t -> t {txWitness = []}) (blockTxns b)- })- x = B.length (encode b)- in s * 3 + x--importTx ::- ( StoreRead m- , StoreWrite m- , MonadLogger m- , MonadError ImportException m- )- => Network- -> BlockRef- -> Word64 -- ^ unix time- -> Tx- -> m [TxHash] -- ^ deleted transactions-importTx net br tt tx = do- when (length (nub (map prevOutput (txIn tx))) < length (txIn tx)) $ do- $(logErrorS) "BlockStore" $- "Transaction spends same output twice: " <> txHashToHex (txHash tx)- throwError (DuplicatePrevOutput (txHashToHex (txHash tx)))- when (iscb && not (confirmed br)) $ do- $(logErrorS) "BlockStore" $- "Coinbase cannot be imported into mempool: " <>- txHashToHex (txHash tx)- throwError (UnconfirmedCoinbase (txHashToHex (txHash tx)))- 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- $(logErrorS) "BlockStore" $- "Insufficient funds for tx: " <> txHashToHex (txHash tx)- throwError (InsufficientFunds (txHashToHex th))- zipWithM_ (spendOutput net br (txHash tx)) [0 ..] us- zipWithM_- (\i o -> newOutput net br (OutPoint (txHash tx) i) o)- [0 ..]- (txOut tx)- rbf <- getrbf- let t =- Transaction- { transactionBlock = br- , transactionVersion = txVersion tx- , transactionLockTime = txLockTime tx- , transactionInputs =- if iscb- then zipWith mkcb (txIn tx) ws- else zipWith3 mkin us (txIn tx) ws- , transactionOutputs = map mkout (txOut tx)- , transactionDeleted = False- , transactionRBF = rbf- , transactionTime = tt- }- let (d, _) = fromTransaction t- 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, [])- Nothing -> do- $(logWarnS) "BlockStore" $- "Unspent output not found: " <>- txHashToHex (outPointHash op) <>- " " <>- fromString (show (outPointIndex op))- getSpender op >>= \case- Nothing -> do- $(logErrorS) "BlockStore" $- "Output not found: " <>- txHashToHex (outPointHash op) <>- " " <>- fromString (show (outPointIndex op))- throwError (NoUnspent (cs (show op)))- Just Spender {spenderHash = s} -> do- ths <- deleteTx net True s- getUnspent op >>= \case- Nothing -> do- $(logErrorS) "BlockStore" $- "Cannot unspend output: " <>- txHashToHex (outPointHash op) <>- " " <>- fromString (show (outPointIndex op))- throwError (NoUnspent (cs (show op)))- Just u -> return (u, ths)- th = txHash tx- iscb = all (== nullOutPoint) (map prevOutput (txIn tx))- ws = map Just (txWitness tx) <> repeat Nothing- getrbf- | iscb = return False- | any ((< 0xffffffff - 1) . txInSequence) (txIn tx) = return True- | confirmed br = return False- | otherwise =- let hs = nub $ map (outPointHash . prevOutput) (txIn tx)- in fmap or . forM hs $ \h ->- getTxData h >>= \case- Nothing -> throwError (TxNotFound (txHashToHex h))- Just t- | confirmed (txDataBlock t) -> return False- | txDataRBF t -> return True- | otherwise -> return False- mkcb ip w =- StoreCoinbase- { inputPoint = prevOutput ip- , inputSequence = txInSequence ip- , inputSigScript = scriptInput ip- , inputWitness = w- }- mkin u ip w =- StoreInput- { inputPoint = prevOutput ip- , inputSequence = txInSequence ip- , inputSigScript = scriptInput ip- , inputPkScript = B.Short.fromShort (unspentScript u)- , inputAmount = unspentAmount u- , inputWitness = w- }- mkout o =- StoreOutput- { outputAmount = outValue o- , outputScript = scriptOutput o- , outputSpender = Nothing- }--confirmTx ::- ( StoreRead m- , StoreWrite m- , MonadLogger m- , MonadError ImportException m- )- => Network- -> TxData- -> BlockRef- -> Tx- -> m ()-confirmTx net t br tx = do- forM_ (txDataPrevs t) $ \p ->- case scriptToAddressBS (prevScript p) of- Left _ -> return ()- Right a -> do- deleteAddrTx- a- BlockTx- {blockTxBlock = txDataBlock t, blockTxHash = txHash tx}- insertAddrTx- a- BlockTx {blockTxBlock = br, blockTxHash = txHash tx}- forM_ (zip [0 ..] (txOut tx)) $ \(n, o) -> do- let op = OutPoint (txHash tx) n- s <- getSpender (OutPoint (txHash tx) n)- when (isNothing s) $ do- deleteUnspent op- insertUnspent- Unspent- { unspentBlock = br- , unspentPoint = op- , unspentAmount = outValue o- , unspentScript = B.Short.toShort (scriptOutput o)- }- case scriptToAddressBS (scriptOutput o) of- Left _ -> return ()- Right a -> do- deleteAddrTx- a- BlockTx- {blockTxBlock = txDataBlock t, blockTxHash = txHash tx}- insertAddrTx- a- BlockTx {blockTxBlock = br, blockTxHash = txHash tx}- when (isNothing s) $ do- deleteAddrUnspent- a- Unspent- { unspentBlock = txDataBlock t- , unspentPoint = op- , unspentAmount = outValue o- , unspentScript = B.Short.toShort (scriptOutput o)- }- insertAddrUnspent- a- Unspent- { unspentBlock = br- , unspentPoint = op- , unspentAmount = outValue o- , unspentScript = B.Short.toShort (scriptOutput o)- }- reduceBalance net False False a (outValue o)- increaseBalance True False a (outValue o)- insertTx t {txDataBlock = br}- deleteFromMempool (txHash tx)--getRecursiveTx ::- (Monad m, StoreRead m, MonadLogger m) => TxHash -> m [Transaction]-getRecursiveTx th =- getTxData th >>= \case- Nothing -> return []- Just d -> do- sm <- getSpenders th- let t = toTransaction d sm- fmap (t :) $ do- let ss = nub . map spenderHash $ I.elems sm- concat <$> mapM getRecursiveTx ss--deleteFromMempool :: (Monad m, StoreRead m, StoreWrite m) => TxHash -> m ()-deleteFromMempool th = do- mp <- getMempool- setMempool $ filter ((/= th) . blockTxHash) mp--insertIntoMempool :: (Monad m, StoreRead m, StoreWrite m) => TxHash -> UnixTime -> m ()-insertIntoMempool th unixtime = do- mp <- getMempool- setMempool . reverse . sort $- BlockTx {blockTxBlock = MemRef unixtime, blockTxHash = th} : mp--deleteTx ::- ( StoreRead m- , StoreWrite m- , MonadLogger m- , MonadError ImportException m- )- => Network- -> Bool -- ^ only delete transaction if unconfirmed- -> TxHash- -> m [TxHash] -- ^ deleted transactions-deleteTx net mo h = do- getTxData h >>= \case- Nothing -> do- $(logErrorS) "BlockStore" $ "Cannot find tx to delete: " <> txHashToHex h- throwError (TxNotFound (txHashToHex h))- Just t- | txDataDeleted t -> do- $(logWarnS) "BlockStore" $ "Already deleted tx: " <> txHashToHex h- return []- | mo && confirmed (txDataBlock t) -> do- $(logErrorS) "BlockStore" $- "Will not delete confirmed tx: " <> txHashToHex h- throwError (TxConfirmed (txHashToHex h))- | otherwise -> go t- where- go t = do- ss <- nub . map spenderHash . I.elems <$> getSpenders h- 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)))- mapM_ (unspendOutput net) ps- unless (confirmed (txDataBlock t)) $ deleteFromMempool h- insertTx t {txDataDeleted = True}- updateAddressCounts net (txDataAddresses t) (subtract 1)- return $ nub (h : ths)--insertDeletedMempoolTx ::- ( StoreRead m- , StoreWrite m- , MonadLogger m- , MonadError ImportException m- )- => Tx- -> UnixTime- -> m ()-insertDeletedMempoolTx tx w = do- us <-- forM (txIn tx) $ \TxIn {prevOutput = op} ->- getImportTx (outPointHash op) >>= getTxOutput (outPointIndex op)- rbf <- getrbf- let (d, _) =- fromTransaction- Transaction- { transactionBlock = MemRef w- , transactionVersion = txVersion tx- , transactionLockTime = txLockTime tx- , transactionInputs = zipWith3 mkin us (txIn tx) ws- , transactionOutputs = map mkout (txOut tx)- , transactionDeleted = True- , transactionRBF = rbf- , transactionTime = w- }- insertTx d- where- ws = map Just (txWitness tx) <> repeat Nothing- getrbf- | any ((< 0xffffffff - 1) . txInSequence) (txIn tx) = return True- | otherwise =- let hs = nub $ map (outPointHash . prevOutput) (txIn tx)- in fmap or . forM hs $ \h ->- getTxData h >>= \case- Nothing -> do- $(logErrorS) "BlockStore" $- "Tx not found: " <> txHashToHex h- throwError (TxNotFound (txHashToHex h))- Just t- | confirmed (txDataBlock t) -> return False- | txDataRBF t -> return True- | otherwise -> return False- mkin u ip wit =- StoreInput- { inputPoint = prevOutput ip- , inputSequence = txInSequence ip- , inputSigScript = scriptInput ip- , inputPkScript = outputScript u- , inputAmount = outputAmount u- , inputWitness = wit- }- mkout o =- StoreOutput- { outputAmount = outValue o- , outputScript = scriptOutput o- , outputSpender = Nothing- }--newOutput ::- ( StoreRead m- , StoreWrite m- , MonadLogger m- )- => Network- -> BlockRef- -> OutPoint- -> TxOut- -> m ()-newOutput _ br op to = do- insertUnspent u- case scriptToAddressBS (scriptOutput to) of- Left _ -> return ()- Right a -> do- insertAddrUnspent a u- insertAddrTx- a- BlockTx {blockTxHash = outPointHash op, blockTxBlock = br}- increaseBalance (confirmed br) True a (outValue to)- where- u =- Unspent- { unspentBlock = br- , unspentAmount = outValue to- , unspentScript = B.Short.toShort (scriptOutput to)- , unspentPoint = op- }--delOutput ::- ( StoreRead m- , StoreWrite m- , MonadLogger m- , MonadError ImportException m- )- => Network- -> OutPoint- -> m ()-delOutput net op = do- t <- getImportTx (outPointHash op)- u <- getTxOutput (outPointIndex op) t- deleteUnspent op- case scriptToAddressBS (outputScript u) of- Left _ -> return ()- Right a -> do- deleteAddrUnspent- a- Unspent- { unspentScript = B.Short.toShort (outputScript u)- , unspentBlock = transactionBlock t- , unspentPoint = op- , unspentAmount = outputAmount u- }- deleteAddrTx- a- BlockTx- { blockTxHash = outPointHash op- , blockTxBlock = transactionBlock t- }- reduceBalance- net- (confirmed (transactionBlock t))- True- a- (outputAmount u)--getImportTx ::- (StoreRead m, MonadLogger m, MonadError ImportException m)- => TxHash- -> m Transaction-getImportTx th =- getTxData th >>= \case- Nothing -> do- $(logErrorS) "BlockStore" $ "Tx not found: " <> txHashToHex th- throwError $ TxNotFound (txHashToHex th)- Just d- | txDataDeleted d -> do- $(logErrorS) "BlockStore" $ "Tx deleted: " <> txHashToHex th- throwError $ TxDeleted (txHashToHex th)- | otherwise -> do- sm <- getSpenders th- return $ toTransaction d sm--getTxOutput ::- (MonadLogger m, MonadError ImportException m)- => Word32- -> Transaction- -> m StoreOutput-getTxOutput i tx = do- unless (fromIntegral i < length (transactionOutputs tx)) $ do- $(logErrorS) "BlockStore" $- "Output out of range: " <> txHashToHex (txHash (transactionData tx)) <>- " " <>- fromString (show i)- throwError . OutputOutOfRange . cs $- show- OutPoint- { outPointHash = txHash (transactionData tx)- , outPointIndex = i- }- return $ transactionOutputs tx !! fromIntegral i--spendOutput ::- ( StoreRead m- , StoreWrite m- , MonadLogger m- , MonadError ImportException m- )- => Network- -> BlockRef- -> TxHash- -> Word32- -> Unspent- -> m ()-spendOutput net br th ix u = do- insertSpender (unspentPoint u) Spender {spenderHash = th, spenderIndex = ix}- case scriptToAddressBS (B.Short.fromShort (unspentScript u)) of- Left _ -> return ()- Right a -> do- reduceBalance- net- (confirmed (unspentBlock u))- False- a- (unspentAmount u)- deleteAddrUnspent a u- insertAddrTx a BlockTx {blockTxHash = th, blockTxBlock = br}- deleteUnspent (unspentPoint u)--unspendOutput ::- ( StoreRead m- , StoreWrite m- , MonadLogger m- , MonadError ImportException m- )- => Network- -> OutPoint- -> m ()-unspendOutput _ op = do- t <- getImportTx (outPointHash op)- o <- getTxOutput (outPointIndex op) t- s <-- case outputSpender o of- Nothing -> do- $(logErrorS) "BlockStore" $- "Output already unspent: " <> txHashToHex (outPointHash op) <>- " " <>- fromString (show (outPointIndex op))- throwError (AlreadyUnspent (cs (show op)))- Just s -> return s- x <- getImportTx (spenderHash s)- deleteSpender op- let u =- Unspent- { unspentAmount = outputAmount o- , unspentBlock = transactionBlock t- , unspentScript = B.Short.toShort (outputScript o)- , unspentPoint = op- }- insertUnspent u- case scriptToAddressBS (outputScript o) of- Left _ -> return ()- Right a -> do- insertAddrUnspent a u- deleteAddrTx- a- BlockTx- { blockTxHash = spenderHash s- , blockTxBlock = transactionBlock x- }- increaseBalance- (confirmed (unspentBlock u))- False- a- (outputAmount o)--reduceBalance ::- ( StoreRead m- , StoreWrite m- , MonadLogger m- , MonadError ImportException m- )- => Network- -> Bool -- ^ spend or delete confirmed output- -> Bool -- ^ reduce total received- -> Address- -> Word64- -> m ()-reduceBalance net c t a v =- getBalance a >>= \b ->- if nullBalance b- then do- $(logErrorS) "BlockStore" $- "Address balance not found: " <> addrText net a- throwError (BalanceNotFound (addrText net a))- else do- when (v > amnt b) $ do- $(logErrorS) "BlockStore" $- "Insufficient " <> conf <> " balance: " <>- addrText net a <>- " (needs: " <>- cs (show v) <>- ", has: " <>- cs (show (amnt b)) <>- ")"- throwError $- if c- then InsufficientBalance (addrText net a)- else InsufficientZeroBalance (addrText net a)- setBalance- b- { balanceAmount =- balanceAmount b -- if c- then v- else 0- , balanceZero =- balanceZero b -- if c- then 0- else v- , balanceUnspentCount = balanceUnspentCount b - 1- , balanceTotalReceived =- balanceTotalReceived b -- if t- then v- else 0- }- where- amnt =- if c- then balanceAmount- else balanceZero- conf =- if c- then "confirmed"- else "unconfirmed"--increaseBalance ::- ( StoreRead m- , StoreWrite m- , MonadLogger m- )- => Bool -- ^ add confirmed output- -> Bool -- ^ increase total received- -> Address- -> Word64- -> m ()-increaseBalance c t a v = do- b <- getBalance a- setBalance- b- { balanceAmount =- balanceAmount b +- if c- then v- else 0- , balanceZero =- balanceZero b +- if c- then 0- else v- , balanceUnspentCount = balanceUnspentCount b + 1- , balanceTotalReceived =- balanceTotalReceived b +- if t- then v- else 0- }--updateAddressCounts ::- (StoreWrite m, StoreRead m, Monad m, MonadError ImportException m)- => Network- -> [Address]- -> (Word64 -> Word64)- -> m ()-updateAddressCounts net as f =- forM_ as $ \a -> do- b <-- getBalance a >>= \b -> if nullBalance b- then throwError (BalanceNotFound (addrText net a))- else return b- setBalance b {balanceTxCount = f (balanceTxCount b)}--txAddresses :: Transaction -> [Address]-txAddresses t =- nub . rights $- map (scriptToAddressBS . inputPkScript)- (filter (not . isCoinbase) (transactionInputs t)) <>- map (scriptToAddressBS . outputScript) (transactionOutputs t)--txDataAddresses :: TxData -> [Address]-txDataAddresses t =- nub . rights $- map (scriptToAddressBS . prevScript) (I.elems (txDataPrevs t)) <>- map (scriptToAddressBS . scriptOutput) (txOut (txData t))--addrText :: Network -> Address -> Text-addrText net a = fromMaybe "???" $ addrToString net a
− src/Network/Haskoin/Store/Web.hs
@@ -1,1203 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TemplateHaskell #-}-module Network.Haskoin.Store.Web where--import Conduit ()-import Control.Applicative ((<|>))-import Control.Monad (forever, guard,- mzero, unless, when,- (<=<))-import Control.Monad.Logger (Loc, LogLevel,- LogSource, LogStr,- MonadLogger,- MonadLoggerIO,- askLoggerIO,- logInfoS,- monadLoggerLog)-import Control.Monad.Reader (ReaderT, asks,- runReaderT)-import Control.Monad.Trans (lift)-import Control.Monad.Trans.Maybe (MaybeT (..),- runMaybeT)-import Data.Aeson (ToJSON (..), object,- (.=))-import Data.Aeson.Encoding (encodingToLazyByteString)-import qualified Data.ByteString as B-import Data.ByteString.Builder (lazyByteString)-import qualified Data.ByteString.Lazy as L-import qualified Data.ByteString.Lazy.Char8 as C-import Data.Char (isSpace)-import Data.List (nub)-import Data.Maybe (catMaybes,- fromMaybe, isJust,- 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 (..),- Message (..),- Network (..),- OutPoint (..), Tx,- TxHash (..),- VarString (..),- Version (..),- decodeHex,- eitherToMaybe,- headerHash,- hexToBlockHash,- hexToTxHash,- sockToHostAddress,- stringToAddr,- txHash, xPubImport)-import Haskoin.Node (Chain, Manager,- OnlinePeer (..),- chainGetBest,- managerGetPeers,- sendMessage)-import Network.Haskoin.Store.Common (BinSerial (..),- BlockData (..),- BlockRef (..),- BlockTx (..),- DeriveType (..),- Event (..),- HealthCheck (..),- JsonSerial (..),- Limit, Offset,- PeerInformation (..),- PubExcept (..),- Store (..),- StoreEvent (..),- StoreInput (..),- StoreRead (..),- Transaction (..),- TxAfterHeight (..),- TxData (..),- TxId (..), UnixTime,- Unspent,- XPubBal (..),- XPubSpec (..),- applyOffset,- blockAtOrBefore,- getTransaction,- isCoinbase,- nullBalance,- transactionData)-import Network.Haskoin.Store.Data.CacheReader (CacheReaderConfig,- CacheReaderT,- withCacheReader)-import Network.Haskoin.Store.Data.DatabaseReader (DatabaseReader (..),- DatabaseReaderT,- withDatabaseReader)-import Network.HTTP.Types (Status (..),- status400,- status403,- 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, MonadIO,- MonadUnliftIO,- askRunInIO, liftIO,- timeout)-import Web.Scotty.Internal.Types (ActionT)-import Web.Scotty.Trans (Parsable,- ScottyError)-import qualified Web.Scotty.Trans as S--type LoggerIO = Loc -> LogSource -> LogLevel -> LogStr -> IO ()--type WebT m = ActionT Except (ReaderT WebConfig m)--data Except- = ThingNotFound- | ServerError- | BadRequest- | UserError String- | StringError String- | BlockTooLarge- deriving Eq--instance Show Except where- show ThingNotFound = "not found"- show ServerError = "you made me kill a unicorn"- show BadRequest = "bad request"- show (UserError s) = s- show (StringError _) = "you killed the dragon with your bare hands"- show BlockTooLarge = "block too large"--instance Exception Except--instance ScottyError Except where- stringError = StringError- showError = T.Lazy.pack . show--instance ToJSON Except where- toJSON e = object ["error" .= T.pack (show e)]--instance JsonSerial Except where- jsonSerial _ = toEncoding- jsonValue _ = toJSON--instance BinSerial Except where- binSerial _ ex =- case ex of- ThingNotFound -> putWord8 0- ServerError -> putWord8 1- BadRequest -> putWord8 2- UserError s -> putWord8 3 >> Serialize.put s- StringError s -> putWord8 4 >> Serialize.put s- BlockTooLarge -> putWord8 5- binDeserial _ =- getWord8 >>= \case- 0 -> return ThingNotFound- 1 -> return ServerError- 2 -> return BadRequest- 3 -> UserError <$> Serialize.get- 4 -> StringError <$> Serialize.get- _ -> mzero--data WebConfig =- WebConfig- { webPort :: !Int- , webNetwork :: !Network- , webDB :: !DatabaseReader- , webCache :: !(Maybe CacheReaderConfig)- , webPublisher :: !(Publisher StoreEvent)- , webStore :: !Store- , webMaxLimits :: !MaxLimits- , webReqLog :: !Bool- , webTimeouts :: !Timeouts- }--data MaxLimits =- MaxLimits- { maxLimitCount :: !Word32- , maxLimitFull :: !Word32- , maxLimitOffset :: !Word32- , maxLimitDefault :: !Word32- , maxLimitGap :: !Word32- }- deriving (Eq, Show)--data Timeouts =- Timeouts- { txTimeout :: !Word64- , blockTimeout :: !Word64- }- deriving (Eq, Show)--newtype MyBlockHash = MyBlockHash {myBlockHash :: BlockHash}-newtype MyTxHash = MyTxHash {myTxHash :: TxHash}--instance Parsable MyBlockHash where- parseParam =- maybe (Left "could not decode block hash") (Right . MyBlockHash) . hexToBlockHash . cs--instance Parsable MyTxHash where- parseParam =- maybe (Left "could not decode tx hash") (Right . MyTxHash) . hexToTxHash . cs--data StartParam- = StartParamHash- { startParamHash :: !Hash256}- | StartParamHeight- { startParamHeight :: !Word32}- | StartParamTime- { startParamTime :: !UnixTime}--instance Parsable StartParam where- parseParam s = maybe (Left "could not decode start") Right (h <|> g <|> t)- where- h = do- x <- fmap B.reverse (decodeHex (cs s)) >>= eitherToMaybe . decode- return StartParamHash {startParamHash = x}- g = do- x <- readMaybe (cs s) :: Maybe Integer- guard $ 0 <= x && x <= 1230768000- return StartParamHeight {startParamHeight = fromIntegral x}- t = do- x <- readMaybe (cs s)- guard $ x > 1230768000- return StartParamTime {startParamTime = x}--runInWebReader ::- MonadIO m- => DatabaseReaderT m a- -> CacheReaderT (DatabaseReaderT m) a- -> ReaderT WebConfig m a-runInWebReader bf cf = do- bdb <- asks webDB- mc <- asks webCache- lift $ withDatabaseReader bdb $- case mc of- Nothing -> bf- Just c -> withCacheReader c cf--instance MonadLoggerIO m => StoreRead (ReaderT WebConfig m) where- getBestBlock = runInWebReader getBestBlock getBestBlock- getBlocksAtHeight height =- runInWebReader (getBlocksAtHeight height) (getBlocksAtHeight height)- getBlock bh = runInWebReader (getBlock bh) (getBlock bh)- getTxData th = runInWebReader (getTxData th) (getTxData th)- getSpender op = runInWebReader (getSpender op) (getSpender op)- getSpenders th = runInWebReader (getSpenders th) (getSpenders th)- getOrphanTx th = runInWebReader (getOrphanTx th) (getOrphanTx th)- getUnspent op = runInWebReader (getUnspent op) (getUnspent op)- getBalance a = runInWebReader (getBalance a) (getBalance a)- getBalances as = runInWebReader (getBalances as) (getBalances as)- getMempool = runInWebReader getMempool getMempool- getAddressesTxs addrs start limit =- runInWebReader- (getAddressesTxs addrs start limit)- (getAddressesTxs addrs start limit)- getAddressesUnspents addrs start limit =- runInWebReader- (getAddressesUnspents addrs start limit)- (getAddressesUnspents addrs start limit)- getOrphans = runInWebReader getOrphans getOrphans- xPubBals xpub = runInWebReader (xPubBals xpub) (xPubBals xpub)- xPubSummary xpub =- runInWebReader (xPubSummary xpub) (xPubSummary xpub)- xPubUnspents xpub start offset limit =- runInWebReader- (xPubUnspents xpub start offset limit)- (xPubUnspents xpub start offset limit)- xPubTxs xpub start offset limit =- runInWebReader- (xPubTxs xpub start offset limit)- (xPubTxs xpub start offset limit)--instance MonadLoggerIO m => StoreRead (WebT m) where- getBestBlock = lift getBestBlock- getBlocksAtHeight = lift . getBlocksAtHeight- getBlock = lift . getBlock- getTxData = lift . getTxData- getSpender = lift . getSpender- getSpenders = lift . getSpenders- 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)- getOrphans = lift getOrphans- xPubBals = lift . xPubBals- xPubSummary = lift . xPubSummary- xPubUnspents xpub start offset limit =- lift (xPubUnspents xpub start offset limit)- xPubTxs xpub start offset limit = lift (xPubTxs xpub start offset limit)- getMaxGap = lift $ asks (maxLimitGap . webMaxLimits)--defHandler :: Monad m => Except -> WebT m ()-defHandler e = do- proto <- setupBin- case e of- ThingNotFound -> S.status status404- BadRequest -> S.status status400- UserError _ -> S.status status400- StringError _ -> S.status status400- ServerError -> S.status status500- BlockTooLarge -> S.status status403- protoSerial proto e--maybeSerial ::- (Monad m, JsonSerial a, BinSerial a)- => Bool -- ^ binary- -> Maybe a- -> WebT m ()-maybeSerial _ Nothing = S.raise ThingNotFound-maybeSerial proto (Just x) =- lift (asks webNetwork) >>= \net -> S.raw (serialAny net proto x)--protoSerial ::- (Monad m, JsonSerial a, BinSerial a)- => Bool- -> a- -> WebT m ()-protoSerial proto x =- lift (asks webNetwork) >>= \net -> S.raw (serialAny net proto x)--scottyBestBlock ::- (MonadLoggerIO m, MonadIO m) => Bool -> WebT m ()-scottyBestBlock raw = do- limits <- lift $ asks webMaxLimits- setHeaders- n <- parseNoTx- proto <- setupBin- bm <-- runMaybeT $ do- h <- MaybeT getBestBlock- MaybeT $ getBlock h- b <-- case bm of- Nothing -> S.raise ThingNotFound- Just b -> return b- if raw- then do- refuseLargeBlock limits b- rawBlock b >>= protoSerial proto- else protoSerial proto (pruneTx n b)--scottyBlock :: MonadLoggerIO m => Bool -> WebT m ()-scottyBlock raw = do- limits <- lift $ asks webMaxLimits- setHeaders- block <- myBlockHash <$> S.param "block"- n <- parseNoTx- proto <- setupBin- b <-- getBlock block >>= \case- Nothing -> S.raise ThingNotFound- Just b -> return b- if raw- then do- refuseLargeBlock limits b- rawBlock b >>= protoSerial proto- else protoSerial proto (pruneTx n b)--scottyBlockHeight ::- MonadLoggerIO m => Bool -> WebT m ()-scottyBlockHeight raw = do- limits <- lift $ asks webMaxLimits- setHeaders- height <- S.param "height"- n <- parseNoTx- proto <- setupBin- hs <- getBlocksAtHeight height- if raw- then do- blocks <- catMaybes <$> mapM getBlock hs- mapM_ (refuseLargeBlock limits) blocks- rawblocks <- mapM rawBlock blocks- protoSerial proto rawblocks- else do- blocks <- catMaybes <$> mapM getBlock hs- let blocks' = map (pruneTx n) blocks- protoSerial proto blocks'--scottyBlockTime :: MonadLoggerIO m => Bool -> WebT m ()-scottyBlockTime raw = do- limits <- lift $ asks webMaxLimits- setHeaders- q <- S.param "time"- n <- parseNoTx- proto <- setupBin- m <- fmap (pruneTx n) <$> blockAtOrBefore q- if raw- then maybeSerial proto =<<- case m of- Nothing -> return Nothing- Just d -> do- refuseLargeBlock limits d- Just <$> rawBlock d- else maybeSerial proto m--scottyBlockHeights :: MonadLoggerIO m => WebT m ()-scottyBlockHeights = do- setHeaders- heights <- S.param "heights"- n <- parseNoTx- proto <- setupBin- bhs <- concat <$> mapM getBlocksAtHeight (heights :: [BlockHeight])- blocks <- map (pruneTx n) . catMaybes <$> mapM getBlock bhs- protoSerial proto blocks--scottyBlockLatest :: MonadLoggerIO m => WebT m ()-scottyBlockLatest = do- setHeaders- n <- parseNoTx- proto <- setupBin- getBestBlock >>= \case- Just h -> do- blocks <- reverse <$> go 100 n h- protoSerial proto blocks- Nothing -> S.raise ThingNotFound- where- go 0 _ _ = return []- go i n h =- getBlock h >>= \case- Nothing -> return []- Just b ->- let b' = pruneTx n b- i' = i - 1 :: Int- prev = prevBlock (blockDataHeader b)- in if blockDataHeight b <= 0- then return []- else (b' :) <$> go i' n prev---scottyBlocks :: MonadLoggerIO m => WebT m ()-scottyBlocks = do- setHeaders- bhs <- map myBlockHash <$> S.param "blocks"- n <- parseNoTx- proto <- setupBin- bks <- map (pruneTx n) . catMaybes <$> mapM getBlock (nub bhs)- protoSerial proto bks--scottyMempool :: MonadLoggerIO m => WebT m ()-scottyMempool = do- setHeaders- proto <- setupBin- txs <- map blockTxHash <$> getMempool- protoSerial proto txs--scottyTransaction :: MonadLoggerIO m => WebT m ()-scottyTransaction = do- setHeaders- txid <- myTxHash <$> S.param "txid"- proto <- setupBin- res <- getTransaction txid- maybeSerial proto res--scottyRawTransaction :: MonadLoggerIO m => WebT m ()-scottyRawTransaction = do- setHeaders- txid <- myTxHash <$> S.param "txid"- proto <- setupBin- res <- fmap transactionData <$> getTransaction txid- maybeSerial proto res--scottyTxAfterHeight :: MonadLoggerIO m => WebT m ()-scottyTxAfterHeight = do- setHeaders- txid <- myTxHash <$> S.param "txid"- height <- S.param "height"- proto <- setupBin- res <- cbAfterHeight 10000 height txid- protoSerial proto res--scottyTransactions :: MonadLoggerIO m => WebT m ()-scottyTransactions = do- setHeaders- txids <- map myTxHash <$> S.param "txids"- proto <- setupBin- txs <- catMaybes <$> mapM getTransaction (nub txids)- protoSerial proto txs--scottyBlockTransactions :: MonadLoggerIO m => WebT m ()-scottyBlockTransactions = do- limits <- lift $ asks webMaxLimits- setHeaders- h <- myBlockHash <$> S.param "block"- proto <- setupBin- getBlock h >>= \case- Just b -> do- refuseLargeBlock limits b- let ths = blockDataTxs b- txs <- catMaybes <$> mapM getTransaction ths- protoSerial proto txs- Nothing -> S.raise ThingNotFound--scottyRawTransactions ::- MonadLoggerIO m => WebT m ()-scottyRawTransactions = do- setHeaders- txids <- map myTxHash <$> S.param "txids"- proto <- setupBin- txs <- map transactionData . catMaybes <$> mapM getTransaction (nub txids)- protoSerial proto txs--rawBlock :: (Monad m, StoreRead m) => BlockData -> m Block-rawBlock b = do- let h = blockDataHeader b- ths = blockDataTxs b- txs <- map transactionData . catMaybes <$> mapM getTransaction ths- return Block {blockHeader = h, blockTxns = txs}--scottyRawBlockTransactions ::- MonadLoggerIO m => WebT m ()-scottyRawBlockTransactions = do- limits <- lift $ asks webMaxLimits- setHeaders- h <- myBlockHash <$> S.param "block"- proto <- setupBin- getBlock h >>= \case- Just b -> do- refuseLargeBlock limits b- let ths = blockDataTxs b- txs <- map transactionData . catMaybes <$> mapM getTransaction ths- protoSerial proto txs- Nothing -> S.raise ThingNotFound--scottyAddressTxs :: MonadLoggerIO m => Bool -> WebT m ()-scottyAddressTxs full = do- setHeaders- a <- parseAddress- s <- getStart- o <- getOffset- l <- getLimit full- proto <- setupBin- if full- then do- getAddressTxsFull o l s a >>= protoSerial proto- else do- getAddressTxsLimit o l s a >>= protoSerial proto--scottyAddressesTxs ::- MonadLoggerIO m => Bool -> WebT m ()-scottyAddressesTxs full = do- setHeaders- as <- parseAddresses- s <- getStart- l <- getLimit full- proto <- setupBin- if full- then getAddressesTxsFull l s as >>= protoSerial proto- else getAddressesTxsLimit l s as >>= protoSerial proto--scottyAddressUnspent :: MonadLoggerIO m => WebT m ()-scottyAddressUnspent = do- setHeaders- a <- parseAddress- s <- getStart- o <- getOffset- l <- getLimit False- proto <- setupBin- uns <- getAddressUnspentsLimit o l s a- protoSerial proto uns--scottyAddressesUnspent :: MonadLoggerIO m => WebT m ()-scottyAddressesUnspent = do- setHeaders- as <- parseAddresses- s <- getStart- l <- getLimit False- proto <- setupBin- uns <- getAddressesUnspentsLimit l s as- protoSerial proto uns--scottyAddressBalance :: MonadLoggerIO m => WebT m ()-scottyAddressBalance = do- setHeaders- a <- parseAddress- proto <- setupBin- res <- getBalance a- protoSerial proto res--scottyAddressesBalances :: MonadLoggerIO m => WebT m ()-scottyAddressesBalances = do- setHeaders- as <- parseAddresses- proto <- setupBin- res <- getBalances as- protoSerial proto res--scottyXpubBalances :: MonadLoggerIO m => WebT m ()-scottyXpubBalances = do- setHeaders- xpub <- parseXpub- proto <- setupBin- res <- filter (not . nullBalance . xPubBal) <$> xPubBals xpub- protoSerial proto res--scottyXpubTxs :: MonadLoggerIO m => Bool -> WebT m ()-scottyXpubTxs full = do- setHeaders- xpub <- parseXpub- start <- getStart- limit <- getLimit full- proto <- setupBin- txs <- xPubTxs xpub start 0 limit- if full- then do- txs' <- catMaybes <$> mapM (getTransaction . blockTxHash) txs- protoSerial proto txs'- else protoSerial proto txs--scottyXpubUnspents :: MonadLoggerIO m => WebT m ()-scottyXpubUnspents = do- setHeaders- xpub <- parseXpub- proto <- setupBin- start <- getStart- limit <- getLimit False- uns <- xPubUnspents xpub start 0 limit- protoSerial proto uns--scottyXpubSummary :: MonadLoggerIO m => WebT m ()-scottyXpubSummary = do- setHeaders- xpub <- parseXpub- proto <- setupBin- res <- xPubSummary xpub- protoSerial proto res--scottyPostTx ::- (MonadUnliftIO m, MonadLoggerIO m)- => WebT m ()-scottyPostTx = do- net <- lift $ asks webNetwork- pub <- lift $ asks webPublisher- st <- lift $ asks webStore- setHeaders- proto <- setupBin- b <- S.body- let bin = eitherToMaybe . Serialize.decode- hex = bin <=< decodeHex . cs . C.filter (not . isSpace)- tx <-- case hex b <|> bin (L.toStrict b) of- Nothing -> S.raise $ UserError "decode tx fail"- Just x -> return x- lift (publishTx net pub st tx) >>= \case- Right () -> do- protoSerial proto (TxId (txHash tx))- Left e -> do- case e of- PubNoPeers -> S.status status500- PubTimeout -> S.status status500- PubPeerDisconnected -> S.status status500- PubReject _ -> S.status status400- protoSerial proto (UserError (show e))- S.finish--scottyDbStats :: MonadLoggerIO m => WebT m ()-scottyDbStats = do- setHeaders- DatabaseReader {databaseHandle = db} <- lift $ asks webDB- stats <- lift (getProperty db Stats)- case stats of- Nothing -> do- S.text "Could not get stats"- Just txt -> do- S.text $ cs txt--scottyEvents :: MonadLoggerIO m => WebT m ()-scottyEvents = do- net <- lift $ asks webNetwork- pub <- lift $ asks webPublisher- setHeaders- proto <- setupBin- S.stream $ \io flush' ->- withSubscription pub $ \sub ->- forever $- flush' >> receive sub >>= \se -> do- let me =- case se of- 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 ->- let bs =- serialAny net proto e <>- if proto- then mempty- else "\n"- in io (lazyByteString bs)--scottyPeers :: MonadLoggerIO m => WebT m ()-scottyPeers = do- mgr <- lift $ asks (storeManager . webStore)- setHeaders- proto <- setupBin- ps <- getPeersInformation mgr- protoSerial proto ps--scottyHealth ::- (MonadUnliftIO m, MonadLoggerIO m)- => WebT m ()-scottyHealth = do- net <- lift $ asks webNetwork- st <- lift $ asks webStore- tos <- lift $ asks webTimeouts- setHeaders- proto <- setupBin- h <- lift $ healthCheck net (storeManager st) (storeChain st) tos- when (not (healthOK h) || not (healthSynced h)) $ S.status status503- protoSerial proto h--runWeb :: (MonadLoggerIO m, MonadUnliftIO m) => WebConfig -> m ()-runWeb cfg@WebConfig {webPort = port, webReqLog = reqlog} = do- req_logger <-- if reqlog- then Just <$> logIt- else return Nothing- runner <- askRunInIO- S.scottyT port (runner . (`runReaderT` cfg)) $ do- case req_logger of- Just m -> S.middleware m- Nothing -> return ()- S.defaultHandler defHandler- S.get "/block/best" $ scottyBestBlock False- S.get "/block/best/raw" $ scottyBestBlock True- S.get "/block/:block" $ scottyBlock False- S.get "/block/:block/raw" $ scottyBlock True- S.get "/block/height/:height" $ scottyBlockHeight False- S.get "/block/height/:height/raw" $ scottyBlockHeight True- S.get "/block/time/:time" $ scottyBlockTime False- S.get "/block/time/:time/raw" $ scottyBlockTime True- S.get "/block/heights" scottyBlockHeights- S.get "/block/latest" scottyBlockLatest- S.get "/blocks" scottyBlocks- S.get "/mempool" scottyMempool- S.get "/transaction/:txid" scottyTransaction- S.get "/transaction/:txid/raw" scottyRawTransaction- S.get "/transaction/:txid/after/:height" scottyTxAfterHeight- S.get "/transactions" scottyTransactions- S.get "/transactions/raw" scottyRawTransactions- S.get "/transactions/block/:block" scottyBlockTransactions- S.get "/transactions/block/:block/raw" scottyRawBlockTransactions- S.get "/address/:address/transactions" $ scottyAddressTxs False- S.get "/address/:address/transactions/full" $ scottyAddressTxs True- S.get "/address/transactions" $ scottyAddressesTxs False- S.get "/address/transactions/full" $ scottyAddressesTxs True- S.get "/address/:address/unspent" scottyAddressUnspent- S.get "/address/unspent" scottyAddressesUnspent- S.get "/address/:address/balance" scottyAddressBalance- S.get "/address/balances" scottyAddressesBalances- S.get "/xpub/:xpub/balances" scottyXpubBalances- S.get "/xpub/:xpub/transactions" $ scottyXpubTxs False- S.get "/xpub/:xpub/transactions/full" $ scottyXpubTxs True- S.get "/xpub/:xpub/unspent" scottyXpubUnspents- S.get "/xpub/:xpub" scottyXpubSummary- S.post "/transactions" scottyPostTx- S.get "/dbstats" scottyDbStats- S.get "/events" scottyEvents- S.get "/peers" scottyPeers- S.get "/health" scottyHealth- S.notFound $ S.raise ThingNotFound--getStart :: MonadLoggerIO m => WebT m (Maybe BlockRef)-getStart =- runMaybeT $ do- s <- MaybeT $ (Just <$> S.param "height") `S.rescue` const (return Nothing)- do case s of- StartParamHash {startParamHash = h} ->- start_tx h <|> start_block h- StartParamHeight {startParamHeight = h} -> start_height h- StartParamTime {startParamTime = q} -> start_time q- where- start_height h = return $ BlockRef h maxBound- start_block h = do- b <- MaybeT $ getBlock (BlockHash h)- let g = blockDataHeight b- return $ BlockRef g maxBound- start_tx h = do- t <- MaybeT $ getTxData (TxHash h)- return $ txDataBlock t- start_time q = do- d <- MaybeT getBestBlock >>= MaybeT . getBlock- if q <= fromIntegral (blockTimestamp (blockDataHeader d))- then do- b <- MaybeT $ blockAtOrBefore q- let g = blockDataHeight b- return $ BlockRef g maxBound- else return $ MemRef q--getOffset :: Monad m => WebT m Offset-getOffset = do- limits <- lift $ asks webMaxLimits- o <- S.param "offset" `S.rescue` const (return 0)- when (maxLimitOffset limits > 0 && o > maxLimitOffset limits) .- S.raise . UserError $- "offset exceeded: " <> show o <> " > " <> show (maxLimitOffset limits)- return o--getLimit ::- Monad m- => Bool- -> WebT m (Maybe Limit)-getLimit full = do- limits <- lift $ asks webMaxLimits- l <- (Just <$> S.param "limit") `S.rescue` const (return Nothing)- let m =- if full- then if maxLimitFull limits > 0- then maxLimitFull limits- else maxLimitCount limits- else maxLimitCount limits- let d = maxLimitDefault limits- return $- case l of- Nothing ->- if d > 0 || m > 0- then Just (min m d)- else Nothing- Just n ->- if m > 0- then Just (min m n)- else Just n--parseAddress :: Monad m => WebT m Address-parseAddress = do- net <- lift $ asks webNetwork- address <- S.param "address"- case stringToAddr net address of- Nothing -> S.next- Just a -> return a--parseAddresses :: Monad m => WebT m [Address]-parseAddresses = do- net <- lift $ asks webNetwork- addresses <- S.param "addresses"- let as = mapMaybe (stringToAddr net) addresses- unless (length as == length addresses) S.next- return as--parseXpub :: Monad m => WebT m XPubSpec-parseXpub = do- net <- lift $ asks webNetwork- t <- S.param "xpub"- d <- parseDeriveAddrs- case xPubImport net t of- Nothing -> S.next- Just x -> return XPubSpec {xPubSpecKey = x, xPubDeriveType = d}--parseDeriveAddrs ::- Monad m => WebT m DeriveType-parseDeriveAddrs =- lift (asks webNetwork) >>= \case- net- | getSegWit net -> do- t <- S.param "derive" `S.rescue` const (return "standard")- return $- case (t :: Text) of- "segwit" -> DeriveP2WPKH- "compat" -> DeriveP2SH- _ -> DeriveNormal- | otherwise -> return DeriveNormal--parseNoTx :: (Monad m, ScottyError e) => ActionT e m Bool-parseNoTx = S.param "notx" `S.rescue` const (return False)--pruneTx :: Bool -> BlockData -> BlockData-pruneTx False b = b-pruneTx True b = b {blockDataTxs = take 1 (blockDataTxs b)}--setHeaders :: (Monad m, ScottyError e) => ActionT e m ()-setHeaders = do- S.setHeader "Access-Control-Allow-Origin" "*"--serialAny ::- (JsonSerial a, BinSerial a)- => Network- -> Bool -- ^ binary- -> a- -> L.ByteString-serialAny net True = runPutLazy . binSerial net-serialAny net False = encodingToLazyByteString . jsonSerial net--setupBin :: Monad m => ActionT Except m Bool-setupBin =- let p = do- S.setHeader "Content-Type" "application/octet-stream"- return True- j = do- S.setHeader "Content-Type" "application/json"- return False- in S.header "accept" >>= \case- Nothing -> j- Just x ->- if is_binary x- then p- else j- where- is_binary = (== "application/octet-stream")--instance MonadLoggerIO m => MonadLoggerIO (WebT m) where- askLoggerIO = lift askLoggerIO--instance MonadLogger m => MonadLogger (WebT m) where- monadLoggerLog loc src lvl = lift . monadLoggerLog loc src lvl--healthCheck ::- (MonadUnliftIO m, StoreRead m)- => Network- -> Manager- -> Chain- -> Timeouts- -> m HealthCheck-healthCheck net mgr ch tos = do- cb <- chain_best- bb <- block_best- pc <- peer_count- tm <- get_current_time- ml <- get_mempool_last- let ck = block_ok cb- bk = block_ok bb- pk = peer_count_ok pc- bd = block_time_delta tm cb- td = tx_time_delta tm bd ml- lk = timeout_ok (blockTimeout tos) bd- tk = timeout_ok (txTimeout tos) td- sy = in_sync bb cb- ok = ck && bk && pk && lk && (tk || not sy)- return- HealthCheck- { healthBlockBest = block_hash <$> bb- , healthBlockHeight = block_height <$> bb- , healthHeaderBest = node_hash <$> cb- , healthHeaderHeight = node_height <$> cb- , healthPeers = pc- , healthNetwork = getNetworkName net- , healthOK = ok- , healthSynced = sy- , healthLastBlock = bd- , healthLastTx = td- }- where- block_hash = headerHash . blockDataHeader- block_height = blockDataHeight- node_hash = headerHash . nodeHeader- node_height = nodeHeight- get_mempool_last = listToMaybe <$> getMempool- get_current_time = fromIntegral . systemSeconds <$> liftIO getSystemTime- peer_count_ok pc = fromMaybe 0 pc > 0- block_ok = isJust- node_timestamp = fromIntegral . blockTimestamp . nodeHeader- in_sync bb cb = fromMaybe False $ do- bh <- blockDataHeight <$> bb- nh <- nodeHeight <$> cb- return $ compute_delta bh nh <= 1- block_time_delta tm cb = do- bt <- node_timestamp <$> cb- return $ compute_delta bt tm- tx_time_delta tm bd ml = do- bd' <- bd- tt <- memRefTime . blockTxBlock <$> ml <|> bd- return $ min (compute_delta tt tm) bd'- timeout_ok to td = fromMaybe False $ do- td' <- td- return $- getAllowMinDifficultyBlocks net ||- to == 0 ||- td' <= to- peer_count = fmap length <$> timeout 500000 (managerGetPeers mgr)- block_best = runMaybeT $ do- h <- MaybeT getBestBlock- MaybeT $ getBlock h- chain_best = timeout 500000 $ chainGetBest ch- compute_delta a b = if b > a then b - a else 0---- | Obtain information about connected peers from peer manager process.-getPeersInformation :: MonadIO m => Manager -> m [PeerInformation]-getPeersInformation mgr = mapMaybe toInfo <$> managerGetPeers mgr- where- toInfo op = do- ver <- onlinePeerVersion op- let as = onlinePeerAddress op- ua = getVarString $ userAgent ver- vs = version ver- sv = services ver- rl = relay ver- return- PeerInformation- { peerUserAgent = ua- , peerAddress = sockToHostAddress as- , peerVersion = vs- , peerServices = sv- , peerRelay = rl- }---- | Check if any of the ancestors of this transaction is a coinbase after the--- specified height. Returns 'Nothing' if answer cannot be computed before--- hitting limits.-cbAfterHeight ::- (MonadIO m, StoreRead m)- => Int -- ^ how many ancestors to test before giving up- -> BlockHeight- -> TxHash- -> m TxAfterHeight-cbAfterHeight d h t- | d <= 0 = return $ TxAfterHeight Nothing- | otherwise = do- x <- fmap snd <$> tst d t- return $ TxAfterHeight x- where- tst e x- | e <= 0 = return Nothing- | otherwise = do- let e' = e - 1- getTransaction x >>= \case- Nothing -> return Nothing- Just tx ->- if any isCoinbase (transactionInputs tx)- then return $- Just (e', blockRefHeight (transactionBlock tx) > h)- else case transactionBlock tx of- BlockRef {blockRefHeight = b}- | b <= h -> return $ Just (e', False)- _ ->- r e' . nub $- map- (outPointHash . inputPoint)- (transactionInputs tx)- r e [] = return $ Just (e, False)- r e (n:ns) =- tst e n >>= \case- Nothing -> return Nothing- Just (e', s) ->- if s- then return $ Just (e', True)- else r e' ns--getAddressTxsLimit ::- (Monad m, StoreRead m)- => Offset- -> Maybe Limit- -> Maybe BlockRef- -> Address- -> m [BlockTx]-getAddressTxsLimit offset limit start addr =- applyOffset offset <$> getAddressTxs addr start ((offset +) <$> limit)--getAddressTxsFull ::- (Monad m, StoreRead m)- => Offset- -> Maybe Limit- -> Maybe BlockRef- -> Address- -> m [Transaction]-getAddressTxsFull offset limit start addr = do- txs <- getAddressTxsLimit offset limit start addr- catMaybes <$> mapM (getTransaction . blockTxHash) txs--getAddressesTxsLimit ::- (Monad m, StoreRead m)- => Maybe Limit- -> Maybe BlockRef- -> [Address]- -> m [BlockTx]-getAddressesTxsLimit limit start addrs =- getAddressesTxs addrs start limit--getAddressesTxsFull ::- (Monad m, StoreRead m)- => Maybe Limit- -> Maybe BlockRef- -> [Address]- -> m [Transaction]-getAddressesTxsFull limit start addrs =- fmap catMaybes $- getAddressesTxsLimit limit start addrs >>=- mapM (getTransaction . blockTxHash)--getAddressUnspentsLimit ::- (Monad m, StoreRead m)- => Offset- -> Maybe Limit- -> Maybe BlockRef- -> Address- -> m [Unspent]-getAddressUnspentsLimit offset limit start addr =- applyOffset offset <$> getAddressUnspents addr start ((offset +) <$> limit)--getAddressesUnspentsLimit ::- (Monad m, StoreRead m)- => Maybe Limit- -> Maybe BlockRef- -> [Address]- -> m [Unspent]-getAddressesUnspentsLimit limit start addrs =- getAddressesUnspents addrs start limit---- | Publish a new transaction to the network.-publishTx ::- (MonadUnliftIO m, StoreRead m)- => Network- -> Publisher StoreEvent- -> Store- -> Tx- -> m (Either PubExcept ())-publishTx net pub st tx =- withSubscription pub $ \s ->- getTransaction (txHash tx) >>= \case- Just _ -> return $ Right ()- Nothing -> go s- where- go s =- managerGetPeers (storeManager st) >>= \case- [] -> return $ Left PubNoPeers- OnlinePeer {onlinePeerMailbox = p}:_ -> do- MTx tx `sendMessage` p- let v =- if getSegWit net- then InvWitnessTx- else InvTx- sendMessage- (MGetData (GetData [InvVector v (getTxHash (txHash tx))]))- p- f p s- t = 5 * 1000 * 1000- f p s =- liftIO (timeout t (g p s)) >>= \case- Nothing -> return $ Left PubTimeout- Just (Left e) -> return $ Left e- Just (Right ()) -> return $ Right ()- g p s =- receive s >>= \case- StoreTxReject p' h' c _- | p == p' && h' == txHash tx -> return . Left $ PubReject c- StorePeerDisconnected p' _- | p == p' -> return $ Left PubPeerDisconnected- StoreMempoolNew h'- | h' == txHash tx -> return $ Right ()- _ -> g p s--logIt :: (MonadUnliftIO m, MonadLoggerIO m) => m Middleware-logIt = do- runner <- askRunInIO- return $ \app req respond -> do- t1 <- getCurrentTime- app req $ \res -> do- t2 <- getCurrentTime- let d = diffUTCTime t2 t1- s = responseStatus res- runner $- $(logInfoS) "Web" $- fmtReq req <> " [" <> fmtStatus s <> " / " <> fmtDiff d <> "]"- respond res--fmtReq :: Request -> Text-fmtReq req =- let m = requestMethod req- v = httpVersion req- p = rawPathInfo req- q = rawQueryString req- in T.decodeUtf8 $ m <> " " <> p <> q <> " " <> cs (show v)--fmtDiff :: NominalDiffTime -> Text-fmtDiff d =- cs (printf "%0.3f" (realToFrac (d * 1000) :: Double) :: String) <> " ms"--fmtStatus :: Status -> Text-fmtStatus s = cs (show (statusCode s)) <> " " <> cs (statusMessage s)--refuseLargeBlock :: Monad m => MaxLimits -> BlockData -> ActionT Except m ()-refuseLargeBlock MaxLimits {maxLimitFull = f} BlockData {blockDataTxs = txs} =- when (length txs > fromIntegral f) $ S.raise BlockTooLarge
+ test/Haskoin/Store/CacheSpec.hs view
@@ -0,0 +1,35 @@+module Haskoin.Store.CacheSpec (spec) where++import Data.List (sort)+import Haskoin.Store.Cache (blockRefScore, scoreBlockRef)+import Haskoin.Store.Common (BlockRef (..))+import Test.Hspec (Spec, describe)+import Test.Hspec.QuickCheck (prop)+import Test.QuickCheck (Gen, choose, forAll, listOf, oneof)++spec :: Spec+spec = do+ describe "Score for block reference" $ do+ prop "sorts correctly" $+ forAll arbitraryBlockRefs $ \ts ->+ let scores = map blockRefScore (sort ts)+ in sort scores == reverse scores+ prop "respects identity" $+ forAll arbitraryBlockRef $ \b ->+ let score = blockRefScore b+ ref = scoreBlockRef score+ in ref == b++arbitraryBlockRefs :: Gen [BlockRef]+arbitraryBlockRefs = listOf arbitraryBlockRef++arbitraryBlockRef :: Gen BlockRef+arbitraryBlockRef = oneof [b, m]+ where+ b = do+ h <- choose (0, 0x07ffffff)+ p <- choose (0, 0x03ffffff)+ return BlockRef {blockRefHeight = h, blockRefPos = p}+ m = do+ t <- choose (0, 0x001fffffffffffff)+ return MemRef {memRefTime = t}
+ test/Haskoin/Store/CommonSpec.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE OverloadedStrings #-}+module Haskoin.Store.CommonSpec+ ( spec+ ) where++import Data.Serialize (decode, encode, runGet, runPut)+import Data.Text (Text)+import Haskoin (Address, Network, TxHash (TxHash), bch,+ bchRegTest, bchTest, btc, btcRegTest,+ btcTest, stringToAddr)+import Haskoin.Store.Common (BinSerial (..), DeriveType (..),+ XPubSpec (..))+import Network.Haskoin.Test (arbitraryXPubKey)+import NQE ()+import Test.Hspec (Expectation, Spec, describe, it,+ shouldBe)+import Test.Hspec.QuickCheck (prop)+import Test.QuickCheck (Gen, elements, forAll)++spec :: Spec+spec = do+ let net = btc+ describe "Extended keys" $ do+ prop "respect serialization identity identity" $+ forAll arbitraryXPubSpec $ \(_, xpub) ->+ Right xpub == (decode . encode) xpub+ 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++arbitraryXPubSpec :: Gen (Network, XPubSpec)+arbitraryXPubSpec = do+ (_, k) <- arbitraryXPubKey+ n <- elements [btc, bch, btcTest, bchTest, btcRegTest, bchRegTest]+ t <- elements [DeriveNormal, DeriveP2SH, DeriveP2WPKH]+ return (n, XPubSpec {xPubSpecKey = k, xPubDeriveType = t})
test/Haskoin/StoreSpec.hs view
@@ -9,10 +9,10 @@ import Control.Monad.Trans import Data.Maybe import Data.Word-import Database.RocksDB import Haskoin import Haskoin.Node import Haskoin.Store+import Haskoin.Store.Common import NQE import Test.Hspec import UnliftIO@@ -73,38 +73,24 @@ MonadUnliftIO m => Network -> String -> (TestStore -> m a) -> m a withTestStore net t f = withSystemTempDirectory ("haskoin-store-test-" <> t <> "-") $ \w ->- runNoLoggingT $ withPublisher $ \pub -> do- db <-- open- w- defaultOptions- { createIfMissing = True- , errorIfExists = True- , compression = SnappyCompression- }- let bdb =- DatabaseReader- { databaseHandle = db- , databaseReadOptions = defaultReadOptions- , databaseMaxGap = gap- }+ runNoLoggingT $ do let cfg = StoreConfig { storeConfMaxPeers = 20 , storeConfInitPeers = [] , storeConfDiscover = True- , storeConfDB = bdb+ , storeConfDB = w , storeConfNetwork = net- , storeConfPublisher = pub , storeConfCache = Nothing , storeConfGap = gap , storeConfCacheMin = 100+ , storeConfMaxKeys = 100 * 1000 * 1000 }- withStore cfg $ \Store {..} -> withSubscription pub $ \sub ->+ withStore cfg $ \Store {..} -> withSubscription storePublisher $ \sub -> lift $ f TestStore- { testStoreDB = bdb+ { testStoreDB = storeDB , testStoreBlockStore = storeBlock , testStoreChain = storeChain , testStoreEvents = sub
− test/Network/Haskoin/Store/CommonSpec.hs
@@ -1,62 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Network.Haskoin.Store.CommonSpec- ( spec- ) where--import Data.Serialize (decode, encode, runGet, runPut)-import Data.Text (Text)-import Haskoin (Address, Network,- TxHash (TxHash), bch, bchRegTest,- bchTest, btc, btcRegTest,- btcTest, stringToAddr)-import Network.Haskoin.Store.Common (BinSerial (..), DeriveType (..),- XPubSpec (..))-import Network.Haskoin.Test (arbitraryXPubKey)-import NQE ()-import Test.Hspec (Expectation, Spec, describe, it,- shouldBe)-import Test.Hspec.QuickCheck (prop)-import Test.QuickCheck (Gen, elements, forAll)--spec :: Spec-spec = do- let net = btc- describe "Extended keys" $ do- prop "respect serialization identity identity" $- forAll arbitraryXPubSpec $ \(_, xpub) ->- Right xpub == (decode . encode) xpub- 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--arbitraryXPubSpec :: Gen (Network, XPubSpec)-arbitraryXPubSpec = do- (_, k) <- arbitraryXPubKey- n <- elements [btc, bch, btcTest, bchTest, btcRegTest, bchRegTest]- t <- elements [DeriveNormal, DeriveP2SH, DeriveP2WPKH]- return (n, XPubSpec {xPubSpecKey = k, xPubDeriveType = t})
− test/Network/Haskoin/Store/Data/CacheReaderSpec.hs
@@ -1,37 +0,0 @@-module Network.Haskoin.Store.Data.CacheReaderSpec (spec) where--import Data.List (sort)-import Network.Haskoin.Store.Common (BlockRef (..))-import Network.Haskoin.Store.Data.CacheReader (blockRefScore,- scoreBlockRef)-import Test.Hspec (Spec, describe)-import Test.Hspec.QuickCheck (prop)-import Test.QuickCheck (Gen, choose, forAll,- listOf, oneof)--spec :: Spec-spec = do- describe "Score for block reference" $ do- prop "sorts correctly" $- forAll arbitraryBlockRefs $ \ts ->- let scores = map blockRefScore (sort ts)- in sort scores == reverse scores- prop "respects identity" $- forAll arbitraryBlockRef $ \b ->- let score = blockRefScore b- ref = scoreBlockRef score- in ref == b--arbitraryBlockRefs :: Gen [BlockRef]-arbitraryBlockRefs = listOf arbitraryBlockRef--arbitraryBlockRef :: Gen BlockRef-arbitraryBlockRef = oneof [b, m]- where- b = do- h <- choose (0, 0x07ffffff)- p <- choose (0, 0x03ffffff)- return BlockRef {blockRefHeight = h, blockRefPos = p}- m = do- t <- choose (0, 0x001fffffffffffff)- return MemRef {memRefTime = t}