diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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 diff --git a/haskoin-store.cabal b/haskoin-store.cabal --- a/haskoin-store.cabal +++ b/haskoin-store.cabal @@ -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 diff --git a/src/Haskoin/Store/BlockStore.hs b/src/Haskoin/Store/BlockStore.hs --- a/src/Haskoin/Store/BlockStore.hs +++ b/src/Haskoin/Store/BlockStore.hs @@ -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 diff --git a/src/Haskoin/Store/Cache.hs b/src/Haskoin/Store/Cache.hs --- a/src/Haskoin/Store/Cache.hs +++ b/src/Haskoin/Store/Cache.hs @@ -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} diff --git a/src/Haskoin/Store/Common.hs b/src/Haskoin/Store/Common.hs --- a/src/Haskoin/Store/Common.hs +++ b/src/Haskoin/Store/Common.hs @@ -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 diff --git a/src/Haskoin/Store/Database/Memory.hs b/src/Haskoin/Store/Database/Memory.hs deleted file mode 100644 --- a/src/Haskoin/Store/Database/Memory.hs +++ /dev/null @@ -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) diff --git a/src/Haskoin/Store/Database/Reader.hs b/src/Haskoin/Store/Database/Reader.hs --- a/src/Haskoin/Store/Database/Reader.hs +++ b/src/Haskoin/Store/Database/Reader.hs @@ -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} = diff --git a/src/Haskoin/Store/Database/Types.hs b/src/Haskoin/Store/Database/Types.hs --- a/src/Haskoin/Store/Database/Types.hs +++ b/src/Haskoin/Store/Database/Types.hs @@ -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 diff --git a/src/Haskoin/Store/Database/Writer.hs b/src/Haskoin/Store/Database/Writer.hs --- a/src/Haskoin/Store/Database/Writer.hs +++ b/src/Haskoin/Store/Database/Writer.hs @@ -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) + } diff --git a/src/Haskoin/Store/Logic.hs b/src/Haskoin/Store/Logic.hs --- a/src/Haskoin/Store/Logic.hs +++ b/src/Haskoin/Store/Logic.hs @@ -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)) diff --git a/src/Haskoin/Store/Web.hs b/src/Haskoin/Store/Web.hs --- a/src/Haskoin/Store/Web.hs +++ b/src/Haskoin/Store/Web.hs @@ -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) +