haskoin-store 0.30.1 → 0.31.0
raw patch · 11 files changed
+3339/−3230 lines, 11 filesdep +aeson-prettydep ~haskoin-coredep ~haskoin-store-data
Dependencies added: aeson-pretty
Dependency ranges changed: haskoin-core, haskoin-store-data
Files
- app/Main.hs +280/−103
- haskoin-store.cabal +12/−13
- src/Haskoin/Store/BlockStore.hs +455/−437
- src/Haskoin/Store/Cache.hs +134/−121
- src/Haskoin/Store/Common.hs +42/−49
- src/Haskoin/Store/Database/Memory.hs +0/−303
- src/Haskoin/Store/Database/Reader.hs +1/−2
- src/Haskoin/Store/Database/Types.hs +9/−16
- src/Haskoin/Store/Database/Writer.hs +498/−214
- src/Haskoin/Store/Logic.hs +795/−778
- src/Haskoin/Store/Web.hs +1113/−1194
app/Main.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-}@@ -9,34 +10,37 @@ import Control.Monad (when) import Control.Monad.Logger (LogLevel (..), filterLogger, logInfoS, runStderrLoggingT)-import Data.Default (def)+import Data.Char (toLower)+import Data.Default (Default (..)) import Data.List (intercalate) import Data.Maybe (fromMaybe) import Data.String.Conversions (cs) import Data.Version (showVersion) import Haskoin (Network (..), allNets, bch, bchRegTest, bchTest, btc, btcRegTest,- btcTest)+ btcTest, eitherToMaybe) import Haskoin.Node (withConnection) import Haskoin.Store (StoreConfig (..), WebConfig (..), WebLimits (..), WebTimeouts (..), runWeb, withStore) import Options.Applicative (Parser, auto, eitherReader,- execParser, fullDesc, header, help,- helper, info, long, many, metavar,- option, progDesc, short, showDefault,- strOption, switch, value)+ execParser, flag, fullDesc, header,+ help, helper, info, long, many,+ metavar, option, progDesc, short,+ showDefault, strOption, switch, value) import Paths_haskoin_store as P import System.Exit (exitSuccess) import System.FilePath ((</>)) import System.IO.Unsafe (unsafePerformIO) import Text.Read (readMaybe)-import UnliftIO (MonadUnliftIO, liftIO)+import UnliftIO (MonadIO) import UnliftIO.Directory (createDirectoryIfMissing, getAppUserDataDirectory)+import UnliftIO.Environment (lookupEnv) data Config = Config { configDir :: !FilePath+ , configHost :: !String , configPort :: !Int , configNetwork :: !Network , configDiscover :: !Bool@@ -55,130 +59,306 @@ , configPeerTooOld :: !Int } +instance Default Config where+ def = Config { configDir = defDirectory+ , configHost = defHost+ , configPort = defPort+ , configNetwork = defNetwork+ , configDiscover = defDiscover+ , configPeers = defPeers+ , configVersion = False+ , configDebug = defDebug+ , configReqLog = defReqLog+ , configWebLimits = defWebLimits+ , configWebTimeouts = defWebTimeouts+ , configRedis = defRedis+ , configRedisURL = defRedisURL+ , configRedisMin = defRedisMin+ , configRedisMax = defRedisMax+ , configWipeMempool = defWipeMempool+ , configPeerTimeout = defPeerTimeout+ , configPeerTooOld = defPeerTooOld+ }++defEnv :: MonadIO m => String -> a -> (String -> Maybe a) -> m a+defEnv e d p = do+ ms <- lookupEnv e+ return $ fromMaybe d $ p =<< ms++defDirectory :: FilePath+defDirectory = unsafePerformIO $ do+ d <- getAppUserDataDirectory "haskoin-store"+ defEnv "DIR" d pure+{-# NOINLINE defDirectory #-}++defHost :: String+defHost = unsafePerformIO $+ defEnv "HOST" "*" pure+{-# NOINLINE defHost #-}+ defPort :: Int-defPort = 3000+defPort = unsafePerformIO $+ defEnv "PORT" 3000 readMaybe+{-# NOINLINE defPort #-} defNetwork :: Network-defNetwork = bch--netNames :: String-netNames = intercalate "|" (map getNetworkName allNets)+defNetwork = unsafePerformIO $+ defEnv "NET" bch (eitherToMaybe . networkReader)+{-# NOINLINE defNetwork #-} defRedisMin :: Int-defRedisMin = 100+defRedisMin = unsafePerformIO $+ defEnv "CACHE_MIN" 100 readMaybe+{-# NOINLINE defRedisMin #-} +defRedis :: Bool+defRedis = unsafePerformIO $+ defEnv "CACHE" False parseBool+{-# NOINLINE defRedis #-}++defDiscover :: Bool+defDiscover = unsafePerformIO $+ defEnv "DISCOVER" False parseBool+{-# NOINLINE defDiscover #-}++defPeers :: [(String, Maybe Int)]+defPeers = unsafePerformIO $+ defEnv "PEERS" [] (mapM (eitherToMaybe . peerReader) . words)+{-# NOINLINE defPeers #-}++defDebug :: Bool+defDebug = unsafePerformIO $+ defEnv "DEBUG" False parseBool+{-# NOINLINE defDebug #-}++defReqLog :: Bool+defReqLog = unsafePerformIO $+ defEnv "REQ_LOG" False parseBool+{-# NOINLINE defReqLog #-}++defWebLimits :: WebLimits+defWebLimits = unsafePerformIO $ do+ max_limit <- defEnv "MAX_LIMIT" (maxLimitCount def) readMaybe+ max_full <- defEnv "MAX_FULL" (maxLimitFull def) readMaybe+ max_offset <- defEnv "MAX_OFFSET" (maxLimitOffset def) readMaybe+ def_limit <- defEnv "DEF_LIMIT" (maxLimitDefault def) readMaybe+ max_gap <- defEnv "MAX_GAP" (maxLimitGap def) readMaybe+ init_gap <- defEnv "INIT_GAP" (maxLimitInitialGap def) readMaybe+ return WebLimits { maxLimitCount = max_limit+ , maxLimitFull = max_full+ , maxLimitOffset = max_offset+ , maxLimitDefault = def_limit+ , maxLimitGap = max_gap+ , maxLimitInitialGap = init_gap+ }+{-# NOINLINE defWebLimits #-}++defWebTimeouts :: WebTimeouts+defWebTimeouts = unsafePerformIO $ do+ block_timeout <- defEnv "BLOCK_TIMEOUT" (blockTimeout def) readMaybe+ tx_timeout <- defEnv "TX_TIMEOUT" (txTimeout def) readMaybe+ return WebTimeouts { txTimeout = tx_timeout+ , blockTimeout = block_timeout+ }+{-# NOINLINE defWebTimeouts #-}++defWipeMempool :: Bool+defWipeMempool = unsafePerformIO $+ defEnv "WIPE_MEMPOOL" False parseBool+{-# NOINLINE defWipeMempool #-}++defRedisURL :: String+defRedisURL = unsafePerformIO $+ defEnv "REDIS" "" pure+{-# NOINLINE defRedisURL #-}+ defRedisMax :: Integer-defRedisMax = 100 * 1000 * 1000+defRedisMax = unsafePerformIO $+ defEnv "CACHE_KEYS" 100000000 readMaybe+{-# NOINLINE defRedisMax #-} defPeerTimeout :: Int-defPeerTimeout = 120+defPeerTimeout = unsafePerformIO $+ defEnv "PEER_TIMEOUT" 120 readMaybe+{-# NOINLINE defPeerTimeout #-} defPeerTooOld :: Int-defPeerTooOld = 48 * 3600+defPeerTooOld = unsafePerformIO $+ defEnv "PEER_TOO_OLD" (48 * 3600) readMaybe+{-# NOINLINE defPeerTooOld #-} +netNames :: String+netNames = intercalate "|" (map getNetworkName allNets)++parseBool :: String -> Maybe Bool+parseBool str = case map toLower str of+ "yes" -> Just True+ "true" -> Just True+ "on" -> Just True+ "1" -> Just True+ "no" -> Just False+ "false" -> Just False+ "off" -> Just False+ "0" -> Just False+ _ -> Nothing+ config :: Parser Config config = do configDir <- strOption $- metavar "WORKDIR" <> long "dir" <> short 'd' <> help "Data directory" <>- showDefault <>- value myDirectory+ metavar "WORKDIR"+ <> long "dir"+ <> short 'd'+ <> help "Data directory"+ <> showDefault+ <> value (configDir def)+ configHost <-+ strOption $+ metavar "HOST"+ <> long "host"+ <> help "Listen on network interface"+ <> showDefault+ <> value (configHost def) configPort <- option auto $- metavar "PORT" <> long "listen" <> short 'l' <> help "Listening port" <>- showDefault <>- value defPort+ metavar "PORT"+ <> long "listen"+ <> short 'l'+ <> help "Listening port"+ <> showDefault+ <> value (configPort def) configNetwork <- option (eitherReader networkReader) $- metavar netNames <> long "net" <> short 'n' <>- help "Network to connect to" <>- showDefault <>- value defNetwork- configDiscover <- switch $ long "auto" <> short 'a' <> help "Peer discovery"+ metavar netNames+ <> long "net"+ <> short 'n'+ <> help "Network to connect to"+ <> showDefault+ <> value (configNetwork def)+ configDiscover <-+ switch $+ long "auto"+ <> short 'a'+ <> help "Peer discovery" configPeers <-- many . option (eitherReader peerReader) $- metavar "HOST" <> long "peer" <> short 'p' <>- help "Network peer (as many as required)"- configVersion <- switch $ long "version" <> short 'v' <> help "Show version"- configDebug <- switch $ long "debug" <> help "Show debug messages"- configReqLog <- switch $ long "reqlog" <> help "HTTP request logging"+ fmap (mappend defPeers) $+ many $+ option (eitherReader peerReader) $+ metavar "HOST"+ <> long "peer"+ <> short 'p'+ <> help "Network peer (as many as required)"+ configVersion <-+ switch $+ long "version"+ <> short 'v'+ <> help "Show version"+ configDebug <-+ flag (configDebug def) True $+ long "debug"+ <> help "Show debug messages"+ configReqLog <-+ flag (configReqLog def) True $+ long "req-log"+ <> help "HTTP request logging" maxLimitCount <- option auto $- metavar "MAXLIMIT" <> long "maxlimit" <>- help "Max limit for listings (0 for no limit)" <>- showDefault <>- value (maxLimitCount def)+ metavar "MAXLIMIT"+ <> long "max-limit"+ <> help "Hard limit for simple listings (0 = ∞)"+ <> showDefault+ <> value (maxLimitCount (configWebLimits def)) maxLimitFull <- option auto $- metavar "MAXLIMITFULL" <> long "maxfull" <>- help "Max limit for full listings (0 for no limit)" <>- showDefault <>- value (maxLimitFull def)+ metavar "MAXLIMITFULL"+ <> long "max-full"+ <> help "Hard limit for full listings (0 = ∞)"+ <> showDefault+ <> value (maxLimitFull (configWebLimits def)) maxLimitOffset <- option auto $- metavar "MAXOFFSET" <> long "maxoffset" <>- help "Max offset (0 for no limit)" <>- showDefault <>- value (maxLimitOffset def)+ metavar "MAXOFFSET"+ <> long "max-offset"+ <> help "Hard limit for offsets (0 = ∞)"+ <> showDefault+ <> value (maxLimitOffset (configWebLimits def)) maxLimitDefault <- option auto $- metavar "LIMITDEFAULT" <> long "deflimit" <>- help "Default limit (0 for max)" <>- showDefault <>- value (maxLimitDefault def)+ metavar "LIMITDEFAULT"+ <> long "def-limit"+ <> help "Soft default limit (0 = ∞)"+ <> showDefault+ <> value (maxLimitDefault (configWebLimits def)) maxLimitGap <- option auto $- metavar "MAXGAP" <> long "maxgap" <> help "Max gap for xpub queries" <>- showDefault <>- value (maxLimitGap def)+ metavar "MAXGAP"+ <> long "max-gap"+ <> help "Max gap for xpub queries"+ <> showDefault+ <> value (maxLimitGap (configWebLimits def)) maxLimitInitialGap <- option auto $- metavar "INITGAP" <> long "initgap" <> help "Max gap for empty xpub" <>- showDefault <>- value (maxLimitInitialGap def)+ metavar "INITGAP"+ <> long "init-gap"+ <> help "Max gap for empty xpub"+ <> showDefault+ <> value (maxLimitInitialGap (configWebLimits def)) blockTimeout <- option auto $- metavar "BLOCKSECONDS" <> long "blocktimeout" <>- help "Last block mined timeout (0 for infinite)" <>- showDefault <>- value (blockTimeout def)+ metavar "BLOCKSECONDS"+ <> long "block-timeout"+ <> help "Last block mined health timeout (0 = ∞)"+ <> showDefault+ <> value (blockTimeout (configWebTimeouts def)) txTimeout <- option auto $- metavar "TXSECONDS" <> long "txtimeout" <>- help "Last transaction broadcast timeout (0 for infinite)" <>- showDefault <>- value (txTimeout def)+ metavar "TXSECONDS"+ <> long "tx-timeout"+ <> help "Last tx recived health timeout (0 = ∞)"+ <> showDefault+ <> value (txTimeout (configWebTimeouts def)) configPeerTimeout <- option auto $- metavar "TIMEOUT" <> long "peertimeout" <>- help "Disconnect if peer doesn't send message for this many seconds" <>- showDefault <>- value defPeerTimeout+ metavar "TIMEOUT"+ <> long "peer-timeout"+ <> help "Unresponsive peer timeout"+ <> showDefault+ <> value (configPeerTimeout def) configPeerTooOld <- option auto $- metavar "TIMEOUT" <> long "peertooold" <>- help "Disconnect if peer has been connected for this many seconds" <>- showDefault <>- value defPeerTooOld+ metavar "TIMEOUT"+ <> long "peer-old"+ <> help "Disconnect peers older than this"+ <> showDefault+ <> value (configPeerTooOld def) configRedis <-- switch $ long "cache" <> help "Redis cache for extended public keys"+ flag (configRedis def) True $+ long "cache"+ <> help "Redis cache for extended public keys" configRedisURL <- strOption $- metavar "URL" <> long "redis" <> help "URL for Redis cache" <> value ""+ metavar "URL"+ <> long "redis"+ <> help "URL for Redis cache"+ <> value (configRedisURL def) configRedisMin <- option auto $- metavar "MINADDRS" <> long "cachemin" <>- help "Minimum used xpub addresses to cache" <>- showDefault <>- value defRedisMin+ metavar "MINADDRS"+ <> long "cache-min"+ <> help "Minimum used xpub addresses to cache"+ <> showDefault+ <> value (configRedisMin def) configRedisMax <- option auto $- metavar "MAXKEYS" <> long "cachekeys" <>- help "Maximum number of keys in Redis xpub cache" <>- showDefault <>- value defRedisMax+ metavar "MAXKEYS"+ <> long "cache-keys"+ <> help "Maximum number of keys in Redis xpub cache"+ <> showDefault+ <> value (configRedisMax def) configWipeMempool <-- switch $ long "wipemempool" <> help "Wipe mempool when starting"+ flag (configWipeMempool def) True $+ long "wipe-mempool"+ <> help "Wipe mempool at start" pure Config { configWebLimits = WebLimits {..}@@ -210,19 +390,15 @@ _ -> Left "Peer information could not be parsed" return (host, port) -myDirectory :: FilePath-myDirectory = unsafePerformIO $ getAppUserDataDirectory "haskoin-store"-{-# NOINLINE myDirectory #-}- main :: IO () main = do- conf <- liftIO (execParser opts)- when (configVersion conf) . liftIO $ do+ conf <- execParser opts+ when (configVersion conf) $ do putStrLn $ showVersion P.version exitSuccess- if (null (configPeers conf) && not (configDiscover conf))- then liftIO (run conf {configDiscover = True})- else liftIO (run conf)+ if null (configPeers conf) && not (configDiscover conf)+ then run conf {configDiscover = True}+ else run conf where opts = info (helper <*> config) $@@ -231,8 +407,9 @@ Options.Applicative.header ("haskoin-store version " <> showVersion P.version) -run :: MonadUnliftIO m => Config -> m ()-run Config { configPort = port+run :: Config -> IO ()+run Config { configHost = host+ , configPort = port , configNetwork = net , configDiscover = disc , configPeers = peers@@ -274,16 +451,16 @@ , storeConfPeerTooOld = peerold , storeConfConnect = withConnection }- in withStore scfg $ \st ->- let wcfg =- WebConfig- { webPort = port- , webStore = st- , webMaxLimits = limits- , webReqLog = reqlog- , webWebTimeouts = tos- }- in runWeb wcfg+ withStore scfg $ \st ->+ runWeb+ WebConfig+ { webHost = host+ , webPort = port+ , webStore = st+ , webMaxLimits = limits+ , webReqLog = reqlog+ , webWebTimeouts = tos+ } where l _ lvl | deb = True
haskoin-store.cabal view
@@ -1,13 +1,13 @@-cabal-version: 2.0+cabal-version: 1.12 -- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack ----- hash: 77d6055c6a570fea7b596bc084accc7376a618e7b3dc0a8126355fcdea6b82ac+-- hash: c5fef1d2f34e119fa142b47d873bda6c5c99c325a1e861107d9ca8ce81746b1d name: haskoin-store-version: 0.30.1+version: 0.31.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.@@ -29,24 +29,22 @@ library exposed-modules: Haskoin.Store- Paths_haskoin_store other-modules: 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: src build-depends: aeson >=1.4.7.1+ , aeson-pretty >=0.8.8 , base >=4.9 && <5 , bytestring >=0.10.10.0 , cereal >=0.5.8.1@@ -55,9 +53,9 @@ , data-default >=0.7.1.1 , deepseq >=1.4.4.0 , hashable >=1.3.0.0- , haskoin-core >=0.13.3+ , haskoin-core >=0.13.6 , haskoin-node >=0.13.0- , haskoin-store-data ==0.30.1+ , haskoin-store-data ==0.31.0 , hedis >=0.12.13 , http-types >=0.12.3 , monad-logger >=0.3.32@@ -87,6 +85,7 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: aeson >=1.4.7.1+ , aeson-pretty >=0.8.8 , base >=4.9 && <5 , bytestring >=0.10.10.0 , cereal >=0.5.8.1@@ -96,10 +95,10 @@ , deepseq >=1.4.4.0 , filepath , hashable >=1.3.0.0- , haskoin-core >=0.13.3+ , haskoin-core >=0.13.6 , haskoin-node >=0.13.0 , haskoin-store- , haskoin-store-data ==0.30.1+ , haskoin-store-data ==0.31.0 , monad-logger >=0.3.32 , mtl >=2.2.2 , nqe >=0.6.1@@ -123,7 +122,6 @@ 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@@ -138,6 +136,7 @@ build-depends: QuickCheck >=2.13.2 , aeson >=1.4.7.1+ , aeson-pretty >=0.8.8 , base >=4.9 && <5 , base64 >=0.4.1 , bytestring >=0.10.10.0@@ -147,9 +146,9 @@ , data-default >=0.7.1.1 , deepseq >=1.4.4.0 , hashable >=1.3.0.0- , haskoin-core >=0.13.3+ , haskoin-core >=0.13.6 , haskoin-node >=0.13.0- , haskoin-store-data ==0.30.1+ , haskoin-store-data ==0.31.0 , hedis >=0.12.13 , hspec >=2.7.1 , http-types >=0.12.3
src/Haskoin/Store/BlockStore.hs view
@@ -37,12 +37,14 @@ import Control.Monad.Reader (MonadReader, ReaderT (..), asks) import Control.Monad.Trans (lift) import Control.Monad.Trans.Maybe (MaybeT (MaybeT), runMaybeT)+import qualified Data.ByteString as B import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet-import Data.Maybe (catMaybes, listToMaybe,- mapMaybe)+import Data.Maybe (catMaybes, fromJust, isJust,+ listToMaybe, mapMaybe)+import Data.Serialize (encode) import Data.String (fromString) import Data.String.Conversions (cs) import Data.Text (Text)@@ -59,23 +61,21 @@ TxHash (..), TxIn (..), blockHashToHex, headerHash, txHash, txHashToHex)-import Haskoin.Node (OnlinePeer (..), Peer,- PeerException (..),+import Haskoin.Node (Chain, OnlinePeer (..), Peer,+ PeerException (..), PeerManager, chainBlockMain, chainGetAncestor, chainGetBest, chainGetBlock, chainGetParents, killPeer, managerGetPeer,- managerGetPeers, sendMessage)-import Haskoin.Node (Chain, PeerManager,- managerPeerText)+ managerGetPeers,+ managerPeerText, sendMessage) import Haskoin.Store.Common (StoreEvent (..), StoreRead (..), sortTxs)-import Haskoin.Store.Data (TxRef (..), TxData (..),+import Haskoin.Store.Data (TxData (..), TxRef (..), UnixTime, Unspent (..)) import Haskoin.Store.Database.Reader (DatabaseReader)-import Haskoin.Store.Database.Writer (DatabaseWriter,- runDatabaseWriter)-import Haskoin.Store.Logic (ImportException (TxOrphan),+import Haskoin.Store.Database.Writer (Writer, runWriter)+import Haskoin.Store.Logic (ImportException (Orphan), deleteTx, getOldMempool, importBlock, initBest, newMempoolTx, revertBlock)@@ -94,19 +94,12 @@ -- | 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 | TxRefReceived !Peer !Tx- -- ^ transaction received from peer | TxRefAvailable !Peer ![TxHash]- -- ^ peer has transactions available | BlockPing !(Listen ()) -- ^ internal housekeeping ping @@ -117,8 +110,8 @@ = BlockNotInChain !BlockHash | Uninitialized | CorruptDatabase- | AncestorNotInChain !BlockHeight- !BlockHash+ | AncestorNotInChain !BlockHeight !BlockHash+ | MempoolImportFailed deriving (Show, Eq, Ord, Exception) data Syncing = Syncing@@ -127,73 +120,88 @@ , syncingHead :: !BlockNode } -data PendingTx =- PendingTx- { pendingTxTime :: !UnixTime- , pendingTx :: !Tx- , pendingDeps :: !(HashSet TxHash)- }+data PendingTx = PendingTx+ { pendingTxTime :: !UnixTime+ , pendingTx :: !Tx+ , pendingDeps :: !(HashSet TxHash)+ } deriving (Show, Eq, Ord) -- | Block store process state.-data BlockRead =- BlockRead- { mySelf :: !BlockStore- , myConfig :: !BlockStoreConfig- , myPeer :: !(TVar (Maybe Syncing))- , myTxs :: !(TVar (HashMap TxHash PendingTx))- }+data BlockRead = BlockRead+ { mySelf :: !BlockStore+ , myConfig :: !BlockStoreConfig+ , myPeer :: !(TVar (Maybe Syncing))+ , myTxs :: !(TVar (HashMap TxHash PendingTx))+ } -- | Configuration for a block store.-data BlockStoreConfig =- BlockStoreConfig- { blockConfManager :: !PeerManager- -- ^ 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- , blockConfWipeMempool :: !Bool- -- ^ wipe mempool at start- , blockConfPeerTimeout :: !Int- -- ^ disconnect syncing peer if inactive for this long- }+data BlockStoreConfig = BlockStoreConfig+ { blockConfManager :: !PeerManager+ -- ^ 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+ , blockConfWipeMempool :: !Bool+ -- ^ wipe mempool at start+ , blockConfPeerTimeout :: !Int+ -- ^ disconnect syncing peer if inactive for this long+ } type BlockT m = ReaderT BlockRead m+type WriterT m = ReaderT Writer (ExceptT ImportException (BlockT 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)+ => WriterT m a+ -> BlockT m (Either ImportException a)+runImport f = do+ db <- asks (blockConfDB . myConfig)+ runExceptT (runWriter db f) -runRocksDB :: ReaderT DatabaseReader m a -> ReaderT BlockRead m a+runRocksDB :: ReaderT DatabaseReader m a -> BlockT m a runRocksDB f = ReaderT $ \BlockRead {myConfig = BlockStoreConfig {blockConfDB = db}} -> runReaderT f db -instance MonadIO m => StoreRead (ReaderT BlockRead m) where- getMaxGap = runRocksDB getMaxGap- getInitialGap = runRocksDB getInitialGap- getNetwork = runRocksDB getNetwork- getBestBlock = runRocksDB getBestBlock- getBlocksAtHeight = runRocksDB . getBlocksAtHeight- getBlock = runRocksDB . getBlock- getTxData = runRocksDB . getTxData- getSpender = runRocksDB . getSpender- getSpenders = runRocksDB . getSpenders- getUnspent = runRocksDB . getUnspent- getBalance = runRocksDB . getBalance- getMempool = runRocksDB getMempool- getAddressesTxs as = runRocksDB . getAddressesTxs as- getAddressesUnspents as = runRocksDB . getAddressesUnspents as- getAddressUnspents a = runRocksDB . getAddressUnspents a- getAddressTxs a = runRocksDB . getAddressTxs a+instance MonadIO m => StoreRead (BlockT m) where+ getMaxGap =+ runRocksDB getMaxGap+ getInitialGap =+ runRocksDB getInitialGap+ getNetwork =+ runRocksDB getNetwork+ getBestBlock =+ runRocksDB getBestBlock+ getBlocksAtHeight =+ runRocksDB . getBlocksAtHeight+ getBlock =+ runRocksDB . getBlock+ getTxData =+ runRocksDB . getTxData+ getSpender =+ runRocksDB . getSpender+ getSpenders =+ runRocksDB . getSpenders+ getUnspent =+ runRocksDB . getUnspent+ getBalance =+ runRocksDB . getBalance+ getMempool =+ runRocksDB getMempool+ getAddressesTxs as =+ runRocksDB . getAddressesTxs as+ getAddressesUnspents as =+ runRocksDB . getAddressesUnspents as+ getAddressUnspents a =+ runRocksDB . getAddressUnspents a+ getAddressTxs a =+ runRocksDB . getAddressTxs a -- | Run block store process. blockStore ::@@ -206,59 +214,51 @@ ts <- newTVarIO HashMap.empty runReaderT (ini >> wipe >> run)- BlockRead- { mySelf = inboxToMailbox inbox- , myConfig = cfg- , myPeer = pb- , myTxs = ts- }+ BlockRead { mySelf = inboxToMailbox inbox+ , myConfig = cfg+ , myPeer = pb+ , myTxs = ts+ } where del x n txs = forM (zip [x ..] txs) $ \(i, tx) -> do- $(logDebugS) "BlockStore" $- "Wiping mempool tx " <> cs (show i) <> "/" <> cs (show n) <>- ": " <>- txHashToHex (txRefHash tx)+ $(logInfoS) "BlockStore" $+ "Deleting "+ <> cs (show i) <> "/" <> cs (show n) <> ": "+ <> txHashToHex (txRefHash tx) <> "…" deleteTx True False (txRefHash tx) wipeit x n txs = do let (txs1, txs2) = splitAt 1000 txs- case txs1 of- [] -> return ()- _ ->- runImport (del x n txs1) >>= \case- Left e -> do- $(logErrorS) "BlockStore" $- "Could not delete mempool, database corrupt: " <>- cs (show e)- throwIO CorruptDatabase- Right _ -> wipeit (x + length txs1) n txs2+ unless (null txs1) $ runImport (del x n txs1) >>= \case+ Left e -> do+ $(logErrorS) "BlockStore" $+ "Could not delete mempool, database corrupt: "+ <> cs (show e)+ throwIO CorruptDatabase+ Right _ -> wipeit (x + length txs1) n txs2 wipe | blockConfWipeMempool cfg = getMempool >>= \mem -> wipeit 1 (length mem) mem | otherwise = return ()- ini = do+ ini = runImport initBest >>= \case Left e -> do $(logErrorS) "BlockStore" $- "Could not initialize block store: " <> fromString (show e)+ "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+ run = withAsync (pingMe (inboxToMailbox inbox)) . const . forever $+ receive inbox >>= ReaderT . runReaderT . processBlockStoreMessage -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)+isInSync :: (MonadLoggerIO m, StoreRead m, MonadReader BlockRead m) => m Bool+isInSync = getBestBlock >>= \case+ Nothing -> do+ $(logErrorS) "BlockStore" "Block database uninitialized"+ throwIO Uninitialized+ Just bb -> do+ cb <- asks (blockConfChain . myConfig) >>= chainGetBest+ return (headerHash (nodeHeader cb) == bb) mempool :: MonadLoggerIO m => Peer -> m () mempool p = do@@ -269,80 +269,84 @@ (MonadUnliftIO m, MonadLoggerIO m) => Peer -> Block- -> ReaderT BlockRead m ()-processBlock peer block = do- void . runMaybeT $ do- checkpeer- blocknode <- getblocknode- p' <- managerPeerText peer =<< asks (blockConfManager . myConfig)- $(logDebugS) "BlockStore" $- "Processing block from peer " <> p' <> ": " <>- blockText blocknode (blockTxns block)- lift (runImport (importBlock block blocknode)) >>= \case- Right deletedtxids -> do- listener <- asks (blockConfListener . myConfig)- $(logInfoS) "BlockStore" $- "Best block: " <> blockText blocknode (blockTxns block)- atomically $ do- mapM_ (listener . StoreTxDeleted) deletedtxids- listener (StoreBestBlock blockhash)- lift (touchPeer peer >> syncMe peer)- Left e -> do- $(logErrorS) "BlockStore" $- "Error importing block: " <> hexhash <> ": " <>- fromString (show e) <>- " from peer " <>- p'- killPeer (PeerMisbehaving (show e)) peer+ -> BlockT m ()+processBlock peer block = void . runMaybeT $ do+ checks <- checkPeer peer+ unless checks mzero+ blocknode <- MaybeT $ getBlockNode peer blockhash+ pt <- managerPeerText peer =<< asks (blockConfManager . myConfig)+ $(logDebugS) "BlockStore" $+ "Processing block : " <> blockText blocknode Nothing+ <> " (peer" <> pt <> ")"+ imported <- lift . runImport $ importBlock block blocknode+ either (failure pt) (success blocknode) imported where header = blockHeader block blockhash = headerHash header hexhash = blockHashToHex blockhash- checkpeer = do- pm <- managerGetPeer peer =<< asks (blockConfManager . myConfig)- case pm of- Nothing -> do- $(logWarnS) "BlockStore" $- "Ignoring block " <> hexhash <> " from disconnected peer"- mzero- Just _ ->- lift (touchPeer peer) >>= \case- True -> return ()- False -> do- p' <-- managerPeerText peer =<<- asks (blockConfManager . myConfig)- $(logDebugS) "BlockStore" $- "Ignoring block " <> hexhash <>- " from non-syncing peer " <>- p'- killPeer (PeerMisbehaving "Sent unpexpected block") peer- mzero- getblocknode =- asks (blockConfChain . myConfig) >>= chainGetBlock blockhash >>= \case- Nothing -> do- p' <-- managerPeerText peer =<< asks (blockConfManager . myConfig)- $(logErrorS) "BlockStore" $- "Header not found for block " <> hexhash <> " sent by peer " <>- p'- killPeer (PeerMisbehaving "Sent unknown block") peer- mzero- Just n -> return n+ success blocknode deletedtxids = do+ $(logInfoS) "BlockStore" $+ "Best block: " <> blockText blocknode (Just block)+ notify deletedtxids+ failure pt e = do+ $(logErrorS) "BlockStore" $+ "Error importing block: "+ <> hexhash <> ": " <> cs (show e)+ <> " (peer " <> pt <> ")"+ killPeer (PeerMisbehaving (show e)) peer+ notify deletedtxids = do+ listener <- asks (blockConfListener . myConfig)+ atomically $ do+ mapM_ (listener . StoreTxDeleted) deletedtxids+ listener (StoreBestBlock blockhash)+ lift (touchPeer peer >> syncMe peer) +checkPeer :: (MonadLoggerIO m, MonadReader BlockRead m) => Peer -> m Bool+checkPeer peer =+ asks (blockConfManager . myConfig)+ >>= managerGetPeer peer+ >>= maybe disconnected (const connected)+ where+ disconnected = do+ $(logDebugS) "BlockStore" "Ignoring data from disconnected peer"+ return False+ connected = touchPeer peer >>= \case+ True -> return True+ False -> remove+ remove = do+ pt <- managerPeerText peer =<< asks (blockConfManager . myConfig)+ $(logDebugS) "BlockStore" $+ "Ignoring data from non-syncing peer: " <> pt+ killPeer (PeerMisbehaving "Sent unpexpected data") peer+ return False++getBlockNode :: (MonadUnliftIO m, MonadLoggerIO m, MonadReader BlockRead m)+ => Peer -> BlockHash -> m (Maybe BlockNode)+getBlockNode peer blockhash = runMaybeT $+ asks (blockConfChain . myConfig)+ >>= chainGetBlock blockhash+ >>= \case+ Nothing -> do+ p' <- managerPeerText peer =<< asks (blockConfManager . myConfig)+ $(logErrorS) "BlockStore" $+ "Header not found for block: "+ <> blockHashToHex blockhash+ <> " (peer " <> p' <> ")"+ killPeer (PeerMisbehaving "Sent unknown block") peer+ mzero+ Just n -> return n+ processNoBlocks :: (MonadUnliftIO m, MonadLoggerIO m) => Peer -> [BlockHash]- -> ReaderT BlockRead m ()+ -> BlockT m () processNoBlocks p hs = do p' <- managerPeerText p =<< asks (blockConfManager . myConfig) forM_ (zip [(1 :: Int) ..] hs) $ \(i, h) -> $(logErrorS) "BlockStore" $- "Block " <> cs (show i) <> "/" <> cs (show (length hs)) <> " " <>- blockHashToHex h <>- " not found by peer " <>- p'+ "Block " <> cs (show i) <> "/" <> cs (show (length hs)) <> " "+ <> blockHashToHex h <> " not found (peer " <> p' <> ")" killPeer (PeerMisbehaving "Did not find requested block(s)") p processTx :: (MonadUnliftIO m, MonadLoggerIO m) => Peer -> Tx -> BlockT m ()@@ -350,7 +354,7 @@ t <- fromIntegral . systemSeconds <$> liftIO getSystemTime p' <- managerPeerText p =<< asks (blockConfManager . myConfig) $(logDebugS) "BlockManager" $- "Received tx " <> txHashToHex (txHash tx) <> " from peer " <> p'+ "Received tx " <> txHashToHex (txHash tx) <> " (peer " <> p' <> ")" addPendingTx $ PendingTx t tx HashSet.empty pruneOrphans :: MonadIO m => BlockT m ()@@ -372,175 +376,192 @@ ts <- asks myTxs atomically $ HashMap.member th <$> readTVar ts -allPendingTxs :: MonadIO m => BlockT m [PendingTx]-allPendingTxs = do- ts <- asks myTxs- atomically $ do- pend <- readTVar ts- writeTVar ts $ HashMap.filter (not . null . pendingDeps) pend- return $ sortit $ HashMap.filter (null . pendingDeps) pend+pendingTxs :: MonadIO m => Int -> BlockT m [PendingTx]+pendingTxs i = asks myTxs >>= \box -> atomically $ do+ pending <- readTVar box+ let (selected, rest) = select pending+ writeTVar box rest+ return selected where- sortit pend =- mapMaybe (flip HashMap.lookup pend . txHash . snd) .- sortTxs . map (pendingTx) $- HashMap.elems pend+ select pend =+ let eligible = HashMap.filter (null . pendingDeps) pend+ orphans = HashMap.difference pend eligible+ selected = take i $ sortit eligible+ remaining = HashMap.filter (`notElem` selected) eligible+ in (selected, remaining <> orphans)+ sortit m =+ let sorted = sortTxs $ map pendingTx $ HashMap.elems m+ txids = map (txHash . snd) sorted+ in mapMaybe (`HashMap.lookup` m) txids -fulfillOrphans :: MonadIO m => TxHash -> BlockT m ()-fulfillOrphans th = do- ts <- asks myTxs- atomically $ do- pend <- readTVar ts- let pend' = HashMap.map upd pend- writeTVar ts pend'+fulfillOrphans :: ( MonadIO m+ , MonadReader BlockRead m+ )+ => TxHash+ -> m ()+fulfillOrphans th = asks myTxs >>= \box ->+ atomically $ modifyTVar box (HashMap.map fulfill) where- upd p = p {pendingDeps = HashSet.delete th (pendingDeps p)}+ fulfill p = p {pendingDeps = HashSet.delete th (pendingDeps p)} -updateOrphans :: (StoreRead m, MonadLoggerIO m, MonadReader BlockRead m) => m ()+updateOrphans+ :: ( StoreRead m+ , MonadLoggerIO m+ , MonadReader BlockRead m+ )+ => m () updateOrphans = do- tb <- asks myTxs- pend1 <- readTVarIO tb- let pend2 = HashMap.filter (not . null . pendingDeps) pend1- pend3 <-- fmap (HashMap.fromList . catMaybes) $- forM (HashMap.elems pend2) $ \p -> do- let tx = pendingTx p- e <- exists (txHash tx)- if e- then return Nothing- else do- uns <-- fmap catMaybes $- forM (txIn tx) (getUnspent . prevOutput)- let f p1 u =- p1- { pendingDeps =- HashSet.delete- (outPointHash (unspentPoint u))- (pendingDeps p1)- }- return $ Just (txHash tx, foldl f p uns)- atomically $ writeTVar tb pend3+ box <- asks myTxs+ pending <- readTVarIO box+ let orphans = HashMap.filter (not . null . pendingDeps) pending+ updated <- forM orphans $ \p -> do+ let tx = pendingTx p+ exists (txHash tx) >>= \case+ True -> return Nothing+ False -> Just <$> fill_deps p+ let pruned = HashMap.map fromJust $ HashMap.filter isJust updated+ atomically $ writeTVar box pruned where- exists th =- getTxData th >>= \case- Nothing -> return False- Just TxData {txDataDeleted = True} -> return False- Just TxData {txDataDeleted = False} -> return True+ exists th = getTxData th >>= \case+ Nothing -> return False+ Just TxData {txDataDeleted = True} -> return False+ Just TxData {txDataDeleted = False} -> return True+ prev_utxos tx = catMaybes <$> mapM (getUnspent . prevOutput) (txIn tx)+ fulfill p unspent =+ let unspent_hash = outPointHash (unspentPoint unspent)+ new_deps = HashSet.delete unspent_hash (pendingDeps p)+ in p {pendingDeps = new_deps}+ fill_deps p = do+ let tx = pendingTx p+ unspents <- prev_utxos tx+ return $ foldl fulfill p unspents -data MemImport- = MemOrphan !PendingTx- | MemImported !TxHash ![TxHash]+newOrphanTx :: (MonadUnliftIO m, MonadLoggerIO m)+ => UnixTime -> Tx -> WriterT m ()+newOrphanTx time tx = do+ $(logDebugS) "BlockStore" $+ "Mempool "+ <> txHashToHex (txHash tx)+ <> ": Orphan"+ box <- lift $ asks myTxs+ unspents <- catMaybes <$> mapM getUnspent prevs+ let unspent_set = HashSet.fromList (map unspentPoint unspents)+ missing_set = HashSet.difference prev_set unspent_set+ missing_txs = HashSet.map outPointHash missing_set+ atomically . modifyTVar box $+ HashMap.insert+ (txHash tx)+ PendingTx { pendingTxTime = time+ , pendingTx = tx+ , pendingDeps = missing_txs+ }+ where+ prev_set = HashSet.fromList prevs+ prevs = map prevOutput (txIn tx) +importMempoolTx :: (MonadUnliftIO m, MonadLoggerIO m)+ => UnixTime -> Tx -> WriterT m (Maybe [TxHash])+importMempoolTx time tx =+ catchError new_mempool_tx handle_error+ where+ tx_hash = txHash tx+ handle_error Orphan = do+ newOrphanTx time tx+ return Nothing+ handle_error _ = do+ $(logDebugS) "BlockStore" $+ "Mempool " <> txHashToHex tx_hash <> ": Failed"+ return Nothing+ new_mempool_tx =+ newMempoolTx tx time >>= \case+ Just deleted -> do+ $(logDebugS) "BlockStore" $+ "Mempool " <> txHashToHex (txHash tx) <> ": OK"+ lift $ fulfillOrphans tx_hash+ return (Just deleted)+ Nothing -> do+ $(logDebugS) "BlockStore" $+ "Mempool " <> txHashToHex (txHash tx) <> ": No action"+ return Nothing+ processMempool :: (MonadUnliftIO m, MonadLoggerIO m) => BlockT m () processMempool = do- allPendingTxs >>= \txs ->- if null txs- then return ()- else go txs+ txs <- pendingTxs 2000+ unless (null txs) $ import_txs txs >>= either failed success where- pend p = do- ex <-- fmap (HashSet.fromList . catMaybes) $- forM (txIn (pendingTx p)) $ \i -> do- let op = prevOutput i- h = outPointHash op- getUnspent op >>= \case- Nothing -> return (Just h)- Just _ -> return Nothing- addPendingTx $ p {pendingDeps = ex}- go txs = do- output <-- runImport . fmap catMaybes . forM txs $ \p -> do- let tx = pendingTx p- t = pendingTxTime p- th = txHash tx- h TxOrphan {} = return (Just (MemOrphan p))- h _ = return Nothing- f =- newMempoolTx tx t >>= \case- Just ls -> do- $(logInfoS) "BlockStore" $- "New mempool tx: " <> txHashToHex th- return (Just (MemImported th ls))- Nothing -> return Nothing- catchError f h- case output of- Left e -> do- $(logErrorS) "BlockStore" $- "Mempool import failed: " <> cs (show e)- Right xs -> do- forM_ xs $ \case- MemOrphan p -> pend p- MemImported th deleted -> do- fulfillOrphans th- l <- asks (blockConfListener . myConfig)- atomically $ do- mapM_ (l . StoreTxDeleted) deleted- l (StoreMempoolNew th)+ run_import p = importMempoolTx (pendingTxTime p) (pendingTx p)+ add_txid p deleted = (txHash (pendingTx p), deleted)+ import_pending p = fmap (add_txid p) <$> run_import p+ import_txs = runImport . mapM import_pending+ failed e = do+ $(logErrorS) "BlockStore" $+ "Mempool import failed: " <> cs (show e)+ throwIO MempoolImportFailed+ success = mapM_ (uncurry notify) . catMaybes+ notify txid deleted = do+ l <- asks (blockConfListener . myConfig)+ atomically $ do+ mapM_ (l . StoreTxDeleted) deleted+ l (StoreMempoolNew txid) processTxs :: (MonadUnliftIO m, MonadLoggerIO m) => Peer -> [TxHash]- -> ReaderT BlockRead m ()-processTxs p hs = do- sync <- isInSync- when sync $ do- p' <- managerPeerText p =<< asks (blockConfManager . myConfig)- $(logDebugS) "BlockStore" $- "Received inventory with " <> cs (show (length hs)) <>- " transactions from peer " <>- p'- xs <-- fmap catMaybes . forM (zip [(1 :: Int) ..] hs) $ \(i, h) ->- haveit h >>= \case- True -> do- $(logDebugS) "BlockStore" $- "Already have tx " <> cs (show i) <> "/" <>- cs (show (length hs)) <>- " " <>- txHashToHex h <>- " offered by peer " <>- p'- return Nothing- False -> do- $(logDebugS) "BlockStore" $- "Requesting transaction " <> cs (show i) <> "/" <>- cs (show (length hs)) <>- " " <>- txHashToHex h <>- " from peer " <>- p'- return (Just h)- unless (null xs) $ go xs+ -> BlockT m ()+processTxs p hs = isInSync >>= \s -> when s $ do+ pt <- managerPeerText p =<< asks (blockConfManager . myConfig)+ $(logDebugS) "BlockStore" $+ "Received inventory with "+ <> cs (show (length hs))+ <> " transactions from peer " <> pt+ xs <- catMaybes <$> zip_counter (process_tx pt)+ unless (null xs) $ go xs where- haveit h =- isPending h >>= \case- True -> return True- False ->- getTxData h >>= \case- Nothing -> return False- Just txd -> return (not (txDataDeleted txd))+ len = length hs+ zip_counter = forM (zip [(1 :: Int) ..] hs) . uncurry+ have_it h = isPending h >>= \case+ True -> return True+ False -> getTxData h >>= \case+ Nothing -> return False+ Just txd -> return (not (txDataDeleted txd))+ process_tx pt i h = have_it h >>= \case+ True -> do_have pt i h+ False -> dont_have pt i h+ do_have pt i h = do+ $(logDebugS) "BlockStore" $+ "Tx inv " <> cs (show i) <> "/" <> cs (show len)+ <> ": " <> txHashToHex h+ <> ": Already have (peer " <> pt <> ")"+ return Nothing+ dont_have pt i h = do+ $(logDebugS) "BlockStore" $+ "Tx inv " <> cs (show i) <> "/" <> cs (show len)+ <> ": " <> txHashToHex h+ <> ": Requesting… (peer " <> pt <> ")"+ return (Just h) go xs = do net <- asks (blockConfNet . myConfig)- let inv =- if getSegWit net- then InvWitnessTx- else InvTx- MGetData (GetData (map (InvVector inv . getTxHash) xs)) `sendMessage` p+ let inv = if getSegWit net then InvWitnessTx else InvTx+ vec = map (InvVector inv . getTxHash) xs+ msg = MGetData (GetData vec)+ msg `sendMessage` p -touchPeer :: MonadIO m => Peer -> ReaderT BlockRead m Bool+touchPeer :: (MonadIO m, MonadReader BlockRead m)+ => Peer -> m Bool touchPeer p = getSyncingState >>= \case Just Syncing {syncingPeer = s} | p == s -> do box <- asks myPeer- now <- fromIntegral . systemSeconds <$> liftIO getSystemTime- atomically . modifyTVar box . fmap $ \x -> x {syncingTime = now}+ now <- fromIntegral . systemSeconds <$>+ liftIO getSystemTime+ atomically . modifyTVar box . fmap $ \x ->+ x {syncingTime = now} return True _ -> return False -checkTime :: (MonadUnliftIO m, MonadLoggerIO m) => ReaderT BlockRead m ()+checkTime :: (MonadUnliftIO m, MonadLoggerIO m) => BlockT m () checkTime = asks myPeer >>= readTVarIO >>= \case Nothing -> return ()@@ -553,98 +574,83 @@ resetPeer killPeer PeerTimeout p -processDisconnect ::- (MonadUnliftIO m, MonadLoggerIO m)+processDisconnect+ :: (MonadUnliftIO m, MonadLoggerIO m) => Peer- -> ReaderT BlockRead m ()+ -> BlockT m () processDisconnect p = asks myPeer >>= readTVarIO >>= \case- Nothing -> return ()- Just Syncing {syncingPeer = p'}- | p == p' -> do- $(logWarnS) "BlockStore" "Syncing peer disconnected"- resetPeer- getPeer >>= \case- Nothing -> do- $(logWarnS) "BlockStore" "No new syncing peer available"- Just peer -> do- ns <-- managerPeerText peer =<<- asks (blockConfManager . myConfig)- $(logWarnS) "BlockStore" $ "New syncing peer " <> ns- syncMe peer- | otherwise -> return ()+ Just Syncing {syncingPeer = p'} | p == p' -> dc+ _ -> return ()+ where+ dc = do+ $(logDebugS) "BlockStore" "Syncing peer disconnected"+ resetPeer+ getPeer >>= \case+ Nothing -> $(logWarnS) "BlockStore" "No peers available"+ Just peer -> do+ ns <- managerPeerText peer =<<+ asks (blockConfManager . myConfig)+ $(logDebugS) "BlockStore" $ "New syncing peer " <> ns+ syncMe peer 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+pruneMempool = isInSync >>= \sync -> when sync $ do+ now <- fromIntegral . systemSeconds <$> liftIO getSystemTime+ getOldMempool now >>= \old -> unless (null old) $ delete_txs old where- deletetxs old = do- forM_ (zip [(1 :: Int) ..] old) $ \(i, txid) -> do- $(logInfoS) "BlockStore" $- "Removing " <> cs (show i) <> "/" <> cs (show (length old)) <>- " old mempool tx " <>- txHashToHex txid- runImport (deleteTx True False txid) >>= \case- Left _ -> return ()- Right txids -> do- listener <- asks (blockConfListener . myConfig)- atomically $ mapM_ (listener . StoreTxDeleted) txids+ delete_txs = mapM_ delete_it+ failed txid e =+ $(logErrorS) "BlockStore" $+ "Could not delete old mempool tx: "+ <> txHashToHex txid <> ": "+ <> cs (show e)+ success txids = do+ $(logDebugS) "BlockStore" $+ "Deleted " <> cs (show (length txids)) <> " txs"+ l <- asks (blockConfListener . myConfig)+ atomically $ mapM_ (l . StoreTxDeleted) txids+ delete_it txid = do+ $(logDebugS) "BlockStore" $+ "Deleting "+ <> ": " <> txHashToHex txid+ <> " (old mempool tx)…"+ runImport (deleteTx True False txid)+ >>= either (failed txid) success 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- p' <- managerPeerText peer =<< asks (blockConfManager . myConfig)- $(logInfoS) "BlockStore" $- "Requesting " <> fromString (show (length vectors)) <>- " blocks from peer " <>- p'- forM_ (zip [(1 :: Int) ..] blocknodes) $ \(i, bn) -> do- $(logDebugS) "BlockStore" $- "Requesting block " <> cs (show i) <> "/" <>- cs (show (length vectors)) <>- " from peer " <>- p' <>- ": " <>- blockText bn []- MGetData (GetData vectors) `sendMessage` peer+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+ vecf = InvVector inv . getBlockHash . headerHash . nodeHeader+ vectors = map vecf blocknodes+ pt <- managerPeerText peer =<< asks (blockConfManager . myConfig)+ $(logDebugS) "BlockStore" $+ "Requesting "+ <> fromString (show (length vectors))+ <> " blocks from peer: " <> pt+ MGetData (GetData vectors) `sendMessage` peer where- checksyncingpeer =- getSyncingState >>= \case- Nothing -> return ()- Just Syncing {syncingPeer = p}- | p == peer -> return ()- | otherwise -> mzero+ checksyncingpeer = getSyncingState >>= \case+ Nothing -> return ()+ Just Syncing {syncingPeer = p}+ | p == peer -> return ()+ | otherwise -> 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+ 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@@ -658,57 +664,67 @@ Nothing -> bestblocknode end syncbest bestblock chainbest | nodeHeader bestblock == nodeHeader chainbest = do- lift updateOrphans >> resetPeer >> mempool peer >> mzero- | nodeHeader syncbest == nodeHeader chainbest = do mzero+ lift updateOrphans+ resetPeer+ mempool peer+ mzero+ | nodeHeader syncbest == nodeHeader chainbest =+ mzero+ | nodeHeight syncbest > nodeHeight bestblock + 500 =+ mzero | otherwise =- when (nodeHeight syncbest > nodeHeight bestblock + 500) mzero+ return () selectblocks chainbest syncbest = do- synctop <-- top- chainbest- (maxsyncheight (nodeHeight chainbest) (nodeHeight syncbest))+ let sync_height = maxsyncheight+ (nodeHeight chainbest)+ (nodeHeight syncbest)+ synctop <- top chainbest sync_height ch <- asks (blockConfChain . myConfig) parents <- chainGetParents (nodeHeight syncbest + 1) synctop ch- return $- if length parents < 500- then parents <> [chainbest]- else parents+ 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)+ top chainbest syncheight = 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))+ then return chainbest+ else findancestor chainbest syncheight+ findancestor chainbest syncheight = do+ ch <- asks (blockConfChain . myConfig)+ m <- chainGetAncestor syncheight chainbest ch+ case m of+ 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- lift (runImport (revertBlock 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+ unless y $ do_revert bestblockhash+ fail_revert e = do+ $(logErrorS) "BlockStore" $+ "Could not revert best block: " <> cs (show e)+ throwIO e+ success_revert bestblockhash txids = do+ listener <- asks (blockConfListener . myConfig)+ atomically $ do+ mapM_ (listener . StoreTxDeleted) txids+ listener (StoreBlockReverted bestblockhash)+ reverttomainchain+ do_revert bestblockhash = do+ $(logErrorS) "BlockStore" $+ "Reverting best block: "+ <> blockHashToHex bestblockhash+ resetPeer+ lift (runImport (revertBlock bestblockhash)) >>=+ either fail_revert (success_revert bestblockhash) resetPeer :: (MonadLoggerIO m, MonadReader BlockRead m) => m () resetPeer = do@@ -806,10 +822,12 @@ blockStoreTxHashSTM peer txhashes store = TxRefAvailable peer txhashes `sendSTM` store -blockText :: BlockNode -> [Tx] -> Text-blockText bn txs- | null txs = height <> sep <> time <> sep <> hash- | otherwise = height <> sep <> time <> sep <> txcount <> sep <> hash+blockText :: BlockNode -> Maybe Block -> Text+blockText bn mblock = case mblock of+ Nothing ->+ height <> sep <> time <> sep <> hash+ Just block ->+ height <> sep <> time <> sep <> hash <> sep <> size block where height = cs $ show (nodeHeight bn) systime =@@ -818,5 +836,5 @@ cs $ formatTime defaultTimeLocale (iso8601DateFormat (Just "%H:%M")) systime hash = blockHashToHex (headerHash (nodeHeader bn))- txcount = cs (show (length txs)) <> " txs" sep = " | "+ size = (<> " bytes") . cs . show . B.length . encode
src/Haskoin/Store/Cache.hs view
@@ -1,13 +1,12 @@-{-# LANGUAGE ApplicativeDo #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-} module Haskoin.Store.Cache ( CacheConfig(..) , CacheT@@ -44,8 +43,7 @@ import Data.List (sort) import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes, mapMaybe)-import Data.Serialize (decode, encode)-import Data.Serialize (Serialize)+import Data.Serialize (Serialize, decode, encode) import Data.String.Conversions (cs) import Data.Text (Text) import Data.Time.Clock.System (getSystemTime, systemSeconds)@@ -69,17 +67,18 @@ xPubCompatWitnessAddr, xPubExport, xPubWitnessAddr) import Haskoin.Node (Chain, chainBlockMain,- chainGetAncestor, chainGetBlock)+ chainGetAncestor, chainGetBest,+ chainGetBlock) import Haskoin.Store.Common (Limits (..), Start (..), StoreRead (..), sortTxs, xPubBals, xPubBalsTxs, xPubBalsUnspents, xPubTxs) import Haskoin.Store.Data (Balance (..), BlockData (..),- BlockRef (..), TxRef (..),- DeriveType (..), Prev (..),- TxData (..), Unspent (..),- XPubBal (..), XPubSpec (..),- XPubUnspent (..), nullBalance)+ BlockRef (..), DeriveType (..),+ Prev (..), TxData (..), TxRef (..),+ Unspent (..), XPubBal (..),+ XPubSpec (..), XPubUnspent (..),+ nullBalance) import NQE (Inbox, Mailbox, receive, send) import System.Random (randomIO, randomRIO) import UnliftIO (Exception, MonadIO, MonadUnliftIO,@@ -95,19 +94,17 @@ $(logErrorS) "Cache" $ "Got error from Redis: " <> cs (show e) throwIO (RedisError e) -data CacheConfig =- CacheConfig- { cacheConn :: !Connection- , cacheMin :: !Int- , cacheMax :: !Integer- , cacheChain :: !Chain- }+data CacheConfig = CacheConfig+ { cacheConn :: !Connection+ , cacheMin :: !Int+ , cacheMax :: !Integer+ , cacheChain :: !Chain+ } type CacheT = ReaderT (Maybe CacheConfig) type CacheX = ReaderT CacheConfig -data CacheError- = RedisError Reply+data CacheError = RedisError Reply | RedisTxError !String | LogicError !String deriving (Show, Eq, Generic, NFData, Exception)@@ -154,7 +151,7 @@ getMaxGap = lift getMaxGap getInitialGap = lift getInitialGap -withCache :: StoreRead m => (Maybe CacheConfig) -> CacheT m a -> m a+withCache :: StoreRead m => Maybe CacheConfig -> CacheT m a -> m a withCache s f = runReaderT f s balancesPfx :: ByteString@@ -207,7 +204,7 @@ True -> do bals <- cacheGetXPubBalances xpub process bals- False -> do+ False -> newXPubC xpub >>= \(bals, t) -> if t then do@@ -236,7 +233,7 @@ uns xpubutxo = mapMaybe- (\(a, u) -> (\p -> XPubUnspent p u) <$> Map.lookup a addrmap)+ (\(a, u) -> (`XPubUnspent` u) <$> Map.lookup a addrmap) addrutxo xpubtxt <- xpubText xpub $(logDebugS) "Cache" $@@ -339,8 +336,7 @@ redisGetXPubBalances :: (Functor f, RedisCtx m f) => XPubSpec -> m (f [XPubBal]) redisGetXPubBalances xpub =- getAllFromMap (balancesPfx <> encode xpub) >>=- return . fmap (sort . map (uncurry f))+ fmap (sort . map (uncurry f)) <$> getAllFromMap (balancesPfx <> encode xpub) where f p b = XPubBal {xPubBalPath = p, xPubBal = b} @@ -350,7 +346,7 @@ where h' = (fromIntegral h .&. 0x07ffffff) `shift` 26 :: Word64 p' = (fromIntegral p .&. 0x03ffffff) :: Word64-blockRefScore MemRef {memRefTime = t} = 0 - t'+blockRefScore MemRef {memRefTime = t} = negate t' where t' = fromIntegral (t .&. 0x001fffffffffffff) @@ -417,18 +413,17 @@ , let Right v = decode v' ] -data CacheWriterMessage- = CacheNewBlock+data CacheWriterMessage = CacheNewBlock | CacheNewTx !TxHash type CacheWriterInbox = Inbox CacheWriterMessage type CacheWriter = Mailbox CacheWriterMessage -data AddressXPub =- AddressXPub- { addressXPubSpec :: !XPubSpec- , addressXPubPath :: ![KeyIndex]- } deriving (Show, Eq, Generic, NFData, Serialize)+data AddressXPub = AddressXPub+ { addressXPubSpec :: !XPubSpec+ , addressXPubPath :: ![KeyIndex]+ }+ deriving (Show, Eq, Generic, NFData, Serialize) mempoolSetKey :: ByteString mempoolSetKey = "mempool"@@ -515,11 +510,11 @@ Just bs -> if read (cs bs) == i then do- runRedis (Redis.del [k]) >> return ()+ void $ runRedis (Redis.del [k]) $(logDebugS) "Cache" $ "Released " <> cs k <> " lock with value " <> cs (show i)- else do+ else $(logErrorS) "Cache" $ "Could not release " <> cs k <> " lock: value is not " <> cs (show i)@@ -552,7 +547,7 @@ go pruneDB :: (MonadUnliftIO m, MonadLoggerIO m, StoreRead m) => CacheX m Integer-pruneDB = do+pruneDB = isAnythingCached >>= \case True -> do x <- asks cacheMax@@ -562,7 +557,7 @@ else return 0 False -> return 0 where- flush n = do+ flush n = case min 1000 (n `div` 64) of 0 -> return 0 x ->@@ -588,21 +583,8 @@ (MonadUnliftIO m, MonadLoggerIO m, StoreRead m) => CacheWriterMessage -> CacheX m ()-cacheWriterReact CacheNewBlock = newBlockC-cacheWriterReact (CacheNewTx th) =- withLockWait importLockKey $ do- runRedis (Redis.zscore mempoolSetKey (encode th)) >>= \case- Nothing ->- lift (getTxData th) >>= \case- Just td -> do- importMultiTxC [td]- $(logDebugS) "Cache" $- "Updated cache with tx: " <> txHashToHex th- Nothing ->- $(logErrorS) "Cache" $- "Tx not found in db: " <> txHashToHex th- Just _ ->- $(logDebugS) "Cache" $ "Tx already in cache: " <> txHashToHex th+cacheWriterReact CacheNewBlock = newBlockC+cacheWriterReact (CacheNewTx th) = newTxC th lenNotNull :: [XPubBal] -> Int lenNotNull bals = length $ filter (not . nullBalance . xPubBal) bals@@ -612,21 +594,25 @@ => XPubSpec -> CacheX m ([XPubBal], Bool) newXPubC xpub =- cachePrime >> do- bals <- lift $ xPubBals xpub- x <- asks cacheMin- xpubtxt <- xpubText xpub- let n = lenNotNull bals- if x <= n- then do- go bals- return (bals, True)- else do- $(logDebugS) "Cache" $- "Not caching xpub with " <> cs (show n) <>- " used addresses: " <>- xpubtxt- return (bals, False)+ cachePrime >>= \case+ Nothing -> do+ bals <- lift $ xPubBals xpub+ return (bals, False)+ Just _ -> do+ bals <- lift $ xPubBals xpub+ x <- asks cacheMin+ xpubtxt <- xpubText xpub+ let n = lenNotNull bals+ if x <= n+ then do+ go bals+ return (bals, True)+ else do+ $(logDebugS) "Cache" $+ "Not caching xpub with " <> cs (show n) <>+ " used addresses: " <>+ xpubtxt+ return (bals, False) where op XPubUnspent {xPubUnspent = u} = (unspentPoint u, unspentBlock u) go bals = do@@ -655,8 +641,30 @@ d <- redisAddXPubUnspents xpub (map op utxo) e <- redisAddXPubTxs xpub xtxs return $ b >> c >> d >> e >> return ()+ $(logDebugS) "Cache" $ "Done caching xpub: " <> xpubtxt++newTxC ::+ (MonadUnliftIO m, MonadLoggerIO m, StoreRead m) => TxHash -> CacheX m ()+newTxC th =+ withLockWait importLockKey $+ isAnythingCached >>= \case+ False -> $(logDebugS) "Cache" $- "Done caching xpub: " <> xpubtxt+ "Not importing tx " <> txHashToHex th <> " because cache is empty"+ True ->+ runRedis (Redis.zscore mempoolSetKey (encode th)) >>= \case+ Nothing ->+ lift (getTxData th) >>= \case+ Just td -> do+ importMultiTxC [td]+ $(logDebugS) "Cache" $+ "Updated cache with tx: " <> txHashToHex th+ Nothing ->+ $(logErrorS) "Cache" $+ "Tx not found in db: " <> txHashToHex th+ Just _ ->+ $(logDebugS) "Cache" $+ "Tx already in cache: " <> txHashToHex th newBlockC :: (MonadUnliftIO m, MonadLoggerIO m, StoreRead m) => CacheX m () newBlockC = withLockWait importLockKey f@@ -692,7 +700,7 @@ Just cacheheadnode -> chainBlockMain cachehead ch >>= \case False -> do- $(logWarnS) "Cache" $+ $(logDebugS) "Cache" $ "Reverting cache head not in main chain: " <> blockHashToHex cachehead removeHeadC >> f@@ -708,17 +716,17 @@ cs (blockHashToHex newhead) Just newheadnode -> next newheadnode cacheheadnode- next newheadnode cacheheadnode =- asks cacheChain >>= \ch ->- chainGetAncestor (nodeHeight cacheheadnode + 1) newheadnode ch >>= \case- Nothing -> do- $(logErrorS) "Cache" $- "Ancestor not found at height " <>- cs (show (nodeHeight cacheheadnode + 1)) <>- " for block: " <>- blockHashToHex (headerHash (nodeHeader newheadnode))- Just newcachenode ->- importBlockC (headerHash (nodeHeader newcachenode)) >> f+ next newheadnode cacheheadnode = do+ ch <- asks cacheChain+ chainGetAncestor (nodeHeight cacheheadnode + 1) newheadnode ch >>= \case+ Nothing ->+ $(logWarnS) "Cache" $+ "Ancestor not found at height " <>+ cs (show (nodeHeight cacheheadnode + 1)) <>+ " for block: " <>+ blockHashToHex (headerHash (nodeHeader newheadnode))+ Just newcachenode ->+ importBlockC (headerHash (nodeHeader newcachenode)) >> f importBlockC :: (MonadUnliftIO m, StoreRead m, MonadLoggerIO m) => BlockHash -> CacheX m () importBlockC bh =@@ -727,7 +735,7 @@ $(logErrorS) "Cache" $ "Could not get block: " <> blockHashToHex bh throwIO . LogicError . cs $ "Could not get block: " <> blockHashToHex bh- Just bd -> do+ Just bd -> go bd where go bd = do@@ -794,13 +802,13 @@ " xpubs…" xmap <- getxbals xpubs let addrmap' = faddrmap (HashMap.keysSet xmap) addrmap- $(logDebugS) "Cache" $ "Starting Redis import pipeline…"+ $(logDebugS) "Cache" "Starting Redis import pipeline…" runRedis $ do x <- redisImportMultiTx addrmap' unspentmap txs y <- redisUpdateBalances addrmap' balmap z <- redisTouchKeys now (HashMap.keys xmap) return $ x >> y >> z >> return ()- $(logDebugS) "Cache" $ "Completed Redis pipeline"+ $(logDebugS) "Cache" "Completed Redis pipeline" return $ getNewAddrs gap xmap (HashMap.elems addrmap') cacheAddAddresses addrs' where@@ -813,7 +821,7 @@ HashMap.fromList . catMaybes . zipWith (\p -> fmap (p, )) allops <$> lift (mapM getUnspent allops) getbalances addrs =- HashMap.fromList . zipWith (,) addrs <$> mapM (lift . getBalance) addrs+ HashMap.fromList . zip addrs <$> mapM (lift . getBalance) addrs getxbals xpubs = do bals <- runRedis . fmap sequence . forM xpubs $ \xpub -> do@@ -836,7 +844,7 @@ -> m (f ()) redisImportMultiTx addrmap unspentmap txs = do xs <- mapM importtxentries txs- return $ sequence xs >> return ()+ return $ sequence_ xs where uns p i = case HashMap.lookup p unspentmap of@@ -869,7 +877,7 @@ then do x <- mapM (uncurry (remtx tx)) (txaddrops tx) y <- redisRemFromMempool [txHash (txData tx)]- return $ sequence x >> y >> return ()+ return $ sequence_ x >> void y else do a <- sequence <$> mapM (uncurry (addtx tx)) (txaddrops tx) b <-@@ -883,9 +891,7 @@ } _ -> redisRemFromMempool [txHash (txData tx)] return $ a >> b >> return ()- txaddrops td = spnts td <> utxos td- spnts td = txInputs td- utxos td = txOutputs td+ txaddrops td = txInputs td <> txOutputs td redisUpdateBalances :: (Monad f, RedisCtx m f)@@ -910,22 +916,22 @@ cacheAddAddresses addrs = do $(logDebugS) "Cache" $ "Adding " <> cs (show (length addrs)) <> " new generated addresses"- $(logDebugS) "Cache" $ "Getting balances…"+ $(logDebugS) "Cache" "Getting balances…" balmap <- HashMap.fromListWith (<>) <$> mapM (uncurry getbal) addrs- $(logDebugS) "Cache" $ "Getting unspent outputs…"+ $(logDebugS) "Cache" "Getting unspent outputs…" utxomap <- HashMap.fromListWith (<>) <$> mapM (uncurry getutxo) addrs- $(logDebugS) "Cache" $ "Getting transactions…"+ $(logDebugS) "Cache" "Getting transactions…" txmap <- HashMap.fromListWith (<>) <$> mapM (uncurry gettxmap) addrs withLockWait lockKey $ do- $(logDebugS) "Cache" $ "Running Redis pipeline…"+ $(logDebugS) "Cache" "Running Redis pipeline…" runRedis $ do a <- forM (HashMap.toList balmap) (uncurry redisAddXPubBalances) b <- forM (HashMap.toList utxomap) (uncurry redisAddXPubUnspents) c <- forM (HashMap.toList txmap) (uncurry redisAddXPubTxs)- return $ sequence a >> sequence b >> sequence c >> return ()- $(logDebugS) "Cache" $ "Completed Redis pipeline"+ return $ sequence_ a >> sequence_ b >> sequence_ c+ $(logDebugS) "Cache" "Completed Redis pipeline" let xpubs = HashSet.toList . HashSet.fromList . map addressXPubSpec $ Map.elems amap- $(logDebugS) "Cache" $ "Getting xpub balances…"+ $(logDebugS) "Cache" "Getting xpub balances…" xmap <- getbals xpubs gap <- lift getMaxGap let notnulls = getnotnull balmap@@ -977,8 +983,8 @@ syncMempoolC :: (MonadUnliftIO m, MonadLoggerIO m, StoreRead m) => CacheX m () syncMempoolC = do- nodepool <- (HashSet.fromList . map txRefHash) <$> lift getMempool- cachepool <- (HashSet.fromList . map txRefHash) <$> cacheGetMempool+ nodepool <- HashSet.fromList . map txRefHash <$> lift getMempool+ cachepool <- HashSet.fromList . map txRefHash <$> cacheGetMempool txs <- mapM getit . HashSet.toList $ mappend@@ -1018,21 +1024,30 @@ $(logInfoS) "Cache" "Best block not set yet" return Nothing Just newhead -> do- mem <- lift getMempool- withLockWait lockKey $ do- $(logDebugS) "Cache" "Priming cache…"- x <- runRedis $ do- a <- redisAddToMempool mem- b <- redisSetHead newhead- return $ a >> b >> return (Just newhead)- $(logDebugS) "Cache" "Primed"- return x- Just cachehead -> return $ Just cachehead+ ch <- asks cacheChain+ chbest <- chainGetBest ch+ if headerHash (nodeHeader chbest) == newhead+ then do+ mem <- lift getMempool+ withLockWait lockKey $ do+ $(logDebugS) "Cache" "Priming cache…"+ runRedis $ do+ a <- redisAddToMempool mem+ b <- redisSetHead newhead+ return $ a >> b+ $(logDebugS) "Cache" "Primed"+ return (Just newhead)+ else do+ $(logDebugS)+ "Cache"+ "Not priming cache because not in sync"+ return Nothing+ Just cachehead -> return (Just cachehead) cacheSetHead :: (MonadLoggerIO m, StoreRead m) => BlockHash -> CacheX m () cacheSetHead bh = do $(logDebugS) "Cache" $ "Cache head set to: " <> blockHashToHex bh- runRedis (redisSetHead bh) >> return ()+ void $ runRedis (redisSetHead bh) cacheGetAddrsInfo :: MonadLoggerIO m => [Address] -> CacheX m [Maybe AddressXPub]@@ -1136,7 +1151,7 @@ (balanceAddress (xPubBal b)) AddressXPub {addressXPubSpec = xpub, addressXPubPath = xPubBalPath b}- return $ sequence xs >> sequence ys >> return ()+ return $ sequence_ xs >> sequence_ ys where entries = map (\b -> (encode (xPubBalPath b), encode (xPubBal b))) bals @@ -1177,7 +1192,7 @@ 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+ in mapMaybe (`Map.lookup` txm) ths txInputs :: TxData -> [(Address, OutPoint)] txInputs td =@@ -1210,9 +1225,7 @@ redisGetMempool :: (Applicative f, RedisCtx m f) => m (f [TxRef]) redisGetMempool = do xs <- getFromSortedSet mempoolSetKey Nothing 0 0- return $ do- ys <- xs- return $ map (uncurry f) ys+ return $ map (uncurry f) <$> xs where f t s = TxRef {txRefBlock = scoreBlockRef s, txRefHash = t}
src/Haskoin/Store/Common.hs view
@@ -12,6 +12,8 @@ , StoreWrite(..) , StoreEvent(..) , PubExcept(..)+ , getActiveBlock+ , getActiveTxData , xPubBalsTxs , xPubBalsUnspents , getTransaction@@ -51,9 +53,9 @@ txHash) import Haskoin.Node (Peer) import Haskoin.Store.Data (Balance (..), BlockData (..),- TxRef (..), DeriveType (..),- Spender, Transaction, TxData,- UnixTime, Unspent (..),+ DeriveType (..), Spender,+ Transaction, TxData (..),+ TxRef (..), UnixTime, Unspent (..), XPubBal (..), XPubSpec (..), XPubSummary (..), XPubUnspent (..), nullBalance, toTransaction)@@ -64,20 +66,20 @@ type Offset = Word32 type Limit = Word32 -data Start- = AtTx- { atTxHash :: !TxHash- }+data Start = AtTx+ { atTxHash :: !TxHash+ } | AtBlock- { atBlockHeight :: !BlockHeight- } deriving (Eq, Show)+ { atBlockHeight :: !BlockHeight+ }+ deriving (Eq, Show) -data Limits =- Limits- { limit :: !Word32- , offset :: !Word32- , start :: !(Maybe Start)- } deriving (Eq, Show)+data Limits = Limits+ { limit :: !Word32+ , offset :: !Word32+ , start :: !(Maybe Start)+ }+ deriving (Eq, Show) defaultLimits :: Limits defaultLimits = Limits { limit = 0, offset = 0, start = Nothing }@@ -98,7 +100,7 @@ getBalance :: Address -> m Balance getBalance a = head <$> getBalances [a] getBalances :: [Address] -> m [Balance]- getBalances as = mapM getBalance as+ getBalances = mapM getBalance getAddressesTxs :: [Address] -> Limits -> m [TxRef] getAddressTxs :: Address -> Limits -> m [TxRef] getAddressTxs a = getAddressesTxs [a]@@ -119,11 +121,10 @@ chg <- derive_until_gap gap 1 (aderiv 1 0) return (ext1 <> ext2 <> chg) where- aderiv m n =+ aderiv m = deriveAddresses (deriveFunction (xPubDeriveType xpub)) (pubSubKey (xPubSpecKey xpub) m)- n xbalance m b n = XPubBal {xPubBalPath = [m, n], xPubBal = b} derive_until_gap _ _ [] = return [] derive_until_gap gap m as = do@@ -163,19 +164,10 @@ xPubUnspents :: XPubSpec -> Limits -> m [XPubUnspent] xPubUnspents xpub limits = do xs <- filter positive <$> xPubBals xpub- sortBy (compare `on` unsblock) . applyLimits limits <$> go xs+ sortBy (compare `on` unsblock) . applyLimits limits <$> xUns limits xs where unsblock = unspentBlock . xPubUnspent positive XPubBal {xPubBal = Balance {balanceUnspentCount = c}} = c > 0- go [] = return []- go (XPubBal {xPubBalPath = p, xPubBal = Balance {balanceAddress = a}}:xs) = do- uns <- getAddressUnspents a (deOffset limits)- let xuns =- map- (\t ->- XPubUnspent {xPubUnspentPath = p, xPubUnspent = t})- uns- (xuns <>) <$> go xs xPubTxs :: XPubSpec -> Limits -> m [TxRef] xPubTxs xpub limits = do bs <- xPubBals xpub@@ -200,6 +192,25 @@ insertUnspent :: Unspent -> m () deleteUnspent :: OutPoint -> m () ++getActiveBlock :: StoreRead m => BlockHash -> m (Maybe BlockData)+getActiveBlock bh = getBlock bh >>= \case+ Just b | blockDataMainChain b -> return (Just b)+ _ -> return Nothing++getActiveTxData :: StoreRead m => TxHash -> m (Maybe TxData)+getActiveTxData th = getTxData th >>= \case+ Just td | not (txDataDeleted td) -> return (Just td)+ _ -> return Nothing++xUns :: StoreRead f => Limits -> [XPubBal] -> f [XPubUnspent]+xUns limits bs = concat <$> mapM g bs+ where+ f p t = XPubUnspent {xPubUnspentPath = p, xPubUnspent = t}+ g b =+ map (f (xPubBalPath b)) <$>+ getAddressUnspents (balanceAddress (xPubBal b)) (deOffset limits)+ deriveAddresses :: DeriveAddr -> XPubKey -> Word32 -> [(Word32, Address)] deriveAddresses derive xpub start = map (\i -> (i, derive xpub i)) [start ..] @@ -215,17 +226,9 @@ -> m [XPubUnspent] xPubBalsUnspents bals limits = do let xs = filter positive bals- applyLimits limits <$> go xs+ applyLimits limits <$> xUns limits 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 (deOffset limits)- let xuns =- map- (\t -> XPubUnspent {xPubUnspentPath = p, xPubUnspent = t})- uns- (xuns <>) <$> go xs xPubBalsTxs :: StoreRead m@@ -265,28 +268,18 @@ -- | Events that the store can generate.-data StoreEvent- = StoreBestBlock !BlockHash- -- ^ new best block+data StoreEvent = StoreBestBlock !BlockHash | 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+data PubExcept = PubNoPeers | PubReject RejectCode | PubTimeout | PubPeerDisconnected
− src/Haskoin/Store/Database/Memory.hs
@@ -1,303 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-module Haskoin.Store.Database.Memory- ( MemoryState(..)- , MemoryDatabase(..)- , withMemoryDatabase- , emptyMemoryDatabase- , getMempoolH- , 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.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as M-import Data.IntMap.Strict (IntMap)-import qualified Data.IntMap.Strict as I-import Data.Maybe (fromJust, fromMaybe, isJust)-import Data.Word (Word32)-import Haskoin (Address, BlockHash, BlockHeight,- Network, OutPoint (..), TxHash,- headerHash, txHash)-import Haskoin.Store.Common (StoreRead (..), StoreWrite (..))-import Haskoin.Store.Data (Balance (..), BlockData (..),- BlockRef (..), TxRef (..),- Spender, TxData (..),- Unspent (..), zeroBalance)-import Haskoin.Store.Database.Types (BalVal, OutVal (..), UnspentVal,- balanceToVal, unspentToVal,- valToBalance, valToUnspent)-import UnliftIO--data MemoryState =- MemoryState- { memoryDatabase :: !(TVar MemoryDatabase)- , memoryMaxGap :: !Word32- , memoryInitialGap :: !Word32- , memoryNetwork :: !Network- }--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 [TxRef])- } 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- }--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 mem =- fromMaybe (zeroBalance a) . fmap (valToBalance a) . M.lookup a $- hBalance mem--getMempoolH :: MemoryDatabase -> Maybe [TxRef]-getMempoolH = hMempool--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 (balanceAddress bal) b (hBalance db)}- where- b = balanceToVal bal--insertAddrTxH :: Address -> TxRef -> MemoryDatabase -> MemoryDatabase-insertAddrTxH a btx db =- let s =- M.singleton- a- (M.singleton- (txRefBlock btx)- (M.singleton (txRefHash btx) True))- in db {hAddrTx = M.unionWith (M.unionWith M.union) s (hAddrTx db)}--deleteAddrTxH :: Address -> TxRef -> MemoryDatabase -> MemoryDatabase-deleteAddrTxH a btx db =- let s =- M.singleton- a- (M.singleton- (txRefBlock btx)- (M.singleton (txRefHash 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 :: [TxRef] -> MemoryDatabase -> MemoryDatabase-setMempoolH xs db = db {hMempool = Just xs}--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- 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 = undefined- getAddressesUnspents = undefined- getAddressTxs = undefined- getAddressUnspents = undefined- getMaxGap = R.asks memoryMaxGap- getInitialGap = R.asks memoryInitialGap- getNetwork = R.asks memoryNetwork--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)- setBalance b = do- v <- R.asks memoryDatabase- atomically $ modifyTVar v (setBalanceH b)- insertUnspent h = do- v <- R.asks memoryDatabase- atomically $ modifyTVar v (insertUnspentH h)- deleteUnspent p = do- v <- R.asks memoryDatabase- atomically $ modifyTVar v (deleteUnspentH p)
src/Haskoin/Store/Database/Reader.hs view
@@ -142,8 +142,7 @@ getBalanceDB a DatabaseReader { databaseReadOptions = opts , databaseHandle = db } =- fromMaybe (zeroBalance a) . fmap (valToBalance a) <$>- retrieve db opts (BalKey a)+ maybe (zeroBalance a) (valToBalance a) <$> retrieve db opts (BalKey a) getMempoolDB :: MonadIO m => DatabaseReader -> m [TxRef] getMempoolDB DatabaseReader {databaseReadOptions = opts, databaseHandle = db} =
src/Haskoin/Store/Database/Types.hs view
@@ -66,18 +66,15 @@ put AddrTxKey { addrTxKeyA = a , addrTxKeyT = TxRef {txRefBlock = b, txRefHash = t} } = do- putWord8 0x05- put a- put b+ put AddrTxKeyB {addrTxKeyA = a, addrTxKeyB = b} put t -- 0x05 · Address put AddrTxKeyA {addrTxKeyA = a} = do- putWord8 0x05+ put AddrTxKeyS put a -- 0x05 · Address · BlockRef put AddrTxKeyB {addrTxKeyA = a, addrTxKeyB = b} = do- putWord8 0x05- put a+ put AddrTxKeyA {addrTxKeyA = a} put b -- 0x05 put AddrTxKeyS = putWord8 0x05@@ -113,18 +110,15 @@ -- 0x06 · StoreAddr · BlockRef · OutPoint where put AddrOutKey {addrOutKeyA = a, addrOutKeyB = b, addrOutKeyP = p} = do- putWord8 0x06- put a- put b+ put AddrOutKeyB {addrOutKeyA = a, addrOutKeyB = b} put p -- 0x06 · StoreAddr · BlockRef put AddrOutKeyB {addrOutKeyA = a, addrOutKeyB = b} = do- putWord8 0x06- put a+ put AddrOutKeyA {addrOutKeyA = a} put b -- 0x06 · StoreAddr put AddrOutKeyA {addrOutKeyA = a} = do- putWord8 0x06+ put AddrOutKeyS put a -- 0x06 put AddrOutKeyS = putWord8 0x06@@ -166,9 +160,9 @@ instance Serialize SpenderKey where -- 0x10 · TxHash · Index put (SpenderKey OutPoint {outPointHash = h, outPointIndex = i}) = do- putWord8 0x10- put h+ put (SpenderKeyS h) put i+ -- 0x10 · TxHash put (SpenderKeyS h) = do putWord8 0x10 put h@@ -225,8 +219,7 @@ instance Serialize MemKey where -- 0x07- put MemKey = do- putWord8 0x07+ put MemKey = putWord8 0x07 get = do guard . (== 0x07) =<< getWord8 return MemKey
src/Haskoin/Store/Database/Writer.hs view
@@ -1,84 +1,208 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Haskoin.Store.Database.Writer- ( DatabaseWriter- , runDatabaseWriter+ ( Writer+ , runWriter ) where import Control.Applicative ((<|>))-import Control.Monad (join)+import Control.DeepSeq (NFData) 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 qualified Data.ByteString.Short as B.Short+import Data.Hashable (Hashable) 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 Data.Maybe (fromJust, isJust, maybeToList) import Database.RocksDB (BatchOp) import Database.RocksDB.Query (deleteOp, insertOp, writeBatch)+import GHC.Generics (Generic) import Haskoin (Address, BlockHash, BlockHeight,- OutPoint (..), TxHash)+ OutPoint (..), TxHash,+ headerHash, txHash) import Haskoin.Store.Common (StoreRead (..), StoreWrite (..))-import Haskoin.Store.Data (Balance, BlockData,- BlockRef (..), TxRef (..),- Spender, TxData, Unspent,- nullBalance, zeroBalance)-import Haskoin.Store.Database.Memory (MemoryDatabase (..),- MemoryState (..),- emptyMemoryDatabase,- getMempoolH, getSpenderH,- getSpendersH, getUnspentH,- withMemoryDatabase)+import Haskoin.Store.Data (Balance (..), BlockData (..),+ BlockRef (..), Spender,+ TxData (..), TxRef (..),+ Unspent (..)) import Haskoin.Store.Database.Reader (DatabaseReader (..), withDatabaseReader) import Haskoin.Store.Database.Types (AddrOutKey (..), AddrTxKey (..), BalKey (..), BalVal (..), BestKey (..), BlockKey (..), HeightKey (..), MemKey (..),- OutVal, SpenderKey (..),+ OutVal (..), SpenderKey (..), TxKey (..), UnspentKey (..),- UnspentVal (..))-import UnliftIO (MonadIO, newTVarIO, readTVarIO)+ UnspentVal (..), balanceToVal,+ unspentToVal, valToBalance,+ valToUnspent)+import UnliftIO (MonadIO, TVar, atomically,+ modifyTVar, newTVarIO,+ readTVarIO) -data DatabaseWriter = DatabaseWriter- { databaseWriterReader :: !DatabaseReader- , databaseWriterState :: !MemoryState- }+data Dirty a = Modified a | Deleted+ deriving (Eq, Show, Generic, Hashable, NFData) -runDatabaseWriter ::- (MonadIO m, MonadError e m)+instance Functor Dirty where+ fmap _ Deleted = Deleted+ fmap f (Modified a) = Modified (f a)++data Writer = Writer { getReader :: !DatabaseReader+ , getState :: !(TVar Memory) }++instance MonadIO m => StoreRead (ReaderT Writer m) where+ getInitialGap =+ R.asks (databaseInitialGap . getReader)+ getNetwork =+ R.asks (databaseNetwork . getReader)+ 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+ getUnspent a =+ R.ask >>= getUnspentI a+ getBalance a =+ R.ask >>= getBalanceI a+ getMempool =+ R.ask >>= getMempoolI+ getAddressesTxs =+ undefined+ getAddressesUnspents =+ undefined+ getMaxGap =+ R.asks (databaseMaxGap . getReader)++instance MonadIO m => StoreWrite (ReaderT Writer 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+ insertUnspent u =+ R.ask >>= insertUnspentI u+ deleteUnspent p =+ R.ask >>= deleteUnspentI p+ setBalance b =+ R.ask >>= setBalanceI b++data Memory = Memory+ { hBest+ :: !(Maybe BlockHash)+ , hBlock+ :: !(HashMap BlockHash BlockData)+ , hHeight+ :: !(HashMap BlockHeight [BlockHash])+ , hTx+ :: !(HashMap TxHash TxData)+ , hSpender+ :: !(HashMap TxHash+ (IntMap (Dirty Spender)))+ , hUnspent+ :: !(HashMap TxHash+ (IntMap (Dirty UnspentVal)))+ , hBalance+ :: !(HashMap Address BalVal)+ , hAddrTx+ :: !(HashMap Address+ (HashMap TxRef (Dirty ())))+ , hAddrOut+ :: !(HashMap Address+ (HashMap BlockRef+ (HashMap OutPoint (Dirty OutVal))))+ , hMempool+ :: !(Maybe [TxRef])+ } deriving (Eq, Show)++instance MonadIO m => StoreWrite (ReaderT (TVar Memory) m) where+ setBest h = do+ v <- R.ask+ atomically $ modifyTVar v (setBestH h)+ insertBlock b = do+ v <- R.ask+ atomically $ modifyTVar v (insertBlockH b)+ setBlocksAtHeight h g = do+ v <- R.ask+ atomically $ modifyTVar v (setBlocksAtHeightH h g)+ insertTx t = do+ v <- R.ask+ atomically $ modifyTVar v (insertTxH t)+ insertSpender p s = do+ v <- R.ask+ atomically $ modifyTVar v (insertSpenderH p s)+ deleteSpender p = do+ v <- R.ask+ atomically $ modifyTVar v (deleteSpenderH p)+ insertAddrTx a t = do+ v <- R.ask+ atomically $ modifyTVar v (insertAddrTxH a t)+ deleteAddrTx a t = do+ v <- R.ask+ atomically $ modifyTVar v (deleteAddrTxH a t)+ insertAddrUnspent a u = do+ v <- R.ask+ atomically $ modifyTVar v (insertAddrUnspentH a u)+ deleteAddrUnspent a u = do+ v <- R.ask+ atomically $ modifyTVar v (deleteAddrUnspentH a u)+ setMempool xs = do+ v <- R.ask+ atomically $ modifyTVar v (setMempoolH xs)+ setBalance b = do+ v <- R.ask+ atomically $ modifyTVar v (setBalanceH b)+ insertUnspent h = do+ v <- R.ask+ atomically $ modifyTVar v (insertUnspentH h)+ deleteUnspent p = do+ v <- R.ask+ atomically $ modifyTVar v (deleteUnspentH p)++runWriter+ :: (MonadIO m, MonadError e m) => DatabaseReader- -> ReaderT DatabaseWriter m a+ -> ReaderT Writer m a -> m a-runDatabaseWriter bdb@DatabaseReader { databaseHandle = db- , databaseMaxGap = gap- , databaseInitialGap = igap- , databaseNetwork = net- } f = do- hm <- newTVarIO emptyMemoryDatabase- let ms =- MemoryState- { memoryDatabase = hm- , memoryMaxGap = gap- , memoryNetwork = net- , memoryInitialGap = igap- }- x <-- R.runReaderT- f- DatabaseWriter- {databaseWriterReader = bdb, databaseWriterState = ms}+runWriter bdb@DatabaseReader{databaseHandle = db} f = do+ hm <- newTVarIO emptyMemory+ x <- R.runReaderT f Writer {getReader = bdb, getState = hm} ops <- hashMapOps <$> readTVarIO hm writeBatch db ops return x -hashMapOps :: MemoryDatabase -> [BatchOp]+hashMapOps :: Memory -> [BatchOp] hashMapOps db = bestBlockOp (hBest db) <> blockHashOps (hBlock db) <>@@ -110,234 +234,394 @@ where f = insertOp . TxKey -spenderOps :: HashMap TxHash (IntMap (Maybe Spender)) -> [BatchOp]+spenderOps :: HashMap TxHash (IntMap (Dirty 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)))+ g h i (Modified s) =+ insertOp (SpenderKey (OutPoint h (fromIntegral i))) s+ g h i Deleted =+ 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+addrTxOps :: HashMap Address (HashMap TxRef (Dirty ()))+ -> [BatchOp]+addrTxOps = 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 =- TxRef- { txRefBlock = b- , txRefHash = t- }- })- ()- h a b t False =- deleteOp- AddrTxKey- { addrTxKeyA = a- , addrTxKeyT =- TxRef- { txRefBlock = b- , txRefHash = t- }- }+ g a t (Modified ()) = insertOp (AddrTxKey a t) ()+ g a t Deleted = deleteOp (AddrTxKey a t) -addrOutOps ::- HashMap Address (HashMap BlockRef (HashMap OutPoint (Maybe OutVal)))+addrOutOps+ :: HashMap Address+ (HashMap BlockRef+ (HashMap OutPoint (Dirty 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) =+ h a b p (Modified l) = insertOp- (AddrOutKey {addrOutKeyA = a, addrOutKeyB = b, addrOutKeyP = p})+ (AddrOutKey { addrOutKeyA = a+ , addrOutKeyB = b+ , addrOutKeyP = p }) l- h a b p Nothing =- deleteOp AddrOutKey {addrOutKeyA = a, addrOutKeyB = b, addrOutKeyP = p}+ h a b p Deleted =+ deleteOp AddrOutKey { addrOutKeyA = a+ , addrOutKeyB = b+ , addrOutKeyP = p } mempoolOp :: [TxRef] -> BatchOp mempoolOp = insertOp MemKey .- map (\TxRef {txRefBlock = MemRef t, txRefHash = h} -> (t, h))+ map (\TxRef { txRefBlock = MemRef t+ , txRefHash = h } -> (t, h)) -unspentOps :: HashMap TxHash (IntMap (Maybe UnspentVal)) -> [BatchOp]+unspentOps :: HashMap TxHash (IntMap (Dirty 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)))+ g h i (Modified u) =+ insertOp (UnspentKey (OutPoint h (fromIntegral i))) u+ g h i Deleted =+ deleteOp (UnspentKey (OutPoint h (fromIntegral i))) -setBestI :: MonadIO m => BlockHash -> DatabaseWriter -> m ()-setBestI bh DatabaseWriter {databaseWriterState = hm} =- withMemoryDatabase hm $ setBest bh+setBestI :: MonadIO m => BlockHash -> Writer -> m ()+setBestI bh Writer {getState = hm} =+ withMemory hm $ setBest bh -insertBlockI :: MonadIO m => BlockData -> DatabaseWriter -> m ()-insertBlockI b DatabaseWriter {databaseWriterState = hm} =- withMemoryDatabase hm $ insertBlock b+insertBlockI :: MonadIO m => BlockData -> Writer -> m ()+insertBlockI b Writer {getState = hm} =+ withMemory hm $ insertBlock b -setBlocksAtHeightI :: MonadIO m => [BlockHash] -> BlockHeight -> DatabaseWriter -> m ()-setBlocksAtHeightI hs g DatabaseWriter {databaseWriterState = hm} =- withMemoryDatabase hm $ setBlocksAtHeight hs g+setBlocksAtHeightI :: MonadIO m+ => [BlockHash]+ -> BlockHeight+ -> Writer+ -> m ()+setBlocksAtHeightI hs g Writer {getState = hm} =+ withMemory hm $ setBlocksAtHeight hs g -insertTxI :: MonadIO m => TxData -> DatabaseWriter -> m ()-insertTxI t DatabaseWriter {databaseWriterState = hm} =- withMemoryDatabase hm $ insertTx t+insertTxI :: MonadIO m => TxData -> Writer -> m ()+insertTxI t Writer {getState = hm} =+ withMemory hm $ insertTx t -insertSpenderI :: MonadIO m => OutPoint -> Spender -> DatabaseWriter -> m ()-insertSpenderI p s DatabaseWriter {databaseWriterState = hm} =- withMemoryDatabase hm $ insertSpender p s+insertSpenderI :: MonadIO m+ => OutPoint+ -> Spender+ -> Writer+ -> m ()+insertSpenderI p s Writer {getState = hm} =+ withMemory hm $ insertSpender p s -deleteSpenderI :: MonadIO m => OutPoint -> DatabaseWriter -> m ()-deleteSpenderI p DatabaseWriter {databaseWriterState = hm} =- withMemoryDatabase hm $ deleteSpender p+deleteSpenderI :: MonadIO m+ => OutPoint+ -> Writer+ -> m ()+deleteSpenderI p Writer {getState = hm} =+ withMemory hm $ deleteSpender p -insertAddrTxI :: MonadIO m => Address -> TxRef -> DatabaseWriter -> m ()-insertAddrTxI a t DatabaseWriter {databaseWriterState = hm} =- withMemoryDatabase hm $ insertAddrTx a t+insertAddrTxI :: MonadIO m+ => Address+ -> TxRef+ -> Writer+ -> m ()+insertAddrTxI a t Writer {getState = hm} =+ withMemory hm $ insertAddrTx a t -deleteAddrTxI :: MonadIO m => Address -> TxRef -> DatabaseWriter -> m ()-deleteAddrTxI a t DatabaseWriter {databaseWriterState = hm} =- withMemoryDatabase hm $ deleteAddrTx a t+deleteAddrTxI :: MonadIO m+ => Address+ -> TxRef+ -> Writer+ -> m ()+deleteAddrTxI a t Writer {getState = hm} =+ withMemory hm $ deleteAddrTx a t -insertAddrUnspentI :: MonadIO m => Address -> Unspent -> DatabaseWriter -> m ()-insertAddrUnspentI a u DatabaseWriter {databaseWriterState = hm} =- withMemoryDatabase hm $ insertAddrUnspent a u+insertAddrUnspentI :: MonadIO m+ => Address+ -> Unspent+ -> Writer+ -> m ()+insertAddrUnspentI a u Writer {getState = hm} =+ withMemory hm $ insertAddrUnspent a u -deleteAddrUnspentI :: MonadIO m => Address -> Unspent -> DatabaseWriter -> m ()-deleteAddrUnspentI a u DatabaseWriter {databaseWriterState = hm} =- withMemoryDatabase hm $ deleteAddrUnspent a u+deleteAddrUnspentI :: MonadIO m+ => Address+ -> Unspent+ -> Writer+ -> m ()+deleteAddrUnspentI a u Writer {getState = hm} =+ withMemory hm $ deleteAddrUnspent a u -setMempoolI :: MonadIO m => [TxRef] -> DatabaseWriter -> m ()-setMempoolI xs DatabaseWriter {databaseWriterState = hm} = withMemoryDatabase hm $ setMempool xs+setMempoolI :: MonadIO m => [TxRef] -> Writer -> m ()+setMempoolI xs Writer {getState = hm} =+ withMemory hm $ setMempool xs -getBestBlockI :: MonadIO m => DatabaseWriter -> m (Maybe BlockHash)-getBestBlockI DatabaseWriter {databaseWriterState = hm, databaseWriterReader = db} =+getBestBlockI :: MonadIO m => Writer -> m (Maybe BlockHash)+getBestBlockI Writer {getState = hm, getReader = db} = runMaybeT $ MaybeT f <|> MaybeT g where- f = withMemoryDatabase hm getBestBlock+ f = getBestBlockH <$> readTVarIO hm 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+getBlocksAtHeightI :: MonadIO m+ => BlockHeight+ -> Writer+ -> m [BlockHash]+getBlocksAtHeightI bh Writer {getState = hm, getReader = db} =+ getBlocksAtHeightH bh <$> readTVarIO hm >>= \case+ Just bs -> return bs+ Nothing -> withDatabaseReader db $ getBlocksAtHeight bh -getBlockI :: MonadIO m => BlockHash -> DatabaseWriter -> m (Maybe BlockData)-getBlockI bh DatabaseWriter {databaseWriterReader = db, databaseWriterState = hm} =+getBlockI :: MonadIO m+ => BlockHash+ -> Writer+ -> m (Maybe BlockData)+getBlockI bh Writer {getReader = db, getState = hm} = runMaybeT $ MaybeT f <|> MaybeT g where- f = withMemoryDatabase hm $ getBlock bh+ f = getBlockH bh <$> readTVarIO hm g = withDatabaseReader db $ getBlock bh -getTxDataI ::- MonadIO m => TxHash -> DatabaseWriter -> m (Maybe TxData)-getTxDataI th DatabaseWriter {databaseWriterReader = db, databaseWriterState = hm} =+getTxDataI :: MonadIO m+ => TxHash+ -> Writer+ -> m (Maybe TxData)+getTxDataI th Writer {getReader = db, getState = hm} = runMaybeT $ MaybeT f <|> MaybeT g where- f = withMemoryDatabase hm $ getTxData th+ f = getTxDataH th <$> readTVarIO hm g = withDatabaseReader db $ getTxData th -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+getSpenderI :: MonadIO m => OutPoint -> Writer -> m (Maybe Spender)+getSpenderI op Writer {getReader = db, getState = hm} =+ getSpenderH op <$> readTVarIO hm >>= \case+ Just (Modified s) -> return (Just s)+ Just Deleted -> return Nothing+ Nothing -> withDatabaseReader db (getSpender op) -getBalanceI :: MonadIO m => Address -> DatabaseWriter -> m Balance-getBalanceI a DatabaseWriter { databaseWriterReader = db- , databaseWriterState = hm- } =- fromMaybe (zeroBalance a) <$> runMaybeT (MaybeT f <|> MaybeT g)+getSpendersI :: MonadIO m => TxHash -> Writer -> m (IntMap Spender)+getSpendersI t Writer {getReader = db, getState = hm} = do+ hsm <- fmap to_maybe . getSpendersH t <$> readTVarIO hm+ dsm <- fmap Just <$> withDatabaseReader db (getSpenders t)+ return $ I.map fromJust $ I.filter isJust $ hsm <> dsm 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+ to_maybe Deleted = Nothing+ to_maybe (Modified x) = Just x -setBalanceI :: MonadIO m => Balance -> DatabaseWriter -> m ()-setBalanceI b DatabaseWriter {databaseWriterState = hm} =- withMemoryDatabase hm $ setBalance b+getBalanceI :: MonadIO m => Address -> Writer -> m Balance+getBalanceI a Writer {getReader = db, getState = hm} =+ getBalanceH a <$> readTVarIO hm >>= \case+ Just b -> return $ valToBalance a b+ Nothing -> withDatabaseReader db $ getBalance a -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)+setBalanceI :: MonadIO m => Balance -> Writer -> m ()+setBalanceI b Writer {getState = hm} =+ withMemory hm $ setBalance b -insertUnspentI :: MonadIO m => Unspent -> DatabaseWriter -> m ()-insertUnspentI u DatabaseWriter {databaseWriterState = hm} =- withMemoryDatabase hm $ insertUnspent u+getUnspentI :: MonadIO m+ => OutPoint+ -> Writer+ -> m (Maybe Unspent)+getUnspentI op Writer {getReader = db, getState = hm} =+ getUnspentH op <$> readTVarIO hm >>= \case+ Just Deleted -> return Nothing+ Just (Modified u) -> return (Just (valToUnspent op u))+ Nothing -> withDatabaseReader db (getUnspent op) -deleteUnspentI :: MonadIO m => OutPoint -> DatabaseWriter -> m ()-deleteUnspentI p DatabaseWriter {databaseWriterState = hm} =- withMemoryDatabase hm $ deleteUnspent p+insertUnspentI :: MonadIO m => Unspent -> Writer -> m ()+insertUnspentI u Writer {getState = hm} =+ withMemory hm $ insertUnspent u -getMempoolI ::- MonadIO m- => DatabaseWriter- -> m [TxRef]-getMempoolI DatabaseWriter {databaseWriterState = hm, databaseWriterReader = db} =- getMempoolH <$> readTVarIO (memoryDatabase hm) >>= \case+deleteUnspentI :: MonadIO m => OutPoint -> Writer -> m ()+deleteUnspentI p Writer {getState = hm} =+ withMemory hm $ deleteUnspent p++getMempoolI :: MonadIO m => Writer -> m [TxRef]+getMempoolI Writer {getState = hm, getReader = db} =+ getMempoolH <$> readTVarIO hm >>= \case Just xs -> return xs Nothing -> withDatabaseReader db getMempool -instance MonadIO m => StoreRead (ReaderT DatabaseWriter m) where- getInitialGap = R.asks (databaseInitialGap . databaseWriterReader)- getNetwork = R.asks (databaseNetwork . databaseWriterReader)- 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- getUnspent a = R.ask >>= getUnspentI a- getBalance a = R.ask >>= getBalanceI a- getMempool = R.ask >>= getMempoolI- getAddressesTxs = undefined- getAddressesUnspents = undefined- getMaxGap = R.asks (databaseMaxGap . databaseWriterReader)+withMemory :: MonadIO m+ => TVar Memory+ -> ReaderT (TVar Memory) m a+ -> m a+withMemory = flip R.runReaderT -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- insertUnspent u = R.ask >>= insertUnspentI u- deleteUnspent p = R.ask >>= deleteUnspentI p- setBalance b = R.ask >>= setBalanceI b+emptyMemory :: Memory+emptyMemory = Memory { 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 }++getBestBlockH :: Memory -> Maybe BlockHash+getBestBlockH = hBest++getBlocksAtHeightH :: BlockHeight -> Memory -> Maybe [BlockHash]+getBlocksAtHeightH h = M.lookup h . hHeight++getBlockH :: BlockHash -> Memory -> Maybe BlockData+getBlockH h = M.lookup h . hBlock++getTxDataH :: TxHash -> Memory -> Maybe TxData+getTxDataH t = M.lookup t . hTx++getSpenderH :: OutPoint -> Memory -> Maybe (Dirty Spender)+getSpenderH op db = do+ m <- M.lookup (outPointHash op) (hSpender db)+ I.lookup (fromIntegral (outPointIndex op)) m++getSpendersH :: TxHash -> Memory -> IntMap (Dirty Spender)+getSpendersH t = M.lookupDefault I.empty t . hSpender++getBalanceH :: Address -> Memory -> Maybe BalVal+getBalanceH a = M.lookup a . hBalance++getMempoolH :: Memory -> Maybe [TxRef]+getMempoolH = hMempool++setBestH :: BlockHash -> Memory -> Memory+setBestH h db = db {hBest = Just h}++insertBlockH :: BlockData -> Memory -> Memory+insertBlockH bd db =+ db { hBlock =+ M.insert+ (headerHash (blockDataHeader bd))+ bd+ (hBlock db)+ }++setBlocksAtHeightH :: [BlockHash] -> BlockHeight -> Memory -> Memory+setBlocksAtHeightH hs g db = db {hHeight = M.insert g hs (hHeight db)}++insertTxH :: TxData -> Memory -> Memory+insertTxH tx db = db {hTx = M.insert (txHash (txData tx)) tx (hTx db)}++insertSpenderH :: OutPoint -> Spender -> Memory -> Memory+insertSpenderH op s db =+ db+ { hSpender =+ M.insertWith+ (<>)+ (outPointHash op)+ (I.singleton+ (fromIntegral (outPointIndex op))+ (Modified s))+ (hSpender db)+ }++deleteSpenderH :: OutPoint -> Memory -> Memory+deleteSpenderH op db =+ db+ { hSpender =+ M.insertWith+ (<>)+ (outPointHash op)+ (I.singleton+ (fromIntegral (outPointIndex op))+ Deleted)+ (hSpender db)+ }++setBalanceH :: Balance -> Memory -> Memory+setBalanceH bal db =+ db {hBalance = M.insert (balanceAddress bal) b (hBalance db)}+ where+ b = balanceToVal bal++insertAddrTxH :: Address -> TxRef -> Memory -> Memory+insertAddrTxH a btx db =+ db+ { hAddrTx =+ M.insertWith+ (<>)+ a+ (M.singleton btx (Modified ()))+ (hAddrTx db)+ }++deleteAddrTxH :: Address -> TxRef -> Memory -> Memory+deleteAddrTxH a btx db =+ db+ { hAddrTx =+ M.insertWith+ (<>)+ a+ (M.singleton btx Deleted)+ (hAddrTx db)+ }++insertAddrUnspentH :: Address -> Unspent -> Memory -> Memory+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) (Modified uns)))+ in db { hAddrOut =+ M.unionWith+ (M.unionWith M.union)+ s+ (hAddrOut db)+ }++deleteAddrUnspentH :: Address -> Unspent -> Memory -> Memory+deleteAddrUnspentH a u db =+ let s =+ M.singleton+ a+ (M.singleton+ (unspentBlock u)+ (M.singleton (unspentPoint u) Deleted))+ in db {hAddrOut = M.unionWith (M.unionWith M.union) s (hAddrOut db)}++setMempoolH :: [TxRef] -> Memory -> Memory+setMempoolH xs db = db {hMempool = Just xs}++getUnspentH :: OutPoint -> Memory -> Maybe (Dirty UnspentVal)+getUnspentH op db = do+ m <- M.lookup (outPointHash op) (hUnspent db)+ I.lookup (fromIntegral (outPointIndex op)) m++insertUnspentH :: Unspent -> Memory -> Memory+insertUnspentH u db =+ db+ { hUnspent =+ M.insertWith+ (<>)+ (outPointHash (unspentPoint u))+ (I.singleton+ (fromIntegral (outPointIndex (unspentPoint u)))+ (Modified (snd (unspentToVal u))))+ (hUnspent db)+ }++deleteUnspentH :: OutPoint -> Memory -> Memory+deleteUnspentH op db =+ db+ { hUnspent =+ M.insertWith+ (<>)+ (outPointHash op)+ (I.singleton+ (fromIntegral (outPointIndex op))+ Deleted)+ (hUnspent db)+ }
src/Haskoin/Store/Logic.hs view
@@ -3,781 +3,798 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-}-module Haskoin.Store.Logic- ( ImportException (..)- , initBest- , getOldMempool- , revertBlock- , importBlock- , newMempoolTx- , deleteTx- ) where--import Control.Monad (forM, forM_, guard, unless, void,- when, zipWithM_)-import Control.Monad.Except (MonadError (..))-import Control.Monad.Logger (MonadLogger, logDebugS, 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 (sort, nub)-import Data.Maybe (fromMaybe, isNothing)-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,- computeSubsidy, eitherToMaybe,- genesisBlock, genesisNode, headerHash,- isGenesis, nullOutPoint,- scriptToAddressBS, txHash,- txHashToHex)-import Haskoin.Store.Common (StoreRead (..), StoreWrite (..), nub',- sortTxs)-import Haskoin.Store.Data (Balance (..), BlockData (..),- BlockRef (..), TxRef (..),- Prev (..), Spender (..), TxData (..),- UnixTime, Unspent (..), confirmed,- nullBalance)-import UnliftIO (Exception)--data ImportException- = PrevBlockNotBest !Text- | TxOrphan !Text- | UnconfirmedCoinbase !Text- | BestBlockUnknown- | BestBlockNotFound !Text- | BlockNotBest !Text- | TxNotFound !Text- | OutputSpent !Text- | CannotDeleteNonRBF !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- )- => m ()-initBest = do- net <- getNetwork- m <- getBestBlock- when- (isNothing m)- (void (importBlock (genesisBlock net) (genesisNode net)))--getOldMempool :: StoreRead m => UnixTime -> m [TxHash]-getOldMempool now =- map txRefHash . filter ((< now - 3600 * 72) . memRefTime . txRefBlock) <$>- getMempool--newMempoolTx ::- (StoreRead m, StoreWrite m, MonadLogger m, MonadError ImportException m)- => Tx- -> UnixTime- -> m (Maybe [TxHash])- -- ^ deleted transactions or nothing if already imported-newMempoolTx tx w =- getTxData (txHash tx) >>= \case- Just x- | not (txDataDeleted x) -> do- $(logDebugS) "BlockStore" $- "Transaction already in store: " <> txHashToHex (txHash tx)- return Nothing- _ -> Just <$> importTx (MemRef w) w tx--revertBlock ::- ( StoreRead m- , StoreWrite m- , MonadLogger m- , MonadError ImportException m- )- => BlockHash- -> m [TxHash]-revertBlock 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 txData . getImportTxData) (blockDataTxs bd)- ths <-- nub' . concat <$>- mapM (deleteTx False 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- )- => Block- -> BlockNode- -> m [TxHash] -- ^ deleted transactions-importBlock b n = do- mp <- filter (`elem` bths) . map txRefHash <$> 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)))- net <- getNetwork- let subsidy = computeSubsidy net (nodeHeight 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 =- if getSegWit net- then fromIntegral w- else 0- , blockDataSubsidy = subsidy- , blockDataFees = cb_out_val - subsidy- , 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 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- (br x)- (fromIntegral (blockTimestamp (nodeHeader n)))- tx- 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- )- => BlockRef- -> Word64 -- ^ unix time- -> Tx- -> m [TxHash] -- ^ deleted transactions-importTx br tt tx = do- unless (confirmed br) $ do- $(logDebugS) "BlockStore" $- "Importing transaction " <> txHashToHex (txHash tx)- 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 $ 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))- rbf <- isRBF br tx- commit rbf us- return ths- where- commit rbf us = do- zipWithM_ (spendOutput br (txHash tx)) [0 ..] us- zipWithM_- (\i o -> newOutput br (OutPoint (txHash tx) i) o)- [0 ..]- (txOut tx)- let ps =- I.fromList . zip [0 ..] $- if iscb- then []- else map mkprv us- d =- TxData- { txDataBlock = br- , txData = tx- , txDataPrevs = ps- , txDataDeleted = False- , txDataRBF = rbf- , txDataTime = tt- }- insertTx d- updateAddressCounts (txDataAddresses d) (+ 1)- unless (confirmed br) $ insertIntoMempool (txHash tx) (memRefTime br)- 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))- $(logErrorS) "BlockStore" $- "Orphan tx: " <> txHashToHex (txHash tx)- throwError (TxOrphan (txHashToHex (txHash tx)))- Just Spender {spenderHash = s} -> do- $(logWarnS) "BlockStore" $- "Deleting transaction " <> txHashToHex s <>- " because it conflicts with " <>- txHashToHex (txHash tx)- ths <- deleteTx True (not (confirmed br)) s- getUnspent op >>= \case- Nothing -> do- $(logErrorS) "BlockStore" $- "Cannot unspend output: " <>- txHashToHex (outPointHash op) <>- " " <>- fromString (show (outPointIndex op))- throwError (OutputSpent (cs (show op)))- Just u -> return (u, ths)- th = txHash tx- iscb = all (== nullOutPoint) (map prevOutput (txIn tx))- mkprv u = Prev (B.Short.fromShort (unspentScript u)) (unspentAmount u)--confirmTx ::- ( StoreRead m- , StoreWrite m- , MonadLogger m- , MonadError ImportException m- )- => TxData- -> BlockRef- -> Tx- -> m ()-confirmTx t br tx = do- forM_ (txDataPrevs t) $ \p ->- case scriptToAddressBS (prevScript p) of- Left _ -> return ()- Right a -> do- deleteAddrTx- a- TxRef- {txRefBlock = txDataBlock t, txRefHash = txHash tx}- insertAddrTx- a- TxRef {txRefBlock = br, txRefHash = 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)- , unspentAddress =- eitherToMaybe (scriptToAddressBS (scriptOutput o))- }- case scriptToAddressBS (scriptOutput o) of- Left _ -> return ()- Right a -> do- deleteAddrTx- a- TxRef- {txRefBlock = txDataBlock t, txRefHash = txHash tx}- insertAddrTx- a- TxRef {txRefBlock = br, txRefHash = txHash tx}- when (isNothing s) $ do- deleteAddrUnspent- a- Unspent- { unspentBlock = txDataBlock t- , unspentPoint = op- , unspentAmount = outValue o- , unspentScript = B.Short.toShort (scriptOutput o)- , unspentAddress =- eitherToMaybe- (scriptToAddressBS (scriptOutput o))- }- insertAddrUnspent- a- Unspent- { unspentBlock = br- , unspentPoint = op- , unspentAmount = outValue o- , unspentScript = B.Short.toShort (scriptOutput o)- , unspentAddress =- eitherToMaybe- (scriptToAddressBS (scriptOutput o))- }- reduceBalance 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) . txRefHash) mp--insertIntoMempool :: (Monad m, StoreRead m, StoreWrite m) => TxHash -> UnixTime -> m ()-insertIntoMempool th unixtime = do- mp <- getMempool- setMempool . reverse . sort $- TxRef {txRefBlock = MemRef unixtime, txRefHash = th} : mp--deleteTx ::- ( StoreRead m- , StoreWrite m- , MonadLogger m- , MonadError ImportException m- )- => Bool -- ^ only delete transaction if unconfirmed- -> Bool -- ^ do RBF check before deleting transaction- -> TxHash- -> m [TxHash] -- ^ deleted transactions-deleteTx memonly rbfcheck txhash = do- getTxData txhash >>= \case- Nothing -> do- $(logErrorS) "BlockStore" $- "Cannot find tx to delete: " <> txHashToHex txhash- throwError (TxNotFound (txHashToHex txhash))- Just t- | txDataDeleted t -> do- $(logWarnS) "BlockStore" $- "Already deleted tx: " <> txHashToHex txhash- return []- | memonly && confirmed (txDataBlock t) -> do- $(logErrorS) "BlockStore" $- "Will not delete confirmed tx: " <> txHashToHex txhash- throwError (TxConfirmed (txHashToHex txhash))- | rbfcheck ->- isRBF (txDataBlock t) (txData t) >>= \case- True -> go t- False -> do- $(logErrorS) "BlockStore" $- "Delete non-RBF transaction attempted: " <>- txHashToHex txhash- throwError $ CannotDeleteNonRBF (txHashToHex txhash)- | otherwise -> go t- where- go t = do- $(logWarnS) "BlockStore" $- "Deleting transaction: " <> txHashToHex txhash- ss <- nub' . map spenderHash . I.elems <$> getSpenders txhash- ths <-- fmap concat $- forM ss $ \s -> do- $(logWarnS) "BlockStore" $- "Deleting descendant " <> txHashToHex s <>- " to delete parent " <>- txHashToHex txhash- deleteTx True rbfcheck s- forM_ (take (length (txOut (txData t))) [0 ..]) $ \n ->- delOutput (OutPoint txhash n)- let ps = filter (/= nullOutPoint) (map prevOutput (txIn (txData t)))- mapM_ unspendOutput ps- unless (confirmed (txDataBlock t)) $ deleteFromMempool txhash- insertTx t {txDataDeleted = True}- updateAddressCounts (txDataAddresses t) (subtract 1)- return $ nub' (txhash : ths)---isRBF ::- (StoreRead m, MonadLogger m, MonadError ImportException m)- => BlockRef- -> Tx- -> m Bool-isRBF br tx- | confirmed br = return False- | otherwise =- getNetwork >>= \net ->- if getReplaceByFee net- then go- else return False- where- go- | all (== nullOutPoint) (map prevOutput (txIn tx)) = return False- | any ((< 0xffffffff - 1) . txInSequence) (txIn tx) = return True- | otherwise =- let hs = nub' $ map (outPointHash . prevOutput) (txIn tx)- ck [] = return False- ck (h:hs') =- getTxData h >>= \case- Nothing -> do- $(logErrorS) "BlockStore" $- "Transaction not found: " <> txHashToHex h- throwError (TxNotFound (txHashToHex h))- Just t- | confirmed (txDataBlock t) -> ck hs'- | txDataRBF t -> return True- | otherwise -> ck hs'- in ck hs--newOutput ::- ( StoreRead m- , StoreWrite m- , MonadLogger m- )- => 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- TxRef {txRefHash = outPointHash op, txRefBlock = br}- increaseBalance (confirmed br) True a (outValue to)- where- u =- Unspent- { unspentBlock = br- , unspentAmount = outValue to- , unspentScript = B.Short.toShort (scriptOutput to)- , unspentPoint = op- , unspentAddress =- eitherToMaybe (scriptToAddressBS (scriptOutput to))- }--delOutput ::- ( StoreRead m- , StoreWrite m- , MonadLogger m- , MonadError ImportException m- )- => OutPoint- -> m ()-delOutput op = do- t <- getImportTxData (outPointHash op)- u <-- case getTxOut (outPointIndex op) (txData t) of- Just u -> return u- Nothing -> do- $(logErrorS) "BlockStore" $- "Output out of range: " <> txHashToHex (txHash (txData t)) <>- " " <>- fromString (show (outPointIndex op))- throwError . OutputOutOfRange . cs $ show op- deleteUnspent op- case scriptToAddressBS (scriptOutput u) of- Left _ -> return ()- Right a -> do- deleteAddrUnspent- a- Unspent- { unspentScript = B.Short.toShort (scriptOutput u)- , unspentBlock = txDataBlock t- , unspentPoint = op- , unspentAmount = outValue u- , unspentAddress =- eitherToMaybe (scriptToAddressBS (scriptOutput u))- }- deleteAddrTx- a- TxRef- { txRefHash = outPointHash op- , txRefBlock = txDataBlock t- }- reduceBalance (confirmed (txDataBlock t)) True a (outValue u)--getImportTxData ::- (StoreRead m, MonadLogger m, MonadError ImportException m)- => TxHash- -> m TxData-getImportTxData 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 -> return d--getTxOut- :: Word32- -> Tx- -> Maybe TxOut-getTxOut i tx = do- guard (fromIntegral i < length (txOut tx))- return $ txOut tx !! fromIntegral i--spendOutput ::- ( StoreRead m- , StoreWrite m- , MonadLogger m- , MonadError ImportException m- )- => BlockRef- -> TxHash- -> Word32- -> Unspent- -> m ()-spendOutput 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- (confirmed (unspentBlock u))- False- a- (unspentAmount u)- deleteAddrUnspent a u- insertAddrTx a TxRef {txRefHash = th, txRefBlock = br}- deleteUnspent (unspentPoint u)--unspendOutput ::- ( StoreRead m- , StoreWrite m- , MonadLogger m- , MonadError ImportException m- )- => OutPoint- -> m ()-unspendOutput op = do- t <- getImportTxData (outPointHash op)- o <-- case getTxOut (outPointIndex op) (txData t) of- Nothing -> do- $(logErrorS) "BlockStore" $- "Output out of range: " <> cs (show op)- throwError (OutputOutOfRange (cs (show op)))- Just o -> return o- s <-- getSpender op >>= \case- Nothing -> do- $(logErrorS) "BlockStore" $- "Output already unspent: " <> txHashToHex (outPointHash op) <>- " " <>- fromString (show (outPointIndex op))- throwError (AlreadyUnspent (cs (show op)))- Just s -> return s- x <- getImportTxData (spenderHash s)- deleteSpender op- let m = eitherToMaybe (scriptToAddressBS (scriptOutput o))- let u =- Unspent- { unspentAmount = outValue o- , unspentBlock = txDataBlock t- , unspentScript = B.Short.toShort (scriptOutput o)- , unspentPoint = op- , unspentAddress = m- }- insertUnspent u- case m of- Nothing -> return ()- Just a -> do- insertAddrUnspent a u- deleteAddrTx- a- TxRef- {txRefHash = spenderHash s, txRefBlock = txDataBlock x}- increaseBalance- (confirmed (unspentBlock u))- False- a- (outValue o)--reduceBalance ::- ( StoreRead m- , StoreWrite m- , MonadLogger m- , MonadError ImportException m- )- => Bool -- ^ spend or delete confirmed output- -> Bool -- ^ reduce total received- -> Address- -> Word64- -> m ()-reduceBalance c t a v = do- net <- getNetwork- b <- getBalance a- 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)- => [Address]- -> (Word64 -> Word64)- -> m ()-updateAddressCounts as f =- forM_ as $ \a -> do- b <-- do net <- getNetwork- b <- getBalance a- if nullBalance b- then throwError (BalanceNotFound (addrText net a))- else return b- setBalance b {balanceTxCount = f (balanceTxCount b)}--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+{-# LANGUAGE TupleSections #-}+module Haskoin.Store.Logic+ ( ImportException (..)+ , initBest+ , getOldMempool+ , revertBlock+ , importBlock+ , newMempoolTx+ , deleteTx+ ) where++import Control.Monad (forM, forM_, guard, unless, void,+ when, zipWithM_)+import Control.Monad.Except (MonadError (..))+import Control.Monad.Logger (MonadLogger, logDebugS, 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, sortOn)+import Data.Maybe (fromMaybe, isNothing)+import Data.Ord (Down (Down))+import Data.Serialize (encode)+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 (..),+ blockHashToHex, computeSubsidy,+ eitherToMaybe, genesisBlock,+ genesisNode, headerHash, isGenesis,+ nullOutPoint, scriptToAddressBS,+ txHash, txHashToHex)+import Haskoin.Store.Common (StoreRead (..), StoreWrite (..),+ getActiveTxData, nub', sortTxs)+import Haskoin.Store.Data (Balance (..), BlockData (..),+ BlockRef (..), Prev (..),+ Spender (..), TxData (..), TxRef (..),+ UnixTime, Unspent (..), confirmed)+import UnliftIO (Exception)++data ImportException+ = PrevBlockNotBest+ | Orphan+ | UnexpectedCoinbase+ | BestBlockNotFound+ | BlockNotBest+ | TxNotFound+ | DoubleSpend+ | TxConfirmed+ | InsufficientFunds+ | DuplicatePrevOutput+ deriving (Eq, Ord, Exception)++instance Show ImportException where+ show PrevBlockNotBest = "Previous block not best"+ show Orphan = "Orphan"+ show UnexpectedCoinbase = "Unexpected coinbase"+ show BestBlockNotFound = "Best block not found"+ show BlockNotBest = "Block not best"+ show TxNotFound = "Transaction not found"+ show DoubleSpend = "Double spend"+ show TxConfirmed = "Transaction confirmed"+ show InsufficientFunds = "Insufficient funds"+ show DuplicatePrevOutput = "Duplicate previous output"++initBest ::+ ( StoreRead m+ , StoreWrite m+ , MonadLogger m+ , MonadError ImportException m+ )+ => m ()+initBest = do+ net <- getNetwork+ m <- getBestBlock+ when (isNothing m) . void $+ importBlock (genesisBlock net) (genesisNode net)++getOldMempool :: StoreRead m => UnixTime -> m [TxHash]+getOldMempool now =+ map txRefHash+ . filter ((< now - 3600 * 72) . memRefTime . txRefBlock)+ <$> getMempool++newMempoolTx ::+ ( StoreRead m+ , StoreWrite m+ , MonadLogger m+ , MonadError ImportException m+ )+ => Tx+ -> UnixTime+ -> m (Maybe [TxHash])+ -- ^ deleted transactions or nothing if already imported+newMempoolTx tx w =+ getActiveTxData (txHash tx) >>= \case+ Just _ -> do+ $(logDebugS) "BlockStore" $+ "Transaction already in store: "+ <> txHashToHex (txHash tx)+ return Nothing+ Nothing -> Just <$> importTx (MemRef w) w tx++bestBlockData+ :: ( StoreRead m+ , StoreWrite m+ , MonadLogger m+ , MonadError ImportException m+ )+ => m BlockData+bestBlockData = do+ h <- getBestBlock >>= \case+ Nothing -> do+ $(logErrorS) "BlockStore" "Best block unknown"+ throwError BestBlockNotFound+ Just h -> return h+ getBlock h >>= \case+ Nothing -> do+ $(logErrorS) "BlockStore" "Best block not found"+ throwError BestBlockNotFound+ Just b -> return b++revertBlock+ :: ( StoreRead m+ , StoreWrite m+ , MonadLogger m+ , MonadError ImportException m+ )+ => BlockHash+ -> m [TxHash]+revertBlock bh = do+ bd <- bestBlockData >>= \b ->+ if headerHash (blockDataHeader b) == bh+ then return b+ else do+ $(logErrorS) "BlockStore" $+ "Cannot revert non-head block: " <> blockHashToHex bh+ throwError BlockNotBest+ tds <- mapM getImportTxData (blockDataTxs bd)+ setBest (prevBlock (blockDataHeader bd))+ insertBlock bd {blockDataMainChain = False}+ forM_ (tail tds) unConfirmTx+ deleteTx False False (txHash (txData (head tds)))++checkNewBlock+ :: ( StoreRead m+ , StoreWrite m+ , MonadLogger m+ , MonadError ImportException m+ )+ => Block+ -> BlockNode+ -> m ()+checkNewBlock b n =+ getBestBlock >>= \case+ Nothing+ | isGenesis n -> return ()+ | otherwise -> do+ $(logErrorS) "BlockStore" $+ "Cannot import non-genesis block: "+ <> blockHashToHex (headerHash (blockHeader b))+ throwError BestBlockNotFound+ Just h+ | prevBlock (blockHeader b) == h -> return ()+ | otherwise -> do+ $(logErrorS) "BlockStore" $+ "Block does not build on head: "+ <> blockHashToHex (headerHash (blockHeader b))+ throwError PrevBlockNotBest++importOrConfirm+ :: ( StoreRead m+ , StoreWrite m+ , MonadLogger m+ , MonadError ImportException m+ )+ => BlockNode+ -> [Tx]+ -> m [TxHash] -- ^ deleted transactions+importOrConfirm bn txs =+ fmap concat . forM (sortTxs txs) $ \(i, tx) ->+ getActiveTxData (txHash tx) >>= \case+ Just td+ | confirmed (txDataBlock td) -> do+ $(logWarnS) "BlockStore" $+ "Transaction already confirmed: "+ <> txHashToHex (txHash tx)+ return []+ | otherwise -> do+ confirmTx td (br i)+ return []+ Nothing ->+ importTx+ (br i)+ (fromIntegral (blockTimestamp (nodeHeader bn)))+ tx+ where+ br i = BlockRef {blockRefHeight = nodeHeight bn, blockRefPos = i}++importBlock+ :: ( StoreRead m+ , StoreWrite m+ , MonadLogger m+ , MonadError ImportException m+ )+ => Block+ -> BlockNode+ -> m [TxHash] -- ^ deleted transactions+importBlock b n = do+ checkNewBlock b n+ net <- getNetwork+ let subsidy = computeSubsidy net (nodeHeight 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 = if getSegWit net then w else 0+ , blockDataSubsidy = subsidy+ , blockDataFees = cb_out_val - subsidy+ , blockDataOutputs = ts_out_val+ }+ bs <- getBlocksAtHeight (nodeHeight n)+ setBlocksAtHeight+ (nub (headerHash (nodeHeader n) : bs))+ (nodeHeight n)+ setBest (headerHash (nodeHeader n))+ importOrConfirm n (blockTxns b)+ where+ cb_out_val =+ sum $ map outValue $ txOut $ head $ blockTxns b+ ts_out_val =+ sum $ map (sum . map outValue . txOut) $ tail $ blockTxns b+ w =+ let f t = t {txWitness = []}+ b' = b {blockTxns = map f (blockTxns b)}+ x = B.length (encode b)+ s = B.length (encode b')+ in fromIntegral $ s * 3 + x++checkNewTx+ :: ( StoreRead m+ , StoreWrite m+ , MonadLogger m+ , MonadError ImportException m+ )+ => Tx+ -> m ()+checkNewTx tx = do+ when (unique_inputs < length (txIn tx)) $ do+ $(logDebugS) "BlockStore" $+ "Transaction spends same output twice: "+ <> txHashToHex (txHash tx)+ throwError DuplicatePrevOutput+ when (isCoinbase tx) $ do+ $(logDebugS) "BlockStore" $+ "Coinbase cannot be imported into mempool: "+ <> txHashToHex (txHash tx)+ throwError UnexpectedCoinbase+ where+ unique_inputs = length (nub' (map prevOutput (txIn tx)))++getUnspentOutputs+ :: ( StoreRead m+ , StoreWrite m+ , MonadLogger m+ , MonadError ImportException m+ )+ => Bool -- ^ only delete from mempool+ -> [OutPoint]+ -> m ([Unspent], [TxHash]) -- ^ unspents and transactions deleted+getUnspentOutputs mem ops = do+ uns_ths <- forM ops go+ let uns = map fst uns_ths+ ths = concatMap snd uns_ths+ return (uns, ths)+ where+ go op = getUnspent op >>= \case+ Nothing -> force_unspent op+ Just u -> return (u, [])+ force_unspent op = do+ s <- getSpender op >>= \case+ Nothing -> do+ $(logDebugS) "BlockStore" $+ "Output not found: " <> showOutput op+ throwError Orphan+ Just Spender {spenderHash = s} -> return s+ $(logDebugS) "BlockStore" $+ "Deleting to free output: " <> txHashToHex s+ ths <- deleteTx True mem s+ getUnspent op >>= \case+ Nothing -> do+ $(logErrorS) "BlockStore" $+ "Unexpected absent output: " <> showOutput op+ error $ "Unexpected absent output: " <> show op+ Just u -> return (u, ths)++checkFunds+ :: ( StoreRead m+ , StoreWrite m+ , MonadLogger m+ , MonadError ImportException m+ )+ => [Unspent]+ -> Tx+ -> m ()+checkFunds us tx =+ when (outputs > unspents) $ do+ $(logDebugS) "BlockStore" $+ "Insufficient funds for tx: " <> txHashToHex (txHash tx)+ throwError InsufficientFunds+ where+ unspents = sum (map unspentAmount us)+ outputs = sum (map outValue (txOut tx))++prepareTxData :: Bool -> BlockRef -> Word64 -> [Unspent] -> Tx -> TxData+prepareTxData rbf br tt us tx =+ TxData { txDataBlock = br+ , txData = tx+ , txDataPrevs = ps+ , txDataDeleted = False+ , txDataRBF = rbf+ , txDataTime = tt+ }+ where+ mkprv u = Prev (B.Short.fromShort (unspentScript u)) (unspentAmount u)+ ps = I.fromList $ zip [0 ..] $ if isCoinbase tx then [] else map mkprv us++importTx+ :: ( StoreRead m+ , StoreWrite m+ , MonadLogger m+ , MonadError ImportException m+ )+ => BlockRef+ -> Word64 -- ^ unix time+ -> Tx+ -> m [TxHash] -- ^ deleted transactions+importTx br tt tx = do+ $(logDebugS) "BlockStore" $+ "Importing transaction " <> txHashToHex (txHash tx)+ unless (confirmed br) $ checkNewTx tx+ (us, ths) <-+ if isCoinbase tx+ then return ([], [])+ else getUnspentOutputs (not (confirmed br)) (map prevOutput (txIn tx))+ unless (confirmed br) $ checkFunds us tx+ rbf <- isRBF br tx+ let td = prepareTxData rbf br tt us tx+ commitAddTx us td+ return ths++unConfirmTx+ :: (StoreRead m, StoreWrite m, MonadLogger m)+ => TxData+ -> m ()+unConfirmTx t = confTx t Nothing++confirmTx+ :: (StoreRead m, StoreWrite m, MonadLogger m)+ => TxData+ -> BlockRef+ -> m ()+confirmTx t br = confTx t (Just br)++replaceAddressTx+ :: ( StoreRead m+ , StoreWrite m+ , MonadLogger m+ )+ => TxData+ -> BlockRef+ -> m ()+replaceAddressTx t new =+ forM_ (txDataAddresses t) $ \a -> do+ deleteAddrTx+ a+ TxRef+ { txRefBlock = txDataBlock t+ , txRefHash = txHash (txData t)+ }+ insertAddrTx+ a+ TxRef+ { txRefBlock = new+ , txRefHash = txHash (txData t)+ }++adjustAddressOutput+ :: (StoreRead m, StoreWrite m, MonadLogger m)+ => OutPoint+ -> TxOut+ -> BlockRef+ -> BlockRef+ -> m ()+adjustAddressOutput op o old new = do+ let pk = scriptOutput o+ s <- getSpender op+ when (isNothing s) $ replace_unspent pk+ where+ replace_unspent pk = do+ let ma = eitherToMaybe (scriptToAddressBS pk)+ deleteUnspent op+ insertUnspent+ Unspent+ { unspentBlock = new+ , unspentPoint = op+ , unspentAmount = outValue o+ , unspentScript = B.Short.toShort pk+ , unspentAddress = ma+ }+ forM_ ma $ replace_addr_unspent pk+ replace_addr_unspent pk a = do+ deleteAddrUnspent+ a+ Unspent+ { unspentBlock = old+ , unspentPoint = op+ , unspentAmount = outValue o+ , unspentScript = B.Short.toShort pk+ , unspentAddress = Just a+ }+ insertAddrUnspent+ a+ Unspent+ { unspentBlock = new+ , unspentPoint = op+ , unspentAmount = outValue o+ , unspentScript = B.Short.toShort pk+ , unspentAddress = Just a+ }+ decreaseBalance (confirmed old) a (outValue o)+ increaseBalance (confirmed new) a (outValue o)++confTx+ :: (StoreRead m, StoreWrite m, MonadLogger m)+ => TxData+ -> Maybe BlockRef+ -> m ()+confTx t mbr = do+ replaceAddressTx t new+ forM_ (zip [0 ..] (txOut (txData t))) $ \(n, o) -> do+ let op = OutPoint (txHash (txData t)) n+ adjustAddressOutput op o old new+ insertTx td+ updateMempool td+ where+ new = fromMaybe (MemRef (txDataTime t)) mbr+ old = txDataBlock t+ td = t { txDataBlock = new }++deleteTx+ :: ( StoreRead m+ , StoreWrite m+ , MonadLogger m+ , MonadError ImportException m+ )+ => Bool -- ^ only delete transaction if unconfirmed+ -> Bool -- ^ only delete RBF+ -> TxHash+ -> m [TxHash] -- ^ deleted transactions+deleteTx memonly rbfcheck txhash =+ getActiveTxData txhash >>= \case+ Nothing -> do+ $(logDebugS) "BlockStore" $+ "Already deleted or not found: "+ <> txHashToHex txhash+ return []+ Just td+ | memonly && confirmed (txDataBlock td) -> do+ $(logDebugS) "BlockStore" $+ "Will not delete confirmed tx: "+ <> txHashToHex txhash+ throwError TxConfirmed+ | rbfcheck ->+ isRBF (txDataBlock td) (txData td) >>= \case+ True -> go td+ False -> do+ $(logDebugS) "BlockStore" $+ "Will not delete non-RBF tx: "+ <> txHashToHex txhash+ throwError DoubleSpend+ | otherwise -> go td+ where+ go td = do+ $(logDebugS) "BlockStore" $+ "Deleting tx: " <> txHashToHex txhash+ ss <- nub' . map spenderHash . I.elems <$>+ getSpenders txhash+ ths <- fmap concat $ forM ss $ \s -> do+ $(logDebugS) "BlockStore" $+ "Need to delete child tx: " <> txHashToHex s+ deleteTx True rbfcheck s+ case ths of+ [] -> do+ commitDelTx td+ return [txhash]+ _ -> getActiveTxData txhash >>= \case+ Nothing -> do+ $(logErrorS) "BlockStore" $+ "Mysteriously gone: " <> txHashToHex txhash+ return ths+ Just td' -> do+ commitDelTx td'+ return (txhash : ths)++commitDelTx+ :: (StoreRead m, StoreWrite m, MonadLogger m)+ => TxData+ -> m ()+commitDelTx = commitModTx False []++commitAddTx+ :: (StoreRead m, StoreWrite m, MonadLogger m)+ => [Unspent]+ -> TxData+ -> m ()+commitAddTx = commitModTx True++commitModTx+ :: (StoreRead m, StoreWrite m, MonadLogger m)+ => Bool+ -> [Unspent]+ -> TxData+ -> m ()+commitModTx add us td = do+ let as = txDataAddresses td+ forM_ as $ \a -> do+ mod_addr_tx a+ modAddressCount add a+ mod_outputs+ mod_unspent+ insertTx td'+ updateMempool td'+ where+ td' = td { txDataDeleted = not add }+ tx_ref = TxRef (txDataBlock td) (txHash (txData td))+ mod_addr_tx a | add = insertAddrTx a tx_ref+ | otherwise = deleteAddrTx a tx_ref+ mod_unspent | add = spendOutputs us td+ | otherwise = unspendOutputs td+ mod_outputs | add = addOutputs td+ | otherwise = delOutputs td++updateMempool :: (StoreRead m, StoreWrite m) => TxData -> m ()+updateMempool td = do+ mp <- getMempool+ setMempool (f mp)+ where+ f mp | txDataDeleted td || confirmed (txDataBlock td) =+ filter ((/= txHash (txData td)) . txRefHash) mp+ | otherwise =+ sortOn Down $ TxRef (txDataBlock td) (txHash (txData td)) : mp++spendOutputs :: (StoreRead m, StoreWrite m) => [Unspent] -> TxData -> m ()+spendOutputs us td =+ zipWithM_ (spendOutput (txHash (txData td))) [0 ..] us++addOutputs :: (StoreRead m, StoreWrite m, MonadLogger m) => TxData -> m ()+addOutputs td =+ zipWithM_+ (addOutput (txDataBlock td) . OutPoint (txHash (txData td)))+ [0 ..]+ (txOut (txData td))++isRBF+ :: (StoreRead m, MonadLogger m)+ => BlockRef+ -> Tx+ -> m Bool+isRBF br tx+ | confirmed br = return False+ | otherwise =+ getNetwork >>= \net ->+ if getReplaceByFee net+ then go+ else return False+ where+ go | any ((< 0xffffffff - 1) . txInSequence) (txIn tx) = return True+ | otherwise =+ let hs = nub' $ map (outPointHash . prevOutput) (txIn tx)+ ck [] = return False+ ck (h:hs') =+ getActiveTxData h >>= \case+ Nothing -> do+ $(logErrorS) "BlockStore" $+ "Parent transaction not found: " <> txHashToHex h+ error $ "Parent transaction not found: " <> show h+ Just t+ | confirmed (txDataBlock t) -> ck hs'+ | txDataRBF t -> return True+ | otherwise -> ck hs'+ in ck hs++addOutput+ :: (StoreRead m, StoreWrite m, MonadLogger m)+ => BlockRef+ -> OutPoint+ -> TxOut+ -> m ()+addOutput = modOutput True++delOutput+ :: (StoreRead m, StoreWrite m)+ => BlockRef+ -> OutPoint+ -> TxOut+ -> m ()+delOutput = modOutput False++modOutput+ :: (StoreRead m, StoreWrite m)+ => Bool+ -> BlockRef+ -> OutPoint+ -> TxOut+ -> m ()+modOutput add br op o = do+ mod_unspent+ forM_ ma $ \a -> do+ mod_addr_unspent a u+ modBalance (confirmed br) add a (outValue o)+ modifyReceived a v+ where+ v | add = (+ outValue o)+ | otherwise = subtract (outValue o)+ ma = eitherToMaybe (scriptToAddressBS (scriptOutput o))+ u = Unspent { unspentScript = B.Short.toShort (scriptOutput o)+ , unspentBlock = br+ , unspentPoint = op+ , unspentAmount = outValue o+ , unspentAddress = ma+ }+ mod_unspent | add = insertUnspent u+ | otherwise = deleteUnspent op+ mod_addr_unspent | add = insertAddrUnspent+ | otherwise = deleteAddrUnspent++delOutputs :: (StoreRead m, StoreWrite m) => TxData -> m ()+delOutputs td =+ forM_ (zip [0..] outs) $ \(i, o) -> do+ let op = OutPoint (txHash (txData td)) i+ delOutput (txDataBlock td) op o+ where+ outs = txOut (txData td)++getImportTxData+ :: ( StoreRead m+ , MonadLogger m+ , MonadError ImportException m+ )+ => TxHash+ -> m TxData+getImportTxData th =+ getActiveTxData th >>= \case+ Nothing -> do+ $(logDebugS) "BlockStore" $ "Tx not found: " <> txHashToHex th+ throwError TxNotFound+ Just d -> return d++getTxOut+ :: Word32+ -> Tx+ -> Maybe TxOut+getTxOut i tx = do+ guard (fromIntegral i < length (txOut tx))+ return $ txOut tx !! fromIntegral i++spendOutput+ :: (StoreRead m, StoreWrite m)+ => TxHash+ -> Word32+ -> Unspent+ -> m ()+spendOutput th ix u = do+ insertSpender (unspentPoint u) (Spender th ix)+ let pk = B.Short.fromShort (unspentScript u)+ case scriptToAddressBS pk of+ Left _ -> return ()+ Right a -> do+ decreaseBalance (confirmed (unspentBlock u)) a (unspentAmount u)+ deleteAddrUnspent a u+ deleteUnspent (unspentPoint u)++unspendOutputs :: (StoreRead m, StoreWrite m, MonadLogger m) => TxData -> m ()+unspendOutputs td = mapM_ unspendOutput (prevOuts (txData td))++unspendOutput :: (StoreRead m, StoreWrite m, MonadLogger m) => OutPoint -> m ()+unspendOutput op = do+ t <- getActiveTxData (outPointHash op) >>= \case+ Nothing -> do+ $(logErrorS) "BlockStore" $+ "Could not find tx data: "+ <> txHashToHex (outPointHash op)+ error $+ "Could not find tx data: "+ <> show (outPointHash op)+ Just t -> return t+ o <- case getTxOut (outPointIndex op) (txData t) of+ Nothing -> do+ $(logErrorS) "BlockStore" $+ "Could not find output: " <> showOutput op+ error $ "Could not find output: " <> show op+ Just o -> return o+ deleteSpender op+ let m = eitherToMaybe (scriptToAddressBS (scriptOutput o))+ u = Unspent { unspentAmount = outValue o+ , unspentBlock = txDataBlock t+ , unspentScript = B.Short.toShort (scriptOutput o)+ , unspentPoint = op+ , unspentAddress = m+ }+ insertUnspent u+ forM_ m $ \a -> do+ insertAddrUnspent a u+ increaseBalance (confirmed (unspentBlock u)) a (outValue o)++modifyReceived+ :: (StoreRead m, StoreWrite m)+ => Address+ -> (Word64 -> Word64)+ -> m ()+modifyReceived a f =+ getBalance a >>= \b ->+ setBalance b {balanceTotalReceived = f (balanceTotalReceived b)}++decreaseBalance+ :: (StoreRead m, StoreWrite m)+ => Bool+ -> Address+ -> Word64+ -> m ()+decreaseBalance conf = modBalance conf False++increaseBalance+ :: (StoreRead m, StoreWrite m)+ => Bool+ -> Address+ -> Word64+ -> m ()+increaseBalance conf = modBalance conf True++modBalance+ :: (StoreRead m, StoreWrite m)+ => Bool -- ^ confirmed+ -> Bool -- ^ add+ -> Address+ -> Word64+ -> m ()+modBalance conf add a val =+ getBalance a >>= \b -> setBalance ((g . f) b)+ where+ g b = b { balanceUnspentCount = m 1 (balanceUnspentCount b) }+ f b | conf = b { balanceAmount = m val (balanceAmount b) }+ | otherwise = b { balanceZero = m val (balanceZero b) }+ m | add = (+)+ | otherwise = subtract++modAddressCount :: (StoreRead m, StoreWrite m) => Bool -> Address -> m ()+modAddressCount add a =+ getBalance a >>= \b ->+ setBalance b {balanceTxCount = f (balanceTxCount b)}+ where+ f | add = (+ 1)+ | otherwise = subtract 1++txOutAddrs :: [TxOut] -> [Address]+txOutAddrs = nub' . rights . map (scriptToAddressBS . scriptOutput)++txInAddrs :: [Prev] -> [Address]+txInAddrs = nub' . rights . map (scriptToAddressBS . prevScript)++txDataAddresses :: TxData -> [Address]+txDataAddresses t =+ nub' $ txInAddrs prevs <> txOutAddrs outs+ where+ prevs = I.elems (txDataPrevs t)+ outs = txOut (txData t)++isCoinbase :: Tx -> Bool+isCoinbase = all ((== nullOutPoint) . prevOutput) . txIn++showOutput :: OutPoint -> Text+showOutput OutPoint {outPointHash = h, outPointIndex = i} =+ txHashToHex h <> "/" <> cs (show i)++prevOuts :: Tx -> [OutPoint]+prevOuts tx = filter (/= nullOutPoint) (map prevOutput (txIn tx))
src/Haskoin/Store/Web.hs view
@@ -1,1194 +1,1113 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}-module Haskoin.Store.Web- ( -- * Web- WebConfig (..)- , Except (..)- , WebLimits (..)- , WebTimeouts (..)- , runWeb- ) where--import Conduit ()-import Control.Applicative ((<|>))-import Control.Monad (forever, guard, unless, when,- (<=<))-import Control.Monad.Logger (MonadLogger, MonadLoggerIO,- askLoggerIO, logInfoS,- monadLoggerLog)-import Control.Monad.Reader (ReaderT, asks, local,- runReaderT)-import Control.Monad.Trans (lift)-import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)-import Data.Aeson (Encoding, ToJSON (..))-import Data.Aeson.Encoding (encodingToLazyByteString, list,- pair, pairs, unsafeToEncoding)-import qualified Data.ByteString as B-import Data.ByteString.Builder (char7, lazyByteString,- lazyByteStringHex)-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.Encoding as T-import qualified Data.Text.Lazy as TL-import Data.Time.Clock (NominalDiffTime, diffUTCTime,- getCurrentTime)-import Data.Time.Clock.System (getSystemTime, systemSeconds)-import Data.Version (showVersion)-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,- stringToAddr, txHash,- xPubImport)-import Haskoin.Node (Chain, OnlinePeer (..),- PeerManager, chainGetBest,- managerGetPeers, sendMessage)-import Haskoin.Store.Cache (CacheT, evictFromCache,- withCache)-import Haskoin.Store.Common (Limits (..), PubExcept (..),- Start (..), StoreEvent (..),- StoreRead (..), blockAtOrBefore,- getTransaction, nub')-import Haskoin.Store.Data (BlockData (..), BlockRef (..),- DeriveType (..), Event (..),- Except (..), GenericResult (..),- HealthCheck (..),- PeerInformation (..),- StoreInput (..),- Transaction (..), TxId (..),- TxRef (..), UnixTime, Unspent,- XPubBal (..), XPubSpec (..),- balanceToEncoding,- blockDataToEncoding, isCoinbase,- nullBalance, transactionData,- transactionToEncoding,- unspentToEncoding,- xPubBalToEncoding,- xPubUnspentToEncoding)-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 qualified Paths_haskoin_store as P (version)-import Text.Printf (printf)-import Text.Read (readMaybe)-import UnliftIO (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 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- , maxLimitInitialGap :: !Word32- }- deriving (Eq, Show)--instance Default WebLimits where- def =- WebLimits- { maxLimitCount = 20000- , maxLimitFull = 5000- , maxLimitOffset = 50000- , maxLimitDefault = 2000- , maxLimitGap = 32- , maxLimitInitialGap = 20- }--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- guard (TL.length s == 32 * 2)- x <- fmap B.reverse (decodeHex (TL.toStrict s)) >>= eitherToMaybe . decode- return StartParamHash {startParamHash = x}- g = do- x <- readMaybe (TL.unpack s)- guard $ x <= 1230768000- return StartParamHeight {startParamHeight = x}- t = do- x <- readMaybe (TL.unpack s)- guard $ x > 1230768000- return StartParamTime {startParamTime = x}--runInWebReader ::- MonadIO m- => CacheT (DatabaseReaderT m) a- -> ReaderT WebConfig m a-runInWebReader f = do- bdb <- asks (storeDB . webStore)- mc <- asks (storeCache . webStore)- lift $ withDatabaseReader bdb (withCache mc f)--runNoCache :: MonadIO m => Bool -> ReaderT WebConfig m a -> ReaderT WebConfig m a-runNoCache False f = f-runNoCache True f =- local (\s -> s {webStore = (webStore s) {storeCache = Nothing}}) f--instance (MonadUnliftIO m, MonadLoggerIO m) =>- StoreRead (ReaderT WebConfig m) where- getMaxGap = runInWebReader getMaxGap- getInitialGap = runInWebReader getInitialGap- getNetwork = runInWebReader getNetwork- getBestBlock = runInWebReader getBestBlock- getBlocksAtHeight height = runInWebReader (getBlocksAtHeight height)- getBlock bh = runInWebReader (getBlock bh)- getTxData th = runInWebReader (getTxData th)- getSpender op = runInWebReader (getSpender op)- getSpenders th = runInWebReader (getSpenders th)- getUnspent op = runInWebReader (getUnspent op)- getBalance a = runInWebReader (getBalance a)- getBalances as = runInWebReader (getBalances as)- getMempool = runInWebReader getMempool- getAddressesTxs as = runInWebReader . getAddressesTxs as- getAddressesUnspents as = runInWebReader . getAddressesUnspents as- xPubBals = runInWebReader . xPubBals- xPubSummary = runInWebReader . xPubSummary- xPubUnspents xpub = runInWebReader . xPubUnspents xpub- xPubTxs xpub = runInWebReader . xPubTxs xpub--instance (MonadUnliftIO m, MonadLoggerIO m) => StoreRead (WebT m) where- getNetwork = lift getNetwork- getBestBlock = lift getBestBlock- getBlocksAtHeight = lift . getBlocksAtHeight- getBlock = lift . getBlock- getTxData = lift . getTxData- getSpender = lift . getSpender- getSpenders = lift . getSpenders- getUnspent = lift . getUnspent- getBalance = lift . getBalance- getBalances = lift . getBalances- getMempool = lift getMempool- getAddressesTxs as = lift . getAddressesTxs as- getAddressesUnspents as = lift . getAddressesUnspents as- xPubBals = lift . xPubBals- xPubSummary = lift . xPubSummary- xPubUnspents xpub = lift . xPubUnspents xpub- xPubTxs xpub = lift . xPubTxs xpub- getMaxGap = lift getMaxGap- getInitialGap = lift getInitialGap--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, ToJSON a, Serialize a)- => Bool -- ^ binary- -> Maybe a- -> WebT m ()-maybeSerial _ Nothing = S.raise ThingNotFound-maybeSerial proto (Just x) = S.raw (serialAny proto x)--maybeSerialRaw :: (Monad m, Serialize a) => Bool -> Maybe a -> WebT m ()-maybeSerialRaw _ Nothing = S.raise ThingNotFound-maybeSerialRaw proto (Just x) = S.raw (serialAnyRaw proto x)--maybeSerialNet ::- (Monad m, Serialize a)- => Bool- -> (Network -> a -> Encoding)- -> Maybe a- -> WebT m ()-maybeSerialNet _ _ Nothing = S.raise ThingNotFound-maybeSerialNet proto f (Just x) = do- net <- lift $ asks (storeNetwork . webStore)- S.raw (serialAnyNet proto (f net) x)--protoSerial ::- (Monad m, ToJSON a, Serialize a)- => Bool- -> a- -> WebT m ()-protoSerial proto x = do- S.raw (serialAny proto x)--protoSerialRaw ::- (Monad m, Serialize a)- => Bool- -> a- -> WebT m ()-protoSerialRaw proto x = do- S.raw (serialAnyRaw proto x)--protoSerialRawList ::- (Monad m, Serialize a)- => Bool- -> [a]- -> WebT m ()-protoSerialRawList proto x = do- S.raw (serialAnyRawList proto x)--protoSerialNet ::- (Monad m, Serialize a)- => Bool- -> (Network -> a -> Encoding)- -> a- -> WebT m ()-protoSerialNet proto f x = do- net <- lift $ asks (storeNetwork . webStore)- S.raw (serialAnyNet proto (f net) x)--scottyBestBlock ::- (MonadUnliftIO m, 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 >>= protoSerialRaw proto- else protoSerialNet proto blockDataToEncoding (pruneTx n b)--scottyBlock :: (MonadUnliftIO m, 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 >>= protoSerialRaw proto- else protoSerialNet proto blockDataToEncoding (pruneTx n b)--scottyBlockHeight :: (MonadUnliftIO m, 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- protoSerialRawList proto rawblocks- else do- blocks <- catMaybes <$> mapM getBlock hs- let blocks' = map (pruneTx n) blocks- protoSerialNet proto (list . blockDataToEncoding) blocks'--scottyBlockTime :: (MonadUnliftIO m, 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 maybeSerialNet proto blockDataToEncoding m--scottyBlockHeights :: (MonadUnliftIO m, 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- protoSerialNet proto (list . blockDataToEncoding) blocks--scottyBlockLatest :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()-scottyBlockLatest = do- setHeaders- n <- parseNoTx- proto <- setupBin- getBestBlock >>= \case- Just h -> do- blocks <- reverse <$> go 100 n h- protoSerialNet proto (list . blockDataToEncoding) 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 :: (MonadUnliftIO m, 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)- protoSerialNet proto (list . blockDataToEncoding) bks--scottyMempool :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()-scottyMempool = do- setHeaders- l <- fromIntegral <$> getLimit False- o <- fromIntegral <$> getOffset- proto <- setupBin- txs <- take l . drop o . map txRefHash <$> getMempool- protoSerial proto txs--scottyTransaction :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()-scottyTransaction = do- setHeaders- MyTxHash txid <- S.param "txid"- proto <- setupBin- res <- getTransaction txid- maybeSerialNet proto transactionToEncoding res--scottyRawTransaction :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()-scottyRawTransaction = do- setHeaders- MyTxHash txid <- S.param "txid"- proto <- setupBin- res <- fmap transactionData <$> getTransaction txid- maybeSerialRaw proto res--scottyTxAfterHeight :: (MonadUnliftIO m, 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 :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()-scottyTransactions = do- setHeaders- txids <- map (\(MyTxHash h) -> h) <$> S.param "txids"- proto <- setupBin- txs <- catMaybes <$> mapM getTransaction (nub txids)- protoSerialNet proto (list . transactionToEncoding) txs--scottyBlockTransactions :: (MonadUnliftIO m, 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- protoSerialNet proto (list . transactionToEncoding) txs- Nothing -> S.raise ThingNotFound--scottyRawTransactions ::- (MonadUnliftIO m, 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)- protoSerialRawList 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 ::- (MonadUnliftIO m, 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- protoSerialRawList proto txs- Nothing -> S.raise ThingNotFound--scottyAddressTxs :: (MonadUnliftIO m, MonadLoggerIO m) => Bool -> WebT m ()-scottyAddressTxs full = do- setHeaders- a <- parseAddress- l <- getLimits full- proto <- setupBin- if full- then do- getAddressTxsFull l a >>=- protoSerialNet proto (list . transactionToEncoding)- else do- getAddressTxsLimit l a >>= protoSerial proto--scottyAddressesTxs ::- (MonadUnliftIO m, MonadLoggerIO m) => Bool -> WebT m ()-scottyAddressesTxs full = do- setHeaders- as <- parseAddresses- l <- getLimits full- proto <- setupBin- if full- then getAddressesTxsFull l as >>=- protoSerialNet proto (list . transactionToEncoding)- else getAddressesTxsLimit l as >>= protoSerial proto--scottyAddressUnspent :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()-scottyAddressUnspent = do- setHeaders- a <- parseAddress- l <- getLimits False- proto <- setupBin- uns <- getAddressUnspentsLimit l a- protoSerialNet proto (list . unspentToEncoding) uns--scottyAddressesUnspent :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()-scottyAddressesUnspent = do- setHeaders- as <- parseAddresses- l <- getLimits False- proto <- setupBin- uns <- getAddressesUnspentsLimit l as- protoSerialNet proto (list . unspentToEncoding) uns--scottyAddressBalance :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()-scottyAddressBalance = do- setHeaders- a <- parseAddress- proto <- setupBin- res <- getBalance a- protoSerialNet proto balanceToEncoding res--scottyAddressesBalances :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()-scottyAddressesBalances = do- setHeaders- as <- parseAddresses- proto <- setupBin- res <- getBalances as- protoSerialNet proto (list . balanceToEncoding) res--scottyXpubBalances :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()-scottyXpubBalances = do- setHeaders- nocache <- parseNoCache- xpub <- parseXpub- proto <- setupBin- res <-- filter (not . nullBalance . xPubBal) <$>- lift (runNoCache nocache (xPubBals xpub))- protoSerialNet proto (list . xPubBalToEncoding) res--scottyXpubTxs :: (MonadUnliftIO m, MonadLoggerIO m) => Bool -> WebT m ()-scottyXpubTxs full = do- setHeaders- nocache <- parseNoCache- xpub <- parseXpub- l <- getLimits full- proto <- setupBin- txs <- lift . runNoCache nocache $ xPubTxs xpub l- if full- then do- txs' <-- fmap catMaybes . lift . runNoCache nocache $- mapM (getTransaction . txRefHash) txs- protoSerialNet proto (list . transactionToEncoding) txs'- else protoSerial proto txs--scottyXpubEvict :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()-scottyXpubEvict =- lift (asks (storeCache . webStore)) >>= \cache -> do- setHeaders- xpub <- parseXpub- proto <- setupBin- lift . withCache cache $ evictFromCache [xpub]- protoSerial proto (GenericResult True)---scottyXpubUnspents :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()-scottyXpubUnspents = do- setHeaders- nocache <- parseNoCache- xpub <- parseXpub- proto <- setupBin- l <- getLimits False- uns <- lift . runNoCache nocache $ xPubUnspents xpub l- protoSerialNet proto (list . xPubUnspentToEncoding) uns--scottyXpubSummary :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m ()-scottyXpubSummary = do- setHeaders- nocache <- parseNoCache- xpub <- parseXpub- proto <- setupBin- res <- lift . runNoCache nocache $ 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- 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 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/evict" scottyXpubEvict- 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 :: (MonadUnliftIO m, MonadLoggerIO m) => WebT m (Maybe Start)-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 = do- return $ AtBlock h- start_block h = do- b <- MaybeT $ getBlock (BlockHash h)- return $ AtBlock (blockDataHeight b)- start_tx h = do- _ <- MaybeT $ getTxData (TxHash h)- return $ AtTx (TxHash h)- start_time q = do- b <- MaybeT $ blockAtOrBefore q- let g = blockDataHeight b- return $ AtBlock g--getLimits :: (MonadLoggerIO m, MonadUnliftIO m) => Bool -> WebT m Limits-getLimits full = do- o <- getOffset- l <- getLimit full- s <- getStart- return Limits {limit = l, offset = o, start = s}--getOffset :: Monad m => WebT m Word32-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 Word32-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 (min m d)- else 0- Just n ->- if m > 0- then (min m n)- else 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--parseNoCache :: (Monad m, ScottyError e) => ActionT e m Bool-parseNoCache = S.param "nocache" `S.rescue` const (return False)--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 ::- (ToJSON a, Serialize a)- => Bool -- ^ binary- -> a- -> L.ByteString-serialAny True = runPutLazy . put-serialAny False = encodingToLazyByteString . toEncoding--serialAnyRaw :: Serialize a => Bool -> a -> L.ByteString-serialAnyRaw True x = runPutLazy (put x)-serialAnyRaw False x = encodingToLazyByteString (pairs ps)- where- ps = "result" `pair` unsafeToEncoding str- str = char7 '"' <> lazyByteStringHex (runPutLazy (put x)) <> char7 '"'--serialAnyRawList :: Serialize a => Bool -> [a] -> L.ByteString-serialAnyRawList True x = runPutLazy (put x)-serialAnyRawList False xs = encodingToLazyByteString (list f xs)- where- f x = unsafeToEncoding (str x)- str x = char7 '"' <> lazyByteStringHex (runPutLazy (put x)) <> char7 '"'--serialAnyNet ::- Serialize a => Bool -> (a -> Encoding) -> a -> L.ByteString-serialAnyNet True _ = runPutLazy . put-serialAnyNet False f = encodingToLazyByteString . f--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- -> PeerManager- -> 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- , healthVersion = showVersion P.version- }- 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 . txRefBlock <$> 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 10000000 (managerGetPeers mgr)- block_best = runMaybeT $ do- h <- MaybeT getBestBlock- MaybeT $ getBlock h- chain_best = timeout 10000000 $ 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 => PeerManager -> 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 = show 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 (GenericResult (Maybe Bool))-cbAfterHeight d h t- | d <= 0 = return $ GenericResult Nothing- | otherwise = do- x <- fmap snd <$> tst d t- return $ GenericResult 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)- => Limits- -> Address- -> m [TxRef]-getAddressTxsLimit limits addr = getAddressTxs addr limits--getAddressTxsFull ::- (Monad m, StoreRead m)- => Limits- -> Address- -> m [Transaction]-getAddressTxsFull limits addr = do- txs <- getAddressTxsLimit limits addr- catMaybes <$> mapM (getTransaction . txRefHash) txs--getAddressesTxsLimit ::- (Monad m, StoreRead m)- => Limits- -> [Address]- -> m [TxRef]-getAddressesTxsLimit limits addrs = getAddressesTxs addrs limits--getAddressesTxsFull ::- (Monad m, StoreRead m)- => Limits- -> [Address]- -> m [Transaction]-getAddressesTxsFull limits addrs =- fmap catMaybes $- getAddressesTxsLimit limits addrs >>=- mapM (getTransaction . txRefHash)--getAddressUnspentsLimit ::- (Monad m, StoreRead m)- => Limits- -> Address- -> m [Unspent]-getAddressUnspentsLimit limits addr = getAddressUnspents addr limits--getAddressesUnspentsLimit ::- (Monad m, StoreRead m)- => Limits- -> [Address]- -> m [Unspent]-getAddressesUnspentsLimit limits addrs = getAddressesUnspents addrs limits---- | Publish a new transaction to the network.-publishTx ::- (MonadUnliftIO m, StoreRead m)- => Network- -> Publisher StoreEvent- -> PeerManager- -> 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+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+module Haskoin.Store.Web+ ( -- * Web+ WebConfig (..)+ , Except (..)+ , WebLimits (..)+ , WebTimeouts (..)+ , runWeb+ ) where++import Conduit ()+import Control.Applicative ((<|>))+import Control.Monad (forever, when, (<=<))+import Control.Monad.Logger+import Control.Monad.Reader (ReaderT, asks, local,+ runReaderT)+import Control.Monad.Trans (lift)+import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)+import Data.Aeson (Encoding, ToJSON (..), Value)+import Data.Aeson.Encode.Pretty (Config (..), defConfig,+ encodePretty')+import Data.Aeson.Encoding (encodingToLazyByteString, list)+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.Function ((&))+import Data.List (nub)+import Data.Maybe (catMaybes, fromMaybe, isJust,+ listToMaybe, mapMaybe)+import Data.Proxy (Proxy (..))+import Data.Serialize as Serialize+import Data.String (fromString)+import Data.String.Conversions (cs)+import Data.Text (Text)+import qualified Data.Text.Encoding as T+import Data.Time.Clock (NominalDiffTime, diffUTCTime,+ getCurrentTime)+import Data.Time.Clock.System (getSystemTime, systemSeconds)+import Data.Version (showVersion)+import Data.Word (Word32, Word64)+import Database.RocksDB (Property (..), getProperty)+import qualified Haskoin.Block as H+import Haskoin.Constants+import Haskoin.Network+import Haskoin.Node (Chain, OnlinePeer (..),+ PeerManager, chainGetBest,+ managerGetPeers, sendMessage)+import Haskoin.Store.Cache (CacheT, evictFromCache,+ withCache)+import Haskoin.Store.Common (Limits (..), PubExcept (..),+ Start (..), StoreEvent (..),+ StoreRead (..), blockAtOrBefore,+ getTransaction)+import Haskoin.Store.Data+import Haskoin.Store.Database.Reader (DatabaseReader (..),+ DatabaseReaderT,+ withDatabaseReader)+import Haskoin.Store.Manager (Store (..))+import Haskoin.Store.WebCommon+import Haskoin.Transaction+import Haskoin.Util+import Network.HTTP.Types (Status (..), status400,+ status403, status404, status500,+ status503)+import Network.Wai (Middleware, Request (..),+ responseStatus)+import Network.Wai.Handler.Warp (defaultSettings, setHost,+ setPort)+import NQE (Inbox, Publisher, receive,+ withSubscription)+import qualified Paths_haskoin_store as P (version)+import Text.Printf (printf)+import UnliftIO (MonadIO, MonadUnliftIO,+ askRunInIO, liftIO, timeout)+import Web.Scotty.Internal.Types (ActionT)+import qualified Web.Scotty.Trans as S++type WebT m = ActionT Except (ReaderT WebConfig m)++data WebLimits = WebLimits+ { maxLimitCount :: !Word32+ , maxLimitFull :: !Word32+ , maxLimitOffset :: !Word32+ , maxLimitDefault :: !Word32+ , maxLimitGap :: !Word32+ , maxLimitInitialGap :: !Word32+ }+ deriving (Eq, Show)++instance Default WebLimits where+ def =+ WebLimits+ { maxLimitCount = 200000+ , maxLimitFull = 5000+ , maxLimitOffset = 50000+ , maxLimitDefault = 100+ , maxLimitGap = 32+ , maxLimitInitialGap = 20+ }++data WebConfig = WebConfig+ { webHost :: !String+ , webPort :: !Int+ , webStore :: !Store+ , webMaxLimits :: !WebLimits+ , webReqLog :: !Bool+ , webWebTimeouts :: !WebTimeouts+ }++data WebTimeouts = WebTimeouts+ { txTimeout :: !Word64+ , blockTimeout :: !Word64+ }+ deriving (Eq, Show)++data SerialAs = SerialAsBinary | SerialAsJSON | SerialAsPrettyJSON+ deriving (Eq, Show)++instance Default WebTimeouts where+ def = WebTimeouts {txTimeout = 300, blockTimeout = 7200}++instance (MonadUnliftIO m, MonadLoggerIO m) =>+ StoreRead (ReaderT WebConfig m) where+ getMaxGap = runInWebReader getMaxGap+ getInitialGap = runInWebReader getInitialGap+ getNetwork = runInWebReader getNetwork+ getBestBlock = runInWebReader getBestBlock+ getBlocksAtHeight height = runInWebReader (getBlocksAtHeight height)+ getBlock bh = runInWebReader (getBlock bh)+ getTxData th = runInWebReader (getTxData th)+ getSpender op = runInWebReader (getSpender op)+ getSpenders th = runInWebReader (getSpenders th)+ getUnspent op = runInWebReader (getUnspent op)+ getBalance a = runInWebReader (getBalance a)+ getBalances as = runInWebReader (getBalances as)+ getMempool = runInWebReader getMempool+ getAddressesTxs as = runInWebReader . getAddressesTxs as+ getAddressesUnspents as = runInWebReader . getAddressesUnspents as+ xPubBals = runInWebReader . xPubBals+ xPubSummary = runInWebReader . xPubSummary+ xPubUnspents xpub = runInWebReader . xPubUnspents xpub+ xPubTxs xpub = runInWebReader . xPubTxs xpub++instance (MonadUnliftIO m, MonadLoggerIO m) => StoreRead (WebT m) where+ getNetwork = lift getNetwork+ getBestBlock = lift getBestBlock+ getBlocksAtHeight = lift . getBlocksAtHeight+ getBlock = lift . getBlock+ getTxData = lift . getTxData+ getSpender = lift . getSpender+ getSpenders = lift . getSpenders+ getUnspent = lift . getUnspent+ getBalance = lift . getBalance+ getBalances = lift . getBalances+ getMempool = lift getMempool+ getAddressesTxs as = lift . getAddressesTxs as+ getAddressesUnspents as = lift . getAddressesUnspents as+ xPubBals = lift . xPubBals+ xPubSummary = lift . xPubSummary+ xPubUnspents xpub = lift . xPubUnspents xpub+ xPubTxs xpub = lift . xPubTxs xpub+ getMaxGap = lift getMaxGap+ getInitialGap = lift getInitialGap++-------------------+-- Path Handlers --+-------------------++runWeb :: (MonadUnliftIO m , MonadLoggerIO m) => WebConfig -> m ()+runWeb cfg@WebConfig {webHost = host, webPort = port, webReqLog = reqlog} = do+ reqLogger <- logIt+ runner <- askRunInIO+ S.scottyOptsT opts (runner . (`runReaderT` cfg)) $ do+ when reqlog $ S.middleware reqLogger+ S.defaultHandler defHandler+ handlePaths+ S.notFound $ S.raise ThingNotFound+ where+ opts = def {S.settings = settings defaultSettings}+ settings = setPort port . setHost (fromString host)++defHandler :: Monad m => Except -> WebT m ()+defHandler e = do+ proto <- setupContentType False+ 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+ S.raw $ protoSerial proto toEncoding toJSON e++handlePaths ::+ (MonadUnliftIO m, MonadLoggerIO m)+ => S.ScottyT Except (ReaderT WebConfig m) ()+handlePaths = do+ -- Block Paths+ pathPretty+ (GetBlock <$> paramLazy <*> paramDef)+ scottyBlock+ blockDataToEncoding+ blockDataToJSON+ pathCompact+ (GetBlocks <$> param <*> paramDef)+ scottyBlocks+ (list . blockDataToEncoding)+ (json_list blockDataToJSON)+ pathCompact+ (GetBlockRaw <$> paramLazy)+ scottyBlockRaw+ (const toEncoding)+ (const toJSON)+ pathPretty+ (GetBlockBest <$> paramDef)+ scottyBlockBest+ blockDataToEncoding+ blockDataToJSON+ pathCompact+ (GetBlockBestRaw & return)+ scottyBlockBestRaw+ (const toEncoding)+ (const toJSON)+ pathCompact+ (GetBlockLatest <$> paramDef)+ scottyBlockLatest+ (list . blockDataToEncoding)+ (json_list blockDataToJSON)+ pathPretty+ (GetBlockHeight <$> paramLazy <*> paramDef)+ scottyBlockHeight+ (list . blockDataToEncoding)+ (json_list blockDataToJSON)+ pathCompact+ (GetBlockHeights <$> param <*> paramDef)+ scottyBlockHeights+ (list . blockDataToEncoding)+ (json_list blockDataToJSON)+ pathCompact+ (GetBlockHeightRaw <$> paramLazy)+ scottyBlockHeightRaw+ (const toEncoding)+ (const toJSON)+ pathPretty+ (GetBlockTime <$> paramLazy <*> paramDef)+ scottyBlockTime+ blockDataToEncoding+ blockDataToJSON+ pathCompact+ (GetBlockTimeRaw <$> paramLazy)+ scottyBlockTimeRaw+ (const toEncoding)+ (const toJSON)+ -- Transaction Paths+ pathPretty+ (GetTx <$> paramLazy)+ scottyTx+ transactionToEncoding+ transactionToJSON+ pathCompact+ (GetTxs <$> param)+ scottyTxs+ (list . transactionToEncoding)+ (json_list transactionToJSON)+ pathCompact+ (GetTxRaw <$> paramLazy)+ scottyTxRaw+ (const toEncoding)+ (const toJSON)+ pathCompact+ (GetTxsRaw <$> param)+ scottyTxsRaw+ (const toEncoding)+ (const toJSON)+ pathCompact+ (GetTxsBlock <$> paramLazy)+ scottyTxsBlock+ (list . transactionToEncoding)+ (json_list transactionToJSON)+ pathCompact+ (GetTxsBlockRaw <$> paramLazy)+ scottyTxsBlockRaw+ (const toEncoding)+ (const toJSON)+ pathCompact+ (GetTxAfter <$> paramLazy <*> paramLazy)+ scottyTxAfter+ (const toEncoding)+ (const toJSON)+ pathCompact+ (PostTx <$> parseBody)+ scottyPostTx+ (const toEncoding)+ (const toJSON)+ pathPretty+ (GetMempool <$> paramOptional <*> parseOffset)+ scottyMempool+ (const toEncoding)+ (const toJSON)+ -- Address Paths+ pathPretty+ (GetAddrTxs <$> paramLazy <*> parseLimits)+ scottyAddrTxs+ (const toEncoding)+ (const toJSON)+ pathCompact+ (GetAddrsTxs <$> param <*> parseLimits)+ scottyAddrsTxs+ (const toEncoding)+ (const toJSON)+ pathCompact+ (GetAddrTxsFull <$> paramLazy <*> parseLimits)+ scottyAddrTxsFull+ (list . transactionToEncoding)+ (json_list transactionToJSON)+ pathCompact+ (GetAddrsTxsFull <$> param <*> parseLimits)+ scottyAddrsTxsFull+ (list . transactionToEncoding)+ (json_list transactionToJSON)+ pathPretty+ (GetAddrBalance <$> paramLazy)+ scottyAddrBalance+ balanceToEncoding+ balanceToJSON+ pathCompact+ (GetAddrsBalance <$> param)+ scottyAddrsBalance+ (list . balanceToEncoding)+ (json_list balanceToJSON)+ pathPretty+ (GetAddrUnspent <$> paramLazy <*> parseLimits)+ scottyAddrUnspent+ (list . unspentToEncoding)+ (json_list unspentToJSON)+ pathCompact+ (GetAddrsUnspent <$> param <*> parseLimits)+ scottyAddrsUnspent+ (list . unspentToEncoding)+ (json_list unspentToJSON)+ -- XPubs+ pathPretty+ (GetXPub <$> paramLazy <*> paramDef <*> paramDef)+ scottyXPub+ (const toEncoding)+ (const toJSON)+ pathPretty+ (GetXPubTxs <$> paramLazy <*> paramDef <*> parseLimits <*> paramDef)+ scottyXPubTxs+ (const toEncoding)+ (const toJSON)+ pathCompact+ (GetXPubTxsFull <$> paramLazy <*> paramDef <*> parseLimits <*> paramDef)+ scottyXPubTxsFull+ (list . transactionToEncoding)+ (json_list transactionToJSON)+ pathPretty+ (GetXPubBalances <$> paramLazy <*> paramDef <*> paramDef)+ scottyXPubBalances+ (list . xPubBalToEncoding)+ (json_list xPubBalToJSON)+ pathPretty+ (GetXPubUnspent <$> paramLazy <*> paramDef <*> parseLimits <*> paramDef)+ scottyXPubUnspent+ (list . xPubUnspentToEncoding)+ (json_list xPubUnspentToJSON)+ pathCompact+ (GetXPubEvict <$> paramLazy <*> paramDef)+ scottyXPubEvict+ (const toEncoding)+ (const toJSON)+ -- Network+ pathPretty+ (GetPeers & return)+ scottyPeers+ (const toEncoding)+ (const toJSON)+ pathPretty+ (GetHealth & return)+ scottyHealth+ (const toEncoding)+ (const toJSON)+ S.get "/events" scottyEvents+ S.get "/dbstats" scottyDbStats+ where+ json_list f net = toJSONList . map (f net)++pathPretty ::+ (ApiResource a b, MonadIO m)+ => WebT m a+ -> (a -> WebT m b)+ -> (Network -> b -> Encoding)+ -> (Network -> b -> Value)+ -> S.ScottyT Except (ReaderT WebConfig m) ()+pathPretty parser action encJson encValue =+ pathCommon parser action encJson encValue True++pathCompact ::+ (ApiResource a b, MonadIO m)+ => WebT m a+ -> (a -> WebT m b)+ -> (Network -> b -> Encoding)+ -> (Network -> b -> Value)+ -> S.ScottyT Except (ReaderT WebConfig m) ()+pathCompact parser action encJson encValue =+ pathCommon parser action encJson encValue False++pathCommon ::+ (ApiResource a b, MonadIO m)+ => WebT m a+ -> (a -> WebT m b)+ -> (Network -> b -> Encoding)+ -> (Network -> b -> Value)+ -> Bool+ -> S.ScottyT Except (ReaderT WebConfig m) ()+pathCommon parser action encJson encValue pretty =+ S.addroute (resourceMethod proxy) (capturePath proxy) $ do+ setHeaders+ proto <- setupContentType pretty+ net <- lift $ asks (storeNetwork . webStore)+ apiRes <- parser+ res <- action apiRes+ S.raw $ protoSerial proto (encJson net) (encValue net) res+ where+ toProxy :: WebT m a -> Proxy a+ toProxy = const Proxy+ proxy = toProxy parser++protoSerial+ :: Serialize a+ => SerialAs+ -> (a -> Encoding)+ -> (a -> Value)+ -> a+ -> L.ByteString+protoSerial SerialAsBinary _ _ = runPutLazy . put+protoSerial SerialAsJSON f _ = encodingToLazyByteString . f+protoSerial SerialAsPrettyJSON _ g =+ encodePretty' defConfig {confTrailingNewline = True} . g++setHeaders :: (Monad m, S.ScottyError e) => ActionT e m ()+setHeaders = S.setHeader "Access-Control-Allow-Origin" "*"++setupContentType :: Monad m => Bool -> ActionT Except m SerialAs+setupContentType pretty = do+ accept <- S.header "accept"+ maybe goJson setType accept+ where+ setType "application/octet-stream" = goBinary+ setType _ = goJson+ goBinary = do+ S.setHeader "Content-Type" "application/octet-stream"+ return SerialAsBinary+ goJson = do+ S.setHeader "Content-Type" "application/json"+ p <- S.param "pretty" `S.rescue` const (return pretty)+ return $ if p then SerialAsPrettyJSON else SerialAsJSON++-- GET Block / GET Blocks --++scottyBlock ::+ (MonadUnliftIO m, MonadLoggerIO m) => GetBlock -> WebT m BlockData+scottyBlock (GetBlock h (NoTx noTx)) =+ maybe (S.raise ThingNotFound) (return . pruneTx noTx) =<< getBlock h++scottyBlocks ::+ (MonadUnliftIO m, MonadLoggerIO m) => GetBlocks -> WebT m [BlockData]+scottyBlocks (GetBlocks hs (NoTx noTx)) =+ (pruneTx noTx <$>) . catMaybes <$> mapM getBlock (nub hs)++pruneTx :: Bool -> BlockData -> BlockData+pruneTx False b = b+pruneTx True b = b {blockDataTxs = take 1 (blockDataTxs b)}++-- GET BlockRaw --++scottyBlockRaw ::+ (MonadUnliftIO m, MonadLoggerIO m)+ => GetBlockRaw+ -> WebT m (RawResult H.Block)+scottyBlockRaw (GetBlockRaw h) = RawResult <$> getRawBlock h++getRawBlock ::+ (MonadUnliftIO m, MonadLoggerIO m) => H.BlockHash -> WebT m H.Block+getRawBlock h = do+ b <- maybe (S.raise ThingNotFound) return =<< getBlock h+ refuseLargeBlock b+ toRawBlock b++toRawBlock :: (Monad m, StoreRead m) => BlockData -> m H.Block+toRawBlock b = do+ let ths = blockDataTxs b+ txs <- map transactionData . catMaybes <$> mapM getTransaction ths+ return H.Block {H.blockHeader = blockDataHeader b, H.blockTxns = txs}++refuseLargeBlock :: Monad m => BlockData -> WebT m ()+refuseLargeBlock BlockData {blockDataTxs = txs} = do+ WebLimits {maxLimitFull = f} <- lift $ asks webMaxLimits+ when (length txs > fromIntegral f) $ S.raise BlockTooLarge++-- GET BlockBest / BlockBestRaw --++scottyBlockBest ::+ (MonadUnliftIO m, MonadLoggerIO m) => GetBlockBest -> WebT m BlockData+scottyBlockBest (GetBlockBest noTx) = do+ bestM <- getBestBlock+ maybe (S.raise ThingNotFound) (scottyBlock . (`GetBlock` noTx)) bestM++scottyBlockBestRaw ::+ (MonadUnliftIO m, MonadLoggerIO m)+ => GetBlockBestRaw+ -> WebT m (RawResult H.Block)+scottyBlockBestRaw _ =+ RawResult <$> (maybe (S.raise ThingNotFound) getRawBlock =<< getBestBlock)++-- GET BlockLatest --++scottyBlockLatest ::+ (MonadUnliftIO m, MonadLoggerIO m)+ => GetBlockLatest+ -> WebT m [BlockData]+scottyBlockLatest (GetBlockLatest (NoTx noTx)) =+ maybe (S.raise ThingNotFound) (go [] <=< getBlock) =<< getBestBlock+ where+ go acc Nothing = return acc+ go acc (Just b)+ | blockDataHeight b <= 0 = return acc+ | length acc == 99 = return (b:acc)+ | otherwise = do+ let prev = H.prevBlock (blockDataHeader b)+ go (pruneTx noTx b : acc) =<< getBlock prev++-- GET BlockHeight / BlockHeights / BlockHeightRaw --++scottyBlockHeight ::+ (MonadUnliftIO m, MonadLoggerIO m) => GetBlockHeight -> WebT m [BlockData]+scottyBlockHeight (GetBlockHeight h noTx) =+ scottyBlocks . (`GetBlocks` noTx) =<< getBlocksAtHeight (fromIntegral h)++scottyBlockHeights ::+ (MonadUnliftIO m, MonadLoggerIO m)+ => GetBlockHeights+ -> WebT m [BlockData]+scottyBlockHeights (GetBlockHeights (HeightsParam heights) noTx) = do+ bhs <- concat <$> mapM getBlocksAtHeight (fromIntegral <$> heights)+ scottyBlocks (GetBlocks bhs noTx)++scottyBlockHeightRaw ::+ (MonadUnliftIO m, MonadLoggerIO m)+ => GetBlockHeightRaw+ -> WebT m (RawResultList H.Block)+scottyBlockHeightRaw (GetBlockHeightRaw h) =+ RawResultList <$> (mapM getRawBlock =<< getBlocksAtHeight (fromIntegral h))++-- GET BlockTime / BlockTimeRaw --++scottyBlockTime ::+ (MonadUnliftIO m, MonadLoggerIO m) => GetBlockTime -> WebT m BlockData+scottyBlockTime (GetBlockTime (TimeParam t) (NoTx noTx)) =+ maybe (S.raise ThingNotFound) (return . pruneTx noTx) =<< blockAtOrBefore t++scottyBlockTimeRaw ::+ (MonadUnliftIO m, MonadLoggerIO m)+ => GetBlockTimeRaw+ -> WebT m (RawResult H.Block)+scottyBlockTimeRaw (GetBlockTimeRaw (TimeParam t)) = do+ b <- maybe (S.raise ThingNotFound) return =<< blockAtOrBefore t+ refuseLargeBlock b+ RawResult <$> toRawBlock b++-- GET Transactions --++scottyTx :: (MonadUnliftIO m, MonadLoggerIO m) => GetTx -> WebT m Transaction+scottyTx (GetTx txid) =+ maybe (S.raise ThingNotFound) return =<< getTransaction txid++scottyTxs ::+ (MonadUnliftIO m, MonadLoggerIO m) => GetTxs -> WebT m [Transaction]+scottyTxs (GetTxs txids) = catMaybes <$> mapM getTransaction (nub txids)++scottyTxRaw ::+ (MonadUnliftIO m, MonadLoggerIO m) => GetTxRaw -> WebT m (RawResult Tx)+scottyTxRaw (GetTxRaw txid) = do+ tx <- maybe (S.raise ThingNotFound) return =<< getTransaction txid+ return $ RawResult $ transactionData tx++scottyTxsRaw ::+ (MonadUnliftIO m, MonadLoggerIO m)+ => GetTxsRaw+ -> WebT m (RawResultList Tx)+scottyTxsRaw (GetTxsRaw txids) = do+ txs <- catMaybes <$> mapM getTransaction (nub txids)+ return $ RawResultList $ transactionData <$> txs++scottyTxsBlock ::+ (MonadUnliftIO m, MonadLoggerIO m) => GetTxsBlock -> WebT m [Transaction]+scottyTxsBlock (GetTxsBlock h) = do+ b <- maybe (S.raise ThingNotFound) return =<< getBlock h+ refuseLargeBlock b+ catMaybes <$> mapM getTransaction (blockDataTxs b)++scottyTxsBlockRaw ::+ (MonadUnliftIO m, MonadLoggerIO m)+ => GetTxsBlockRaw+ -> WebT m (RawResultList Tx)+scottyTxsBlockRaw (GetTxsBlockRaw h) =+ RawResultList . fmap transactionData <$> scottyTxsBlock (GetTxsBlock h)++-- GET TransactionAfterHeight --++scottyTxAfter ::+ (MonadUnliftIO m, MonadLoggerIO m)+ => GetTxAfter+ -> WebT m (GenericResult (Maybe Bool))+scottyTxAfter (GetTxAfter txid height) =+ GenericResult <$> cbAfterHeight (fromIntegral height) txid++-- | 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)+ => H.BlockHeight+ -> TxHash+ -> m (Maybe Bool)+cbAfterHeight height begin =+ go (10000 :: Int) [begin] -- Depth first search+ where+ go 0 _ = return Nothing -- We searched too far. Return Nothing.+ go _ [] = return $ Just False -- Nothing left to search.+ go i (txid:xs) =+ getTransaction txid >>= \case+ Nothing -> return Nothing -- Error. Bail out.+ Just tx+ | cbCheck tx -> return $ Just True -- Stop everything. Return.+ | heightCheck tx -> go i xs -- Continue search sideways+ | otherwise -> do+ let is = outPointHash . inputPoint <$> transactionInputs tx+ -- We have to search down and search sideways+ go (i - 1) is `returnOr` go i xs+ cbCheck tx =+ any isCoinbase (transactionInputs tx) &&+ blockRefHeight (transactionBlock tx) > height+ heightCheck tx =+ case transactionBlock tx of+ BlockRef thisHeight _ -> thisHeight <= height+ _ -> False+ returnOr a b =+ a >>= \case+ Just True -> return $ Just True -- Bubble up this result+ _ -> b++-- POST Transaction --++scottyPostTx :: (MonadUnliftIO m, MonadLoggerIO m) => PostTx -> WebT m TxId+scottyPostTx (PostTx tx) = do+ net <- lift $ asks (storeNetwork . webStore)+ pub <- lift $ asks (storePublisher . webStore)+ mgr <- lift $ asks (storeManager . webStore)+ lift (publishTx net pub mgr tx) >>= \case+ Right () -> return $ TxId (txHash tx)+ Left e@(PubReject _) -> S.raise $ UserError $ show e+ _ -> S.raise ServerError++-- | Publish a new transaction to the network.+publishTx ::+ (MonadUnliftIO m, StoreRead m)+ => Network+ -> Publisher StoreEvent+ -> PeerManager+ -> 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++-- GET Mempool / Events --++scottyMempool ::+ (MonadUnliftIO m, MonadLoggerIO m) => GetMempool -> WebT m [TxHash]+scottyMempool (GetMempool limitM (OffsetParam o)) = do+ wl <- lift $ asks webMaxLimits+ let l = validateLimit wl False limitM+ take (fromIntegral l) . drop (fromIntegral o) . map txRefHash <$> getMempool++scottyEvents :: MonadLoggerIO m => WebT m ()+scottyEvents = do+ setHeaders+ proto <- setupContentType False+ pub <- lift $ asks (storePublisher . webStore)+ S.stream $ \io flush' ->+ withSubscription pub $ \sub ->+ forever $+ flush' >> receiveEvent sub >>= maybe (return ()) (io . serial proto)+ where+ serial proto e =+ lazyByteString $ protoSerial proto toEncoding toJSON e <> newLine proto+ newLine SerialAsBinary = mempty+ newLine SerialAsJSON = "\n"+ newLine SerialAsPrettyJSON = mempty++receiveEvent :: Inbox StoreEvent -> IO (Maybe Event)+receiveEvent sub = do+ se <- receive sub+ return $+ case se of+ StoreBestBlock b -> Just (EventBlock b)+ StoreMempoolNew t -> Just (EventTx t)+ StoreTxDeleted t -> Just (EventTx t)+ StoreBlockReverted b -> Just (EventBlock b)+ _ -> Nothing++-- GET Address Transactions --++scottyAddrTxs ::+ (MonadUnliftIO m, MonadLoggerIO m) => GetAddrTxs -> WebT m [TxRef]+scottyAddrTxs (GetAddrTxs addr pLimits) =+ getAddressTxs addr =<< paramToLimits False pLimits++scottyAddrsTxs ::+ (MonadUnliftIO m, MonadLoggerIO m) => GetAddrsTxs -> WebT m [TxRef]+scottyAddrsTxs (GetAddrsTxs addrs pLimits) =+ getAddressesTxs addrs =<< paramToLimits False pLimits++scottyAddrTxsFull ::+ (MonadUnliftIO m, MonadLoggerIO m)+ => GetAddrTxsFull+ -> WebT m [Transaction]+scottyAddrTxsFull (GetAddrTxsFull addr pLimits) = do+ txs <- getAddressTxs addr =<< paramToLimits True pLimits+ catMaybes <$> mapM (getTransaction . txRefHash) txs++scottyAddrsTxsFull ::+ (MonadUnliftIO m, MonadLoggerIO m) => GetAddrsTxsFull -> WebT m [Transaction]+scottyAddrsTxsFull (GetAddrsTxsFull addrs pLimits) = do+ txs <- getAddressesTxs addrs =<< paramToLimits True pLimits+ catMaybes <$> mapM (getTransaction . txRefHash) txs++scottyAddrBalance ::+ (MonadUnliftIO m, MonadLoggerIO m) => GetAddrBalance -> WebT m Balance+scottyAddrBalance (GetAddrBalance addr) = getBalance addr++scottyAddrsBalance ::+ (MonadUnliftIO m, MonadLoggerIO m) => GetAddrsBalance -> WebT m [Balance]+scottyAddrsBalance (GetAddrsBalance addrs) = getBalances addrs++scottyAddrUnspent ::+ (MonadUnliftIO m, MonadLoggerIO m) => GetAddrUnspent -> WebT m [Unspent]+scottyAddrUnspent (GetAddrUnspent addr pLimits) =+ getAddressUnspents addr =<< paramToLimits False pLimits++scottyAddrsUnspent ::+ (MonadUnliftIO m, MonadLoggerIO m) => GetAddrsUnspent -> WebT m [Unspent]+scottyAddrsUnspent (GetAddrsUnspent addrs pLimits) =+ getAddressesUnspents addrs =<< paramToLimits False pLimits++-- GET XPubs --++scottyXPub ::+ (MonadUnliftIO m, MonadLoggerIO m) => GetXPub -> WebT m XPubSummary+scottyXPub (GetXPub xpub deriv (NoCache noCache)) =+ lift . runNoCache noCache $ xPubSummary $ XPubSpec xpub deriv++scottyXPubTxs ::+ (MonadUnliftIO m, MonadLoggerIO m) => GetXPubTxs -> WebT m [TxRef]+scottyXPubTxs (GetXPubTxs xpub deriv pLimits (NoCache noCache)) = do+ limits <- paramToLimits False pLimits+ lift . runNoCache noCache $ xPubTxs (XPubSpec xpub deriv) limits++scottyXPubTxsFull ::+ (MonadUnliftIO m, MonadLoggerIO m)+ => GetXPubTxsFull+ -> WebT m [Transaction]+scottyXPubTxsFull (GetXPubTxsFull xpub deriv pLimits n@(NoCache noCache)) = do+ refs <- scottyXPubTxs (GetXPubTxs xpub deriv pLimits n)+ txs <- lift . runNoCache noCache $ mapM (getTransaction . txRefHash) refs+ return $ catMaybes txs++scottyXPubBalances ::+ (MonadUnliftIO m, MonadLoggerIO m) => GetXPubBalances -> WebT m [XPubBal]+scottyXPubBalances (GetXPubBalances xpub deriv (NoCache noCache)) =+ filter f <$> lift (runNoCache noCache (xPubBals spec))+ where+ spec = XPubSpec xpub deriv+ f = not . nullBalance . xPubBal++scottyXPubUnspent ::+ (MonadUnliftIO m, MonadLoggerIO m)+ => GetXPubUnspent+ -> WebT m [XPubUnspent]+scottyXPubUnspent (GetXPubUnspent xpub deriv pLimits (NoCache noCache)) = do+ limits <- paramToLimits False pLimits+ lift . runNoCache noCache $ xPubUnspents (XPubSpec xpub deriv) limits++scottyXPubEvict ::+ (MonadUnliftIO m, MonadLoggerIO m)+ => GetXPubEvict+ -> WebT m (GenericResult Bool)+scottyXPubEvict (GetXPubEvict xpub deriv) = do+ cache <- lift $ asks (storeCache . webStore)+ lift . withCache cache $ evictFromCache [XPubSpec xpub deriv]+ return $ GenericResult True++-- GET Network Information --++scottyPeers :: MonadLoggerIO m => GetPeers -> WebT m [PeerInformation]+scottyPeers _ = getPeersInformation =<< lift (asks (storeManager . webStore))++-- | Obtain information about connected peers from peer manager process.+getPeersInformation :: MonadIO m => PeerManager -> 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 = show as+ , peerVersion = vs+ , peerServices = sv+ , peerRelay = rl+ }++scottyHealth ::+ (MonadUnliftIO m, MonadLoggerIO m) => GetHealth -> WebT m HealthCheck+scottyHealth _ = do+ net <- lift $ asks (storeNetwork . webStore)+ mgr <- lift $ asks (storeManager . webStore)+ chn <- lift $ asks (storeChain . webStore)+ tos <- lift $ asks webWebTimeouts+ h <- lift $ healthCheck net mgr chn tos+ when (not (healthOK h) || not (healthSynced h)) $ S.status status503+ return h++healthCheck ::+ (MonadUnliftIO m, StoreRead m)+ => Network+ -> PeerManager+ -> 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+ , healthVersion = showVersion P.version+ }+ where+ block_hash = H.headerHash . blockDataHeader+ block_height = blockDataHeight+ node_hash = H.headerHash . H.nodeHeader+ node_height = H.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 . H.blockTimestamp . H.nodeHeader+ in_sync bb cb = fromMaybe False $ do+ bh <- blockDataHeight <$> bb+ nh <- H.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 . txRefBlock <$> 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 10000000 (managerGetPeers mgr)+ block_best = runMaybeT $ do+ h <- MaybeT getBestBlock+ MaybeT $ getBlock h+ chain_best = timeout 10000000 $ chainGetBest ch+ compute_delta a b = if b > a then b - a else 0++scottyDbStats :: MonadLoggerIO m => WebT m ()+scottyDbStats = do+ setHeaders+ db <- lift $ asks (databaseHandle . storeDB . webStore)+ statsM <- lift (getProperty db Stats)+ S.text $ maybe "Could not get stats" cs statsM++-----------------------+-- Parameter Parsing --+-----------------------++-- | Returns @Nothing@ if the parameter is not supplied. Raises an exception on+-- parse failure.+paramOptional :: (Param a, Monad m) => WebT m (Maybe a)+paramOptional = go Proxy+ where+ go :: (Param a, Monad m) => Proxy a -> WebT m (Maybe a)+ go proxy = do+ net <- lift $ asks (storeNetwork . webStore)+ tsM :: Maybe [Text] <- p `S.rescue` const (return Nothing)+ case tsM of+ Nothing -> return Nothing -- Parameter was not supplied+ Just ts -> maybe (S.raise err) (return . Just) $ parseParam net ts+ where+ l = proxyLabel proxy+ p = Just <$> S.param (cs l)+ err = UserError $ "Unable to parse param " <> cs l++-- | Raises an exception if the parameter is not supplied+param :: (Param a, Monad m) => WebT m a+param = go Proxy+ where+ go :: (Param a, Monad m) => Proxy a -> WebT m a+ go proxy = do+ resM <- paramOptional+ case resM of+ Just res -> return res+ _ ->+ S.raise . UserError $+ "The param " <> cs (proxyLabel proxy) <> " was not defined"++-- | Returns the default value of a parameter if it is not supplied. Raises an+-- exception on parse failure.+paramDef :: (Default a, Param a, Monad m) => WebT m a+paramDef = fromMaybe def <$> paramOptional++-- | Does not raise exceptions. Will call @Scotty.next@ if the parameter is+-- not supplied or if parsing fails.+paramLazy :: (Param a, Monad m) => WebT m a+paramLazy = do+ resM <- paramOptional `S.rescue` const (return Nothing)+ maybe S.next return resM++parseBody :: (MonadIO m, Serialize a) => WebT m a+parseBody = do+ b <- S.body+ case hex b <|> bin (L.toStrict b) of+ Nothing -> S.raise $ UserError "Failed to parse request body"+ Just x -> return x+ where+ bin = eitherToMaybe . Serialize.decode+ hex = bin <=< decodeHex . cs . C.filter (not . isSpace)++parseOffset :: Monad m => WebT m OffsetParam+parseOffset = do+ res@(OffsetParam o) <- paramDef+ limits <- lift $ asks webMaxLimits+ when (maxLimitOffset limits > 0 && fromIntegral o > maxLimitOffset limits) $+ S.raise . UserError $+ "offset exceeded: " <> show o <> " > " <> show (maxLimitOffset limits)+ return res++parseStart ::+ (MonadUnliftIO m, MonadLoggerIO m)+ => Maybe StartParam+ -> WebT m (Maybe Start)+parseStart Nothing = return Nothing+parseStart (Just s) =+ runMaybeT $+ 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 $ AtBlock $ fromIntegral h+ start_block h = do+ b <- MaybeT $ getBlock (H.BlockHash h)+ return $ AtBlock (blockDataHeight b)+ start_tx h = do+ _ <- MaybeT $ getTxData (TxHash h)+ return $ AtTx (TxHash h)+ start_time q = do+ b <- MaybeT $ blockAtOrBefore q+ let g = blockDataHeight b+ return $ AtBlock g++parseLimits :: Monad m => WebT m LimitsParam+parseLimits = LimitsParam <$> paramOptional <*> parseOffset <*> paramOptional++paramToLimits ::+ (MonadUnliftIO m, MonadLoggerIO m)+ => Bool+ -> LimitsParam+ -> WebT m Limits+paramToLimits full (LimitsParam limitM o startM) = do+ wl <- lift $ asks webMaxLimits+ Limits (validateLimit wl full limitM) (fromIntegral o) <$> parseStart startM++validateLimit :: WebLimits -> Bool -> Maybe LimitParam -> Word32+validateLimit wl full limitM =+ f m $ maybe d (fromIntegral . getLimitParam) limitM+ where+ m | full && maxLimitFull wl > 0 = maxLimitFull wl+ | otherwise = maxLimitCount wl+ d = maxLimitDefault wl+ f a 0 = a+ f 0 b = b+ f a b = min a b++---------------+-- Utilities --+---------------++runInWebReader ::+ MonadIO m+ => CacheT (DatabaseReaderT m) a+ -> ReaderT WebConfig m a+runInWebReader f = do+ bdb <- asks (storeDB . webStore)+ mc <- asks (storeCache . webStore)+ lift $ withDatabaseReader bdb (withCache mc f)++runNoCache :: MonadIO m => Bool -> ReaderT WebConfig m a -> ReaderT WebConfig m a+runNoCache False f = f+runNoCache True f =+ local (\s -> s {webStore = (webStore s) {storeCache = Nothing}}) f++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)+