diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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 diff --git a/haskoin-store.cabal b/haskoin-store.cabal --- a/haskoin-store.cabal +++ b/haskoin-store.cabal @@ -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 diff --git a/src/Haskoin/Store.hs b/src/Haskoin/Store.hs --- a/src/Haskoin/Store.hs +++ b/src/Haskoin/Store.hs @@ -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 diff --git a/src/Haskoin/Store/BlockStore.hs b/src/Haskoin/Store/BlockStore.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Store/BlockStore.hs @@ -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 diff --git a/src/Haskoin/Store/Cache.hs b/src/Haskoin/Store/Cache.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Store/Cache.hs @@ -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} diff --git a/src/Haskoin/Store/Common.hs b/src/Haskoin/Store/Common.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Store/Common.hs @@ -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 diff --git a/src/Haskoin/Store/Database/Memory.hs b/src/Haskoin/Store/Database/Memory.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Store/Database/Memory.hs @@ -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) diff --git a/src/Haskoin/Store/Database/Reader.hs b/src/Haskoin/Store/Database/Reader.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Store/Database/Reader.hs @@ -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 diff --git a/src/Haskoin/Store/Database/Types.hs b/src/Haskoin/Store/Database/Types.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Store/Database/Types.hs @@ -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 + } diff --git a/src/Haskoin/Store/Database/Writer.hs b/src/Haskoin/Store/Database/Writer.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Store/Database/Writer.hs @@ -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 diff --git a/src/Haskoin/Store/Logic.hs b/src/Haskoin/Store/Logic.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Store/Logic.hs @@ -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 diff --git a/src/Haskoin/Store/Manager.hs b/src/Haskoin/Store/Manager.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Store/Manager.hs @@ -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 () diff --git a/src/Haskoin/Store/Web.hs b/src/Haskoin/Store/Web.hs new file mode 100644 --- /dev/null +++ b/src/Haskoin/Store/Web.hs @@ -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 diff --git a/src/Network/Haskoin/Store/BlockStore.hs b/src/Network/Haskoin/Store/BlockStore.hs deleted file mode 100644 --- a/src/Network/Haskoin/Store/BlockStore.hs +++ /dev/null @@ -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 diff --git a/src/Network/Haskoin/Store/CacheWriter.hs b/src/Network/Haskoin/Store/CacheWriter.hs deleted file mode 100644 --- a/src/Network/Haskoin/Store/CacheWriter.hs +++ /dev/null @@ -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) diff --git a/src/Network/Haskoin/Store/Common.hs b/src/Network/Haskoin/Store/Common.hs deleted file mode 100644 --- a/src/Network/Haskoin/Store/Common.hs +++ /dev/null @@ -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 diff --git a/src/Network/Haskoin/Store/Data/CacheReader.hs b/src/Network/Haskoin/Store/Data/CacheReader.hs deleted file mode 100644 --- a/src/Network/Haskoin/Store/Data/CacheReader.hs +++ /dev/null @@ -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' - ] diff --git a/src/Network/Haskoin/Store/Data/DatabaseReader.hs b/src/Network/Haskoin/Store/Data/DatabaseReader.hs deleted file mode 100644 --- a/src/Network/Haskoin/Store/Data/DatabaseReader.hs +++ /dev/null @@ -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 diff --git a/src/Network/Haskoin/Store/Data/DatabaseWriter.hs b/src/Network/Haskoin/Store/Data/DatabaseWriter.hs deleted file mode 100644 --- a/src/Network/Haskoin/Store/Data/DatabaseWriter.hs +++ /dev/null @@ -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 diff --git a/src/Network/Haskoin/Store/Data/MemoryDatabase.hs b/src/Network/Haskoin/Store/Data/MemoryDatabase.hs deleted file mode 100644 --- a/src/Network/Haskoin/Store/Data/MemoryDatabase.hs +++ /dev/null @@ -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) diff --git a/src/Network/Haskoin/Store/Data/Types.hs b/src/Network/Haskoin/Store/Data/Types.hs deleted file mode 100644 --- a/src/Network/Haskoin/Store/Data/Types.hs +++ /dev/null @@ -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 () diff --git a/src/Network/Haskoin/Store/Logic.hs b/src/Network/Haskoin/Store/Logic.hs deleted file mode 100644 --- a/src/Network/Haskoin/Store/Logic.hs +++ /dev/null @@ -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 diff --git a/src/Network/Haskoin/Store/Web.hs b/src/Network/Haskoin/Store/Web.hs deleted file mode 100644 --- a/src/Network/Haskoin/Store/Web.hs +++ /dev/null @@ -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 diff --git a/test/Haskoin/Store/CacheSpec.hs b/test/Haskoin/Store/CacheSpec.hs new file mode 100644 --- /dev/null +++ b/test/Haskoin/Store/CacheSpec.hs @@ -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} diff --git a/test/Haskoin/Store/CommonSpec.hs b/test/Haskoin/Store/CommonSpec.hs new file mode 100644 --- /dev/null +++ b/test/Haskoin/Store/CommonSpec.hs @@ -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}) diff --git a/test/Haskoin/StoreSpec.hs b/test/Haskoin/StoreSpec.hs --- a/test/Haskoin/StoreSpec.hs +++ b/test/Haskoin/StoreSpec.hs @@ -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 diff --git a/test/Network/Haskoin/Store/CommonSpec.hs b/test/Network/Haskoin/Store/CommonSpec.hs deleted file mode 100644 --- a/test/Network/Haskoin/Store/CommonSpec.hs +++ /dev/null @@ -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}) diff --git a/test/Network/Haskoin/Store/Data/CacheReaderSpec.hs b/test/Network/Haskoin/Store/Data/CacheReaderSpec.hs deleted file mode 100644 --- a/test/Network/Haskoin/Store/Data/CacheReaderSpec.hs +++ /dev/null @@ -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}