diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,32 @@ The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.html). +## 0.3.0 +### Added +- Update dependencies. +- Keep orphan blocks and deleted transactions in database. +- Add a `mainchain` field for block data and a `deleted` field for transactions. +- Stream records for performance. +- Show witness data for transaction inputs in SegWit network. +- Support RBF in SegWit network. + +### Changed +- Refactor all data access code away from actor. +- Refactor import logic away from actor. +- Abstract data access using typeclasses. +- Implement data access using clean layered architecture. +- Make most of import logic code pure. +- Database now in `db` as opposed to `blocks` directory. +- Use latest `haskoin-node`. + +### Removed +- Remove some data from peer information output. +- Remove full transaction from address transaction data. +- Remove limits from address transaction data. +- Remove block data from previous output. +- Remove spender from JSON response when output not spent. +- Remove block hash from block reference. + ## 0.2.3 ### Removed - Do not send transaction notifications if a block is being imported. diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -7,43 +7,37 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} import Conduit import Control.Arrow -import Control.Exception +import Control.Exception () import Control.Monad import Control.Monad.Logger -import Data.Aeson (ToJSON (..), Value (..), encode, - object, (.=)) +import Control.Monad.Trans.Maybe +import Data.Aeson as A import Data.Bits -import Data.ByteString.Builder (lazyByteString) +import Data.ByteString.Builder +import qualified Data.ByteString.Lazy.Char8 as C +import Data.Char +import Data.Foldable +import Data.Function import Data.List import Data.Maybe +import Data.Serialize as Serialize import Data.String.Conversions -import qualified Data.Text as T import Data.Version -import Database.RocksDB hiding (get) +import Database.RocksDB as R import Haskoin import Haskoin.Node import Haskoin.Store import Network.HTTP.Types import NQE import Options.Applicative -import Paths_haskoin_store as P +import Paths_haskoin_store as P import System.Directory import System.Exit import System.FilePath import System.IO.Unsafe -import Text.Read (readMaybe) +import Text.Read (readMaybe) import UnliftIO -import Web.Scotty.Trans - -data OptConfig = OptConfig - { optConfigDir :: !(Maybe FilePath) - , optConfigPort :: !(Maybe Int) - , optConfigNetwork :: !(Maybe Network) - , optConfigDiscover :: !(Maybe Bool) - , optConfigPeers :: !(Maybe [(Host, Maybe Port)]) - , optConfigMaxReqs :: !(Maybe Int) - , optConfigVersion :: !Bool - } +import Web.Scotty.Trans as S data Config = Config { configDir :: !FilePath @@ -51,41 +45,15 @@ , configNetwork :: !Network , configDiscover :: !Bool , configPeers :: ![(Host, Maybe Port)] - , configMaxReqs :: !Int + , configVersion :: !Bool } -maxUriArgs :: Int -maxUriArgs = 500 - -maxPubSubQueue :: Int -maxPubSubQueue = 10000 - -defMaxReqs :: Int -defMaxReqs = 10000 - defPort :: Int defPort = 3000 defNetwork :: Network defNetwork = btc -defDiscovery :: Bool -defDiscovery = False - -defPeers :: [(Host, Maybe Port)] -defPeers = [] - -optToConfig :: OptConfig -> Config -optToConfig OptConfig {..} = - Config - { configDir = fromMaybe myDirectory optConfigDir - , configPort = fromMaybe defPort optConfigPort - , configNetwork = fromMaybe defNetwork optConfigNetwork - , configDiscover = fromMaybe defDiscovery optConfigDiscover - , configPeers = fromMaybe defPeers optConfigPeers - , configMaxReqs = fromMaybe defMaxReqs optConfigMaxReqs - } - instance Parsable BlockHash where parseParam = maybe (Left "could not decode block hash") Right . hexToBlockHash . cs @@ -99,7 +67,6 @@ | ServerError | BadRequest | UserError String - | OutOfBounds | StringError String deriving (Show, Eq) @@ -113,7 +80,6 @@ toJSON ThingNotFound = object ["error" .= String "not found"] toJSON BadRequest = object ["error" .= String "bad request"] toJSON ServerError = object ["error" .= String "you made me kill a unicorn"] - toJSON OutOfBounds = object ["error" .= String "too many elements requested"] toJSON (StringError _) = object ["error" .= String "you made me kill a unicorn"] toJSON (UserError s) = object ["error" .= s] @@ -129,37 +95,36 @@ object ["type" .= String "block", "id" .= block_hash] netNames :: String -netNames = intercalate "|" $ map getNetworkName allNets +netNames = intercalate "|" (map getNetworkName allNets) -config :: Parser OptConfig +config :: Parser Config config = do - optConfigDir <- - optional . option str $ - metavar "DIR" <> long "dir" <> short 'd' <> - help ("Data directory (default: " <> myDirectory <> ")") - optConfigPort <- - optional . option auto $ - metavar "PORT" <> long "port" <> short 'p' <> - help ("Port to listen (default: " <> show defPort <> ")") - optConfigNetwork <- - optional . option (eitherReader networkReader) $ - metavar "NETWORK" <> long "network" <> short 'n' <> - help ("Network: " <> netNames <> " (default: " <> net <> ")") - optConfigDiscover <- - optional . switch $ long "discover" <> help "Enable peer discovery" - optConfigPeers <- - optional . option (eitherReader peerReader) $ - metavar "PEERS" <> long "peers" <> - help "Network peers (i.e. localhost,peer.example.com:8333)" - optConfigMaxReqs <- - optional . option auto $ - metavar "MAXREQ" <> long "maxreq" <> - help ("Maximum returned entries (default:" <> show defMaxReqs <> ")") - optConfigVersion <- + configDir <- + option str $ + metavar "DIR" <> long "dir" <> short 'd' <> help "Data directory" <> + showDefault <> + value myDirectory + configPort <- + option auto $ + metavar "INT" <> long "listen" <> short 'l' <> help "Listening port" <> + showDefault <> + value defPort + 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" + 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" - return OptConfig {..} - where - net = getNetworkName defNetwork + return Config {..} networkReader :: String -> Either String Network networkReader s @@ -171,34 +136,30 @@ | s == getNetworkName bchRegTest = Right bchRegTest | otherwise = Left "Network name invalid" -peerReader :: String -> Either String [(Host, Maybe Port)] -peerReader = mapM hp . ls - where - hp s = do - let (host, p) = span (/= ':') s - when (null host) (Left "Peer name or address not defined") - port <- - case p of - [] -> return Nothing - ':':p' -> - case readMaybe p' of - Nothing -> Left "Peer port number cannot be read" - Just n -> return (Just n) - _ -> Left "Peer information could not be parsed" - return (host, port) - ls = map T.unpack . T.split (== ',') . T.pack +peerReader :: String -> Either String (Host, Maybe Port) +peerReader s = do + let (host, p) = span (/= ':') s + when (null host) (Left "Peer name or address not defined") + port <- + case p of + [] -> return Nothing + ':':p' -> + case readMaybe p' of + Nothing -> Left "Peer port number cannot be read" + Just n -> return (Just n) + _ -> Left "Peer information could not be parsed" + return (host, port) defHandler :: Monad m => Except -> ActionT Except m () -defHandler ServerError = json ServerError -defHandler OutOfBounds = status status413 >> json OutOfBounds -defHandler ThingNotFound = status status404 >> json ThingNotFound -defHandler BadRequest = status status400 >> json BadRequest -defHandler (UserError s) = status status400 >> json (UserError s) -defHandler e = status status400 >> json e +defHandler ServerError = S.json ServerError +defHandler ThingNotFound = status status404 >> S.json ThingNotFound +defHandler BadRequest = status status400 >> S.json BadRequest +defHandler (UserError s) = status status400 >> S.json (UserError s) +defHandler e = status status400 >> S.json e maybeJSON :: (Monad m, ToJSON a) => Maybe a -> ActionT Except m () maybeJSON Nothing = raise ThingNotFound -maybeJSON (Just x) = json x +maybeJSON (Just x) = S.json x myDirectory :: FilePath myDirectory = unsafePerformIO $ getAppUserDataDirectory "haskoin-store" @@ -207,141 +168,237 @@ main :: IO () main = runStderrLoggingT $ do - opt <- liftIO (execParser opts) - when (optConfigVersion opt) . liftIO $ do + conf <- liftIO (execParser opts) + when (configVersion conf) . liftIO $ do putStrLn $ showVersion P.version exitSuccess - let conf = optToConfig opt when (null (configPeers conf) && not (configDiscover conf)) . liftIO $ - die "Specify: --discover | --peers PEER,..." + die "ERROR: Specify peers to connect or enable peer discovery." let net = configNetwork conf let wdir = configDir conf getNetworkName net liftIO $ createDirectoryIfMissing True wdir db <- open - (wdir "blocks") - defaultOptions + (wdir "db") + R.defaultOptions { createIfMissing = True , compression = SnappyCompression , maxOpenFiles = -1 , writeBufferSize = 2 `shift` 30 } - runStore conf db $ \st -> runWeb conf st db + withPublisher $ \pub -> + withStore (scfg conf db pub) $ \st -> runWeb conf st db pub where + scfg conf db pub = + StoreConfig + { storeConfMaxPeers = 20 + , storeConfInitPeers = + map + (second (fromMaybe (getDefaultPort (configNetwork conf)))) + (configPeers conf) + , storeConfDiscover = configDiscover conf + , storeConfDB = db + , storeConfNetwork = configNetwork conf + , storeConfListen = (`sendSTM` pub) . Event + } opts = info (helper <*> config) $ fullDesc <> progDesc "Blockchain store and API" <> Options.Applicative.header ("haskoin-store version " <> showVersion P.version) -testLength :: Monad m => Int -> ActionT Except m () -testLength l = when (l <= 0 || l > maxUriArgs) (raise OutOfBounds) - runWeb :: (MonadUnliftIO m, MonadLoggerIO m) => Config -> Store -> DB + -> Publisher StoreEvent -> m () -runWeb conf st db = do +runWeb conf st db pub = do l <- askLoggerIO scottyT (configPort conf) (runner l) $ do defaultHandler defHandler - get "/block/best" $ do - res <- withSnapshot db $ getBestBlock db - json res - get "/block/:block" $ do + S.get "/block/best" $ do + res <- + withSnapshot db $ \s -> + runMaybeT $ do + let d = (db, defaultReadOptions {useSnapshot = Just s}) + bh <- MaybeT $ getBestBlock d + MaybeT $ getBlock d bh + maybeJSON res + S.get "/block/:block" $ do block <- param "block" - res <- withSnapshot db $ getBlock block db + res <- + withSnapshot db $ \s -> do + let d = (db, defaultReadOptions {useSnapshot = Just s}) + getBlock d block maybeJSON res - get "/block/height/:height" $ do + S.get "/block/height/:height" $ do height <- param "height" - res <- withSnapshot db $ getBlockAtHeight height db - maybeJSON res - get "/block/heights" $ do + res <- + withSnapshot db $ \s -> do + let d = (db, defaultReadOptions {useSnapshot = Just s}) + getBlocksAtHeight d height + S.json res + S.get "/block/heights" $ do heights <- param "heights" - testLength (length (heights :: [BlockHeight])) res <- - withSnapshot db $ \s -> - mapM (\h -> getBlockAtHeight h db s) heights - json res - get "/blocks" $ do + withSnapshot db $ \s -> do + let d = (db, defaultReadOptions {useSnapshot = Just s}) + mapM (getBlocksAtHeight d) (nub heights) + S.json res + S.get "/blocks" $ do blocks <- param "blocks" - testLength (length blocks) - res <- withSnapshot db $ getBlocks blocks db - json res - get "/mempool" $ do - res <- withSnapshot db $ getMempool db - json res - get "/transaction/:txid" $ do + res <- + withSnapshot db $ \s -> do + let d = (db, defaultReadOptions {useSnapshot = Just s}) + mapM (getBlock d) (blocks :: [BlockHash]) + S.json res + S.get "/mempool" $ do + setHeader "Content-Type" "application/json" + stream $ \io flush' -> + withSnapshot db $ \s -> + runResourceT . runConduit $ + getMempool (db, defaultReadOptions {useSnapshot = Just s}) .| + mapC snd .| + jsonListConduit toEncoding .| + streamConduit io >> + liftIO flush' + S.get "/transaction/:txid" $ do txid <- param "txid" - res <- withSnapshot db $ getTx net txid db - maybeJSON res - get "/transactions" $ do + res <- + withSnapshot db $ \s -> do + let d = (db, defaultReadOptions {useSnapshot = Just s}) + getTransaction d txid + let f = transactionToJSON net + maybeJSON $ fmap f res + S.get "/transaction/:txid/hex" $ do + txid <- param "txid" + res <- + withSnapshot db $ \s -> do + let d = (db, defaultReadOptions {useSnapshot = Just s}) + getTransaction d txid + case res of + Nothing -> raise ThingNotFound + Just x -> + text . cs . encodeHex $ Serialize.encode (transactionData x) + S.get "/transactions" $ do txids <- param "txids" - testLength (length (txids :: [TxHash])) - res <- withSnapshot db $ \s -> mapM (\t -> getTx net t db s) txids - json res - get "/address/:address/transactions" $ do + res <- + withSnapshot db $ \s -> do + let d = (db, defaultReadOptions {useSnapshot = Just s}) + catMaybes <$> mapM (getTransaction d) (nub txids) + S.json $ map (transactionToJSON net) res + S.get "/transactions/hex" $ do + txids <- param "txids" + res <- + withSnapshot db $ \s -> do + let d = (db, defaultReadOptions {useSnapshot = Just s}) + catMaybes <$> mapM (getTransaction d) (nub txids) + S.json $ map (encodeHex . Serialize.encode . transactionData) res + S.get "/address/:address/transactions" $ do address <- parse_address - height <- parse_height - x <- parse_max - res <- withSnapshot db $ \s -> addrTxsMax net db s x height address - json res - get "/address/transactions" $ do + setHeader "Content-Type" "application/json" + stream $ \io flush' -> + withSnapshot db $ \s -> + runResourceT . runConduit $ + getAddressTxs + (db, defaultReadOptions {useSnapshot = Just s}) + address .| + jsonListConduit (addressTxToEncoding net) .| + streamConduit io >> + liftIO flush' + S.get "/address/transactions" $ do addresses <- parse_addresses - height <- parse_height - x <- parse_max - res <- - withSnapshot db $ \s -> addrsTxsMax net db s x height addresses - json res - get "/address/:address/unspent" $ do + setHeader "Content-Type" "application/json" + stream $ \io flush' -> + withSnapshot db $ \s -> + runResourceT . runConduit $ + mergeSourcesBy + (compare `on` addressTxBlock) + (map (getAddressTxs + ( db + , defaultReadOptions {useSnapshot = Just s})) + addresses) .| + jsonListConduit (addressTxToEncoding net) .| + streamConduit io >> + liftIO flush' + S.get "/address/:address/unspent" $ do address <- parse_address - height <- parse_height - x <- parse_max - res <- withSnapshot db $ \s -> addrUnspentMax db s x height address - json res - get "/address/unspent" $ do + setHeader "Content-Type" "application/json" + stream $ \io flush' -> + withSnapshot db $ \s -> + runResourceT . runConduit $ + getAddressUnspents + (db, defaultReadOptions {useSnapshot = Just s}) + address .| + jsonListConduit (unspentToEncoding net) .| + streamConduit io >> + liftIO flush' + S.get "/address/unspent" $ do addresses <- parse_addresses - height <- parse_height - x <- parse_max - res <- - withSnapshot db $ \s -> addrsUnspentMax db s x height addresses - json res - get "/address/:address/balance" $ do + setHeader "Content-Type" "application/json" + stream $ \io flush' -> + withSnapshot db $ \s -> + runResourceT . runConduit $ + mergeSourcesBy + (compare `on` unspentBlock) + (map (getAddressUnspents + ( db + , defaultReadOptions {useSnapshot = Just s})) + addresses) .| + jsonListConduit (unspentToEncoding net) .| + streamConduit io >> + liftIO flush' + S.get "/address/:address/balance" $ do address <- parse_address - res <- withSnapshot db $ getBalance address db - json res - get "/address/balances" $ do + res <- + withSnapshot db $ \s -> do + let d = (db, defaultReadOptions {useSnapshot = Just s}) + getBalance d address + S.json $ balanceToJSON net res + S.get "/address/balances" $ do addresses <- parse_addresses res <- - withSnapshot db $ \s -> mapM (\a -> getBalance a db s) addresses - json res - post "/transactions" $ do - NewTx tx <- jsonData - lift (publishTx net st db tx) >>= \case - Left PublishTimeout -> do - status status500 - json (UserError (show PublishTimeout)) - Left e -> do - status status400 - json (UserError (show e)) - Right j -> json j - get "/dbstats" $ getProperty db Stats >>= text . cs . fromJust - get "/events" $ do + withSnapshot db $ \s -> do + let d = (db, defaultReadOptions {useSnapshot = Just s}) + mapM (getBalance d) addresses + S.json $ map (balanceToJSON net) res + S.post "/transactions" $ do + hex_tx <- C.filter (not . isSpace) <$> body + bin_tx <- + case decodeHex (cs hex_tx) of + Nothing -> do + status status400 + S.json (UserError "decode hex fail") + finish + Just x -> return x + tx <- + case Serialize.decode bin_tx of + Left _ -> do + status status400 + S.json (UserError "decode tx within hex fail") + finish + Right x -> return x + lift (publishTx (storeManager st) tx) >>= \case + True -> S.json $ object ["sent" .= True] + False -> S.json $ object ["sent" .= False] + S.get "/dbstats" $ getProperty db Stats >>= text . cs . fromJust + S.get "/events" $ do setHeader "Content-Type" "application/x-json-stream" - stream $ \io flush -> - withPubSub (storePublisher st) (newTBQueueIO maxPubSubQueue) $ \sub -> + stream $ \io flush' -> + withSubscription pub $ \sub -> forever $ - flush >> receive sub >>= \case - BestBlock block_hash -> do - let bs = encode (JsonEventBlock block_hash) <> "\n" + flush' >> receive sub >>= \case + StoreBestBlock block_hash -> do + let bs = + A.encode (JsonEventBlock block_hash) <> "\n" io (lazyByteString bs) - MempoolNew tx_hash -> do - let bs = encode (JsonEventTx tx_hash) <> "\n" + StoreMempoolNew tx_hash -> do + let bs = A.encode (JsonEventTx tx_hash) <> "\n" io (lazyByteString bs) _ -> return () - get "/peers" $ getPeersInformation (storeManager st) >>= json + S.get "/peers" $ getPeersInformation (storeManager st) >>= S.json notFound $ raise ThingNotFound where parse_address = do @@ -352,96 +409,39 @@ parse_addresses = do addresses <- param "addresses" let as = mapMaybe (stringToAddr net) addresses - if length as == length addresses - then testLength (length as) >> return as - else next - parse_max = do - x <- param "max" `rescue` const (return (configMaxReqs conf)) - when (x < 1 || x > configMaxReqs conf) (raise OutOfBounds) - return x - parse_height = (Just <$> param "height") `rescue` const (return Nothing) + unless (length as == length addresses) next + return as net = configNetwork conf runner f l = do u <- askUnliftIO unliftIO u (runLoggingT l f) -runStore :: - (MonadLoggerIO m, MonadUnliftIO m) - => Config - -> DB - -> (Store -> m a) - -> m a -runStore conf db f = do - let net = configNetwork conf - cfg = - StoreConfig - { storeConfMaxPeers = 20 - , storeConfInitPeers = - map - (second (fromMaybe (getDefaultPort net))) - (configPeers conf) - , storeConfDiscover = configDiscover conf - , storeConfDB = db - , storeConfNetwork = net - } - withStore cfg f - -addrTxsMax :: - MonadUnliftIO m - => Network - -> DB - -> Snapshot - -> Int - -> Maybe BlockHeight - -> Address - -> m [DetailedTx] -addrTxsMax net db s c h a = concat <$> addrsTxsMax net db s c h [a] - -addrsTxsMax :: - MonadUnliftIO m - => Network - -> DB - -> Snapshot - -> Int - -> Maybe BlockHeight - -> [Address] - -> m [[DetailedTx]] -addrsTxsMax net db s c h addrs - | c <= 0 = return [] - | otherwise = - case addrs of - [] -> return [] - (a:as) -> do - ts <- - runResourceT . runConduit $ - getAddrTxs net a h db s .| takeC c .| sinkList - mappend [ts] <$> addrsTxsMax net db s (c - length ts) h as +-- Snatched from: +-- https://github.com/cblp/conduit-merge/blob/master/src/Data/Conduit/Merge.hs +mergeSourcesBy :: + (Foldable f, Monad m) + => (a -> a -> Ordering) + -> f (ConduitT () a m ()) + -> ConduitT i a m () +mergeSourcesBy f = mergeSealed . fmap sealConduitT . toList + where + mergeSealed sources = do + prefetchedSources <- lift $ traverse ($$++ await) sources + go [(a, s) | (s, Just a) <- prefetchedSources] + go [] = pure () + go sources = do + let (a, src1):sources1 = sortBy (f `on` fst) sources + yield a + (src2, mb) <- lift $ src1 $$++ await + let sources2 = + case mb of + Nothing -> sources1 + Just b -> (b, src2) : sources1 + go sources2 -addrUnspentMax :: - MonadUnliftIO m - => DB - -> Snapshot - -> Int - -> Maybe BlockHeight - -> Address - -> m [AddrOutput] -addrUnspentMax db s c h a = concat <$> addrsUnspentMax db s c h [a] +jsonListConduit :: Monad m => (a -> Encoding) -> ConduitT a Builder m () +jsonListConduit f = + yield "[" >> mapC (fromEncoding . f) .| intersperseC "," >> yield "]" -addrsUnspentMax :: - MonadUnliftIO m - => DB - -> Snapshot - -> Int - -> Maybe BlockHeight - -> [Address] - -> m [[AddrOutput]] -addrsUnspentMax db s c h addrs - | c <= 0 = return [] - | otherwise = - case addrs of - [] -> return [] - (a:as) -> do - os <- - runResourceT . runConduit $ - getUnspent a h db s .| takeC c .| sinkList - mappend [os] <$> addrsUnspentMax db s (c - length os) h as +streamConduit :: MonadIO m => (i -> IO ()) -> ConduitT i o m () +streamConduit io = mapM_C (liftIO . io) diff --git a/haskoin-store.cabal b/haskoin-store.cabal --- a/haskoin-store.cabal +++ b/haskoin-store.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: b699d7a2ed5b2ee3d05c7af8cdde725e59d289f9f99dfdce6a897a9b7fca1d38 +-- hash: 340a53a68d9dccc28ec8cb71b8c6663a14515304a250c6afd689cedaab696996 name: haskoin-store -version: 0.2.3 +version: 0.3.0 synopsis: Storage and index for Bitcoin and Bitcoin Cash description: Store blocks, transactions, and balances for Bitcoin or Bitcoin Cash, and make that information via REST API. category: Bitcoin, Finance, Network @@ -30,17 +30,25 @@ Haskoin.Store other-modules: Network.Haskoin.Store.Block - Network.Haskoin.Store.Types + Network.Haskoin.Store.Data + Network.Haskoin.Store.Data.HashMap + Network.Haskoin.Store.Data.ImportDB + Network.Haskoin.Store.Data.KeyValue + Network.Haskoin.Store.Data.RocksDB + Network.Haskoin.Store.Logic + Network.Haskoin.Store.Messages Paths_haskoin_store hs-source-dirs: src build-depends: aeson - , base >=4.7 && <5 + , base >=4.9 && <5 , bytestring , cereal , conduit , containers + , data-default + , hashable , haskoin-core , haskoin-node , monad-logger @@ -55,6 +63,7 @@ , time , transformers , unliftio + , unordered-containers default-language: Haskell2010 executable haskoin-store @@ -66,9 +75,12 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: aeson - , base >=4.7 && <5 + , base >=4.9 && <5 + , binary , bytestring + , cereal , conduit + , data-default , directory , filepath , haskoin-core @@ -82,7 +94,9 @@ , scotty , string-conversions , text + , transformers , unliftio + , unordered-containers default-language: Haskell2010 test-suite haskoin-store-test @@ -94,7 +108,8 @@ test ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: - base >=4.7 && <5 + base >=4.9 && <5 + , data-default , haskoin-core , haskoin-node , haskoin-store @@ -103,5 +118,7 @@ , mtl , nqe , rocksdb-haskell + , transformers , unliftio + , unordered-containers default-language: Haskell2010 diff --git a/src/Haskoin/Store.hs b/src/Haskoin/Store.hs --- a/src/Haskoin/Store.hs +++ b/src/Haskoin/Store.hs @@ -3,280 +3,181 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} module Haskoin.Store ( Store(..) , BlockStore + , StoreConfig(..) + , StoreEvent(..) + , BlockData(..) + , Transaction(..) + , Input(..) , Output(..) , Spender(..) , BlockRef(..) - , StoreConfig(..) - , StoreEvent(..) - , BlockValue(..) - , DetailedTx(..) - , DetailedInput(..) - , DetailedOutput(..) - , NewTx(..) - , AddrOutput(..) - , AddressBalance(..) - , TxException(..) + , Unspent(..) + , AddressTx(..) + , Balance(..) , PeerInformation(..) , withStore + , store , getBestBlock - , getBlockAtHeight + , getBlocksAtHeight , getBlock - , getBlocks - , getTx - , getAddrTxs - , getUnspent + , getTransaction , getBalance , getMempool + , getAddressUnspents + , getAddressTxs , getPeersInformation , publishTx + , transactionData + , isCoinbase + , confirmed + , transactionToJSON + , transactionToEncoding + , outputToJSON + , outputToEncoding + , inputToJSON + , inputToEncoding + , unspentToJSON + , unspentToEncoding + , balanceToJSON + , balanceToEncoding + , addressTxToJSON + , addressTxToEncoding ) where import Control.Monad.Except import Control.Monad.Logger -import Control.Monad.Reader -import Control.Monad.Trans.Maybe -import Data.Serialize -import Data.String -import Data.String.Conversions -import Database.RocksDB +import Data.Maybe +import Haskoin import Haskoin.Node -import Network.Haskoin.Block -import Network.Haskoin.Constants -import Network.Haskoin.Network import Network.Haskoin.Store.Block -import Network.Haskoin.Store.Types -import Network.Haskoin.Transaction -import Network.Socket (SockAddr (..)) +import Network.Haskoin.Store.Data +import Network.Haskoin.Store.Messages +import Network.Socket (SockAddr (..)) import NQE -import System.Random import UnliftIO --- | Context for the store. -type MonadStore m = (MonadLoggerIO m, MonadReader StoreRead m) - --- | Running store state. -data StoreRead = StoreRead - { myMailbox :: !(Inbox NodeEvent) - , myBlockStore :: !BlockStore - , myChain :: !Chain - , myManager :: !Manager - , myListener :: !(Listen StoreEvent) - , myPublisher :: !(Publisher StoreEvent) - , myBlockDB :: !DB - , myNetwork :: !Network - } - --- | Run a Haskoin Store instance. It will launch a network node, a --- 'BlockStore', connect to the network and start synchronizing blocks and --- transactions. withStore :: (MonadLoggerIO m, MonadUnliftIO m) => StoreConfig -> (Store -> m a) -> m a -withStore StoreConfig {..} f = do - sm <- newInbox =<< newTQueueIO - withNode (node_cfg sm) $ \(mg, ch) -> do - ls <- newInbox =<< newTQueueIO - bs <- newInbox =<< newTQueueIO - pb <- newInbox =<< newTQueueIO - let store_read = - StoreRead - { myMailbox = sm - , myBlockStore = bs - , myChain = ch - , myManager = mg - , myPublisher = pb - , myListener = (`sendSTM` ls) - , myBlockDB = storeConfDB - , myNetwork = storeConfNetwork - } - let block_cfg = +withStore cfg f = do + mgri <- newInbox + chi <- newInbox + withProcess (store cfg mgri chi) $ \(Process a b) -> do + link a + f + Store + { storeManager = inboxToMailbox mgri + , storeChain = inboxToMailbox chi + , storeBlock = b + } + +-- | Run a Haskoin Store instance. It will launch a network node and a +-- 'BlockStore', connect to the network and start synchronizing blocks and +-- transactions. +store :: + (MonadLoggerIO m, MonadUnliftIO m) + => StoreConfig + -> Inbox ManagerMessage + -> Inbox ChainMessage + -> Inbox BlockMessage + -> m () +store cfg mgri chi bsi = do + let ncfg = + NodeConfig + { nodeConfMaxPeers = storeConfMaxPeers cfg + , nodeConfDB = storeConfDB cfg + , nodeConfPeers = storeConfInitPeers cfg + , nodeConfDiscover = storeConfDiscover cfg + , nodeConfEvents = storeDispatch b l + , nodeConfNetAddr = NetworkAddress 0 (SockAddrInet 0 0) + , nodeConfNet = storeConfNetwork cfg + , nodeConfTimeout = 10 + } + withAsync (node ncfg mgri chi) $ \a -> do + link a + let bcfg = BlockConfig - { blockConfMailbox = bs - , blockConfChain = ch - , blockConfManager = mg - , blockConfListener = (`sendSTM` ls) - , blockConfDB = storeConfDB - , blockConfNet = storeConfNetwork + { blockConfChain = inboxToMailbox chi + , blockConfManager = inboxToMailbox mgri + , blockConfListener = l + , blockConfDB = storeConfDB cfg + , blockConfNet = storeConfNetwork cfg } - withAsync (runReaderT run store_read) $ \st -> - withAsync (blockStore block_cfg) $ \bt -> - withAsync (publisher pb (receiveSTM ls)) $ \pu -> do - link st - link bt - link pu - f (Store mg ch bs pb) + blockStore bcfg bsi where - run = - forever $ do - sm <- asks myMailbox - storeDispatch =<< receive sm - node_cfg sm = - NodeConfig - { maxPeers = storeConfMaxPeers - , database = storeConfDB - , initPeers = storeConfInitPeers - , discover = storeConfDiscover - , nodeEvents = (`sendSTM` sm) - , netAddress = NetworkAddress 0 (SockAddrInet 0 0) - , nodeNet = storeConfNetwork - } + l = storeConfListen cfg + b = inboxToMailbox bsi -- | Dispatcher of node events. -storeDispatch :: MonadStore m => NodeEvent -> m () - -storeDispatch (ManagerEvent (ManagerConnect p)) = do - b <- asks myBlockStore - l <- asks myListener - atomically (l (PeerConnected p)) - BlockPeerConnect p `send` b +storeDispatch :: BlockStore -> Listen StoreEvent -> Listen NodeEvent -storeDispatch (ManagerEvent (ManagerDisconnect p)) = do - b <- asks myBlockStore - l <- asks myListener - atomically (l (PeerDisconnected p)) - BlockPeerDisconnect p `send` b +storeDispatch b pub (PeerEvent (PeerConnected p a)) = do + pub (StorePeerConnected p a) + BlockPeerConnect p a `sendSTM` b -storeDispatch (ChainEvent (ChainNewBest bn)) = do - b <- asks myBlockStore - BlockChainNew bn `send` b +storeDispatch b pub (PeerEvent (PeerDisconnected p a)) = do + pub (StorePeerDisconnected p a) + BlockPeerDisconnect p a `sendSTM` b -storeDispatch (ChainEvent _) = return () +storeDispatch b _ (ChainEvent (ChainBestBlock bn)) = + BlockNewBest bn `sendSTM` b -storeDispatch (PeerEvent (p, GotBlock block)) = do - b <- asks myBlockStore - BlockReceived p block `send` b +storeDispatch _ _ (ChainEvent _) = return () -storeDispatch (PeerEvent (p, BlockNotFound hash)) = do - b <- asks myBlockStore - BlockNotReceived p hash `send` b +storeDispatch _ pub (PeerEvent (PeerMessage p (MPong (Pong n)))) = + pub (StorePeerPong p n) -storeDispatch (PeerEvent (p, TxAvail ts)) = do - b <- asks myBlockStore - TxAvailable p ts `send` b +storeDispatch b _ (PeerEvent (PeerMessage p (MBlock block))) = + BlockReceived p block `sendSTM` b -storeDispatch (PeerEvent (p, GotTx tx)) = do - b <- asks myBlockStore - TxReceived p tx `send` b +storeDispatch b _ (PeerEvent (PeerMessage p (MTx tx))) = + BlockTxReceived p tx `sendSTM` b -storeDispatch (PeerEvent (p, Rejected Reject {..})) = - void . runMaybeT $ do - l <- asks myListener - guard (rejectMessage == MCTx) - pstr <- peerString p - tx_hash <- decode_tx_hash pstr rejectData - case rejectCode of - RejectInvalid -> do - $(logErrorS) "Store" $ - "Peer " <> pstr <> " rejected invalid tx hash: " <> - cs (txHashToHex tx_hash) - atomically (l (TxException tx_hash InvalidTx)) - RejectDuplicate -> do - $(logErrorS) "Store" $ - "Peer " <> pstr <> " rejected double-spend tx hash: " <> - cs (txHashToHex tx_hash) - atomically (l (TxException tx_hash DoubleSpend)) - RejectNonStandard -> do - $(logErrorS) "Store" $ - "Peer " <> pstr <> " rejected non-standard tx hash: " <> - cs (txHashToHex tx_hash) - atomically (l (TxException tx_hash NonStandard)) - RejectDust -> do - $(logErrorS) "Store" $ - "Peer " <> pstr <> " rejected dust tx hash: " <> - cs (txHashToHex tx_hash) - atomically (l (TxException tx_hash Dust)) - RejectInsufficientFee -> do - $(logErrorS) "Store" $ - "Peer " <> pstr <> " rejected low fee tx hash: " <> - cs (txHashToHex tx_hash) - atomically (l (TxException tx_hash LowFee)) - _ -> do - $(logErrorS) "Store" $ - "Peer " <> pstr <> " rejected tx hash: " <> - cs (show rejectCode) - atomically (l (TxException tx_hash PeerRejectOther)) - where - decode_tx_hash pstr bytes = - case decode bytes of - Left e -> do - $(logErrorS) "Store" $ - "Could not decode rejection data from peer " <> pstr <> ": " <> - cs e - MaybeT (return Nothing) - Right h -> return h +storeDispatch b _ (PeerEvent (PeerMessage p (MNotFound (NotFound is)))) = do + let blocks = + [ BlockHash h + | InvVector t h <- is + , t == InvBlock || t == InvWitnessBlock + ] + unless (null blocks) $ BlockNotFound p blocks `sendSTM` b -storeDispatch (PeerEvent (_, TxNotFound tx_hash)) = do - l <- asks myListener - atomically (l (TxException tx_hash CouldNotImport)) +storeDispatch b _ (PeerEvent (PeerMessage p (MInv (Inv is)))) = do + let txs = [TxHash h | InvVector t h <- is, t == InvTx || t == InvWitnessTx] + unless (null txs) $ BlockTxAvailable p txs `sendSTM` b -storeDispatch (PeerEvent _) = return () +storeDispatch _ _ (PeerEvent _) = return () -- | Publish a new transaction to the network. -publishTx :: - (MonadUnliftIO m, MonadLoggerIO m) - => Network - -> Store - -> DB - -> Tx - -> m (Either TxException DetailedTx) -publishTx net Store {..} db tx = - withSnapshot db $ \s -> - getTx net (txHash tx) db s >>= \case - Just d -> return (Right d) - Nothing -> - timeout 10000000 (runExceptT (go s)) >>= \case - Nothing -> return (Left PublishTimeout) - Just e -> return e - where - go s = do - p <- - managerGetPeers storeManager >>= \case - [] -> throwError NoPeers - p:_ -> return (onlinePeerMailbox p) - ExceptT . withPubSub storePublisher (newTBQueueIO 1000) $ \sub -> - runExceptT (send_it s sub p) - send_it s sub p = do - h <- is_at_height s - unless h $ throwError NotAtHeight - r <- liftIO randomIO - MTx tx `sendMessage` p - MPing (Ping r) `sendMessage` p - recv_loop sub p r - maybeToExceptT - CouldNotImport - (MaybeT (withSnapshot db $ getTx net (txHash tx) db)) - recv_loop sub p r = - receive sub >>= \case - PeerPong p' n - | p == p' && n == r -> do - TxPublished tx `send` storeBlock - recv_loop sub p r - MempoolNew h - | h == txHash tx -> return () - PeerDisconnected p' - | p' == p -> throwError PeerIsGone - TxException h AlreadyImported - | h == txHash tx -> return () - TxException h x - | h == txHash tx -> throwError x - _ -> recv_loop sub p r - is_at_height s = do - bb <- getBestBlockHash db s - cb <- chainGetBest storeChain - return (headerHash (nodeHeader cb) == bb) +publishTx :: (MonadUnliftIO m, MonadLoggerIO m) => Manager -> Tx -> m Bool +publishTx mgr tx = + managerGetPeers mgr >>= \case + [] -> return False + ps -> do + forM_ ps (\OnlinePeer {onlinePeerMailbox = p} -> MTx tx `sendMessage` p) + return True --- | Peer information to show on logs. -peerString :: (MonadStore m, IsString a) => Peer -> m a -peerString p = do - mgr <- asks myManager - managerGetPeer mgr p >>= \case - Nothing -> return "[unknown]" - Just o -> return $ fromString $ show $ onlinePeerAddress o + +-- | Obtain information about connected peers from peer manager process. +getPeersInformation :: MonadIO m => Manager -> m [PeerInformation] +getPeersInformation mgr = mapMaybe toInfo <$> managerGetPeers mgr + where + toInfo op = do + ver <- onlinePeerVersion op + let as = onlinePeerAddress op + ua = getVarString $ userAgent ver + vs = version ver + sv = services ver + rl = relay ver + return + PeerInformation + { peerUserAgent = ua + , peerAddress = as + , peerVersion = vs + , peerServices = sv + , peerRelay = rl + } diff --git a/src/Network/Haskoin/Store/Block.hs b/src/Network/Haskoin/Store/Block.hs --- a/src/Network/Haskoin/Store/Block.hs +++ b/src/Network/Haskoin/Store/Block.hs @@ -1,1192 +1,366 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -module Network.Haskoin.Store.Block - ( blockStore - , getBestBlock - , getBestBlockHash - , getBlockAtHeight - , getBlock - , getBlocks - , getAddrTxs - , getUnspent - , getBalance - , getTx - , getMempool - , getPeersInformation - ) where - -import Conduit -import Control.Applicative -import Control.Monad.Except -import Control.Monad.Logger -import Control.Monad.Reader -import Control.Monad.State.Strict -import Control.Monad.Trans.Maybe -import qualified Data.ByteString as B -import Data.List -import Data.Map (Map) -import qualified Data.Map.Strict as M -import Data.Maybe -import Data.Serialize (encode) -import Data.Set (Set) -import qualified Data.Set as S -import Data.String -import Data.String.Conversions -import Data.Text (Text) -import Data.Time.Clock.POSIX -import Database.RocksDB (BatchOp, DB, Snapshot) -import Database.RocksDB as R -import Database.RocksDB.Query as R -import Haskoin -import Haskoin.Node -import Network.Haskoin.Store.Types -import NQE -import UnliftIO - --- | Block store process state. -data BlockRead = BlockRead - { myBlockDB :: !DB - , mySelf :: !BlockStore - , myChain :: !Chain - , myManager :: !Manager - , myListener :: !(Listen StoreEvent) - , myBaseHeight :: !(TVar BlockHeight) - , myPeer :: !(TVar (Maybe Peer)) - , myNetwork :: !Network - } - --- | Block store context. -type MonadBlock m - = (MonadLoggerIO m, MonadReader BlockRead m) - --- | Map of outputs for importing transactions. -type OutputMap = Map OutPoint Output - --- | Map of address balances for importing transactions. -type AddressMap = Map Address Balance - --- | Map of transactions for importing. -type TxMap = Map TxHash ImportTx - --- | Status of a transaction being verified for importing. -data TxStatus - = TxValid - | TxOrphan - | TxLowFunds - | TxInputSpent - deriving (Eq, Show, Ord) - --- | Transaction to import. -data ImportTx = ImportTx - { importTx :: !Tx - , importTxBlock :: !(Maybe BlockRef) - } - --- | State for importing or removing blocks and transactions. -data ImportState = ImportState - { outputMap :: !OutputMap - , addressMap :: !AddressMap - , deleteTxs :: !(Set TxHash) - , newTxs :: !TxMap - , blockAction :: !(Maybe BlockAction) - } - --- | Context for importing or removing blocks and transactions. -type MonadImport m = MonadState ImportState m - --- | Whether to import or remove a block. -data BlockAction = RevertBlock | ImportBlock !Block - --- | Run within 'MonadImport' context. Execute updates to database and --- notification to subscribers when finished. -runMonadImport :: - MonadBlock m => StateT ImportState m a -> m a -runMonadImport f = - evalStateT - (f >>= \a -> update_database >> return a) - ImportState - { outputMap = M.empty - , addressMap = M.empty - , deleteTxs = S.empty - , newTxs = M.empty - , blockAction = Nothing - } - where - update_database = do - net <- asks myNetwork - ops <- - concat <$> - sequence - [ getBlockOps - , getBalanceOps - , getDeleteTxOps net - , getInsertTxOps - , purgeOrphanOps - ] - db <- asks myBlockDB - writeBatch db ops - l <- asks myListener - ba <- gets blockAction - case ba of - Just (ImportBlock Block {..}) -> - atomically (l (BestBlock (headerHash blockHeader))) - Just RevertBlock -> $(logWarnS) "Block" "Reverted best block" - Nothing -> gets newTxs >>= \ths -> - forM_ (M.keys ths) $ \tx -> atomically (l (MempoolNew tx)) - --- | Run block store process. -blockStore :: (MonadUnliftIO m, MonadLoggerIO m) => BlockConfig -> m () -blockStore BlockConfig {..} = do - base_height_box <- newTVarIO 0 - peer_box <- newTVarIO Nothing - runReaderT - (init_db >> syncBlocks >> run) - BlockRead - { mySelf = blockConfMailbox - , myBlockDB = blockConfDB - , myChain = blockConfChain - , myManager = blockConfManager - , myListener = blockConfListener - , myBaseHeight = base_height_box - , myPeer = peer_box - , myNetwork = blockConfNet - } - where - run = - forever $ do - msg <- receive blockConfMailbox - processBlockMessage msg - init_db = - runResourceT $ do - runConduit $ - matching blockConfDB Nothing ShortOrphanKey .| - mapM_C (\(k, Tx {}) -> remove blockConfDB k) - retrieve blockConfDB Nothing BestBlockKey >>= \case - Nothing -> addNewBlock (genesisBlock blockConfNet) - Just (_ :: BlockHash) -> do - BlockValue {..} <- - withSnapshot blockConfDB $ getBestBlock blockConfDB - base_height_box <- asks myBaseHeight - atomically $ writeTVar base_height_box blockValueHeight - --- | Get best block hash. -getBestBlockHash :: MonadIO m => DB -> Snapshot -> m BlockHash -getBestBlockHash db s = - retrieve db (Just s) BestBlockKey >>= \case - Nothing -> throwString "Best block hash not available" - Just bh -> return bh - --- | Get best block. -getBestBlock :: MonadIO m => DB -> Snapshot -> m BlockValue -getBestBlock db s = - getBestBlockHash db s >>= \bh -> - getBlock bh db s >>= \case - Nothing -> - throwString $ - "Best block not available at hash: " <> cs (blockHashToHex bh) - Just b -> return b - --- | Get one block at specified height. -getBlockAtHeight :: - MonadIO m => BlockHeight -> DB -> Snapshot -> m (Maybe BlockValue) -getBlockAtHeight height db s = - retrieve db (Just s) (HeightKey height) >>= \case - Nothing -> return Nothing - Just h -> retrieve db (Just s) (BlockKey h) - --- | Get blocks for specific hashes. -getBlocks :: MonadIO m => [BlockHash] -> DB -> Snapshot -> m [BlockValue] -getBlocks bids db s = - fmap catMaybes . forM (nub bids) $ \bid -> getBlock bid db s - --- | Get a block. -getBlock :: - MonadIO m => BlockHash -> DB -> Snapshot -> m (Maybe BlockValue) -getBlock bh db s = retrieve db (Just s) (BlockKey bh) - --- | Get unspent outputs for an address. -getAddrUnspent :: - (MonadUnliftIO m, MonadResource m) - => Address - -> Maybe BlockHeight - -> DB - -> Snapshot - -> ConduitT () (AddrOutKey, Output) m () -getAddrUnspent addr h db s = - matchingSkip - db - (Just s) - (ShortAddrOutKey addr) - (ShortAddrOutKeyHeight addr h) - --- | Get balance for an address. -getBalance :: - MonadIO m => Address -> DB -> Snapshot -> m AddressBalance -getBalance addr db s = - retrieve db (Just s) (BalanceKey addr) >>= \case - Just Balance {..} -> - return - AddressBalance - { addressBalAddress = addr - , addressBalConfirmed = balanceValue - , addressBalUnconfirmed = balanceUnconfirmed - , addressUtxoCount = balanceUtxoCount - } - Nothing -> - return - AddressBalance - { addressBalAddress = addr - , addressBalConfirmed = 0 - , addressBalUnconfirmed = 0 - , addressUtxoCount = 0 - } - --- | Get list of transactions in mempool. -getMempool :: MonadUnliftIO m => DB -> Snapshot -> m [TxHash] -getMempool db s = get_hashes <$> matchingAsList db (Just s) ShortMempoolKey - where - get_hashes mempool_txs = [tx_hash | (MempoolKey tx_hash, ()) <- mempool_txs] - --- | Get single transaction. -getTx :: - MonadUnliftIO m - => Network - -> TxHash - -> DB - -> Snapshot - -> m (Maybe DetailedTx) -getTx net th db s = do - xs <- matchingAsList db (Just s) (ShortMultiTxKey th) - case find_tx xs of - Just TxRecord {..} -> - let os = map (uncurry output) (filter_outputs xs) - is = map (input txValuePrevOuts) (txIn txValue) - in return $ - Just - DetailedTx - { detailedTxData = txValue - , detailedTxFee = fee is os - , detailedTxBlock = txValueBlock - , detailedTxInputs = is - , detailedTxOutputs = os - } - Nothing -> return Nothing - where - fee is os = - if any isCoinbase is - then 0 - else sum (map detInValue is) - sum (map detOutValue os) - input prevs TxIn {..} = - if outPointHash prevOutput == zero - then DetailedCoinbase - { detInOutPoint = prevOutput - , detInSequence = txInSequence - , detInSigScript = scriptInput - , detInNetwork = net - } - else let PrevOut {..} = - fromMaybe - (error - ("Could not locate outpoint: " <> - showOutPoint prevOutput)) - (lookup prevOutput prevs) - in DetailedInput - { detInOutPoint = prevOutput - , detInSequence = txInSequence - , detInSigScript = scriptInput - , detInPkScript = prevOutScript - , detInValue = prevOutValue - , detInBlock = prevOutBlock - , detInNetwork = net - } - output OutPoint {..} Output {..} = - DetailedOutput - { detOutValue = outputValue - , detOutScript = outScript - , detOutSpender = outSpender - , detOutNetwork = net - } - find_tx xs = - listToMaybe - [ t - | (k, v) <- xs - , case k of - MultiTxKey {} -> True - _ -> False - , let MultiTx t = v - ] - filter_outputs xs = - [ (p, o) - | (k, v) <- xs - , case (k, v) of - (MultiTxOutKey {}, MultiTxOutput {}) -> True - _ -> False - , let MultiTxOutKey (OutputKey p) = k - , let MultiTxOutput o = v - ] - --- | Get transaction output for importing transaction. -getOutput :: (MonadBlock m, MonadImport m) => OutPoint -> m (Maybe Output) -getOutput out_point = runMaybeT $ MaybeT map_lookup <|> MaybeT db_lookup - where - map_lookup = M.lookup out_point <$> gets outputMap - db_key = OutputKey out_point - db_lookup = asks myBlockDB >>= \db -> retrieve db Nothing db_key - --- | Get address balance for importing transaction. -getAddress :: (MonadBlock m, MonadImport m) => Address -> m Balance -getAddress address = - fromMaybe emptyBalance <$> - runMaybeT (MaybeT map_lookup <|> MaybeT db_lookup) - where - map_lookup = M.lookup address <$> gets addressMap - db_key = BalanceKey address - db_lookup = asks myBlockDB >>= \db -> retrieve db Nothing db_key - --- | Get transactions to delete. -getDeleteTxs :: MonadImport m => m (Set TxHash) -getDeleteTxs = gets deleteTxs - --- | Should this transaction be deleted already? -shouldDelete :: MonadImport m => TxHash -> m Bool -shouldDelete tx_hash = S.member tx_hash <$> getDeleteTxs - --- | Add a new block. -addBlock :: MonadImport m => Block -> m () -addBlock block = modify $ \s -> s {blockAction = Just (ImportBlock block)} - --- | Revert best block. -revertBlock :: MonadImport m => m () -revertBlock = modify $ \s -> s {blockAction = Just RevertBlock} - --- | Delete a transaction. -deleteTx :: MonadImport m => TxHash -> m () -deleteTx tx_hash = - modify $ \s -> s {deleteTxs = S.insert tx_hash (deleteTxs s)} - --- | Insert a transaction. -insertTx :: MonadImport m => Tx -> Maybe BlockRef -> m () -insertTx tx maybe_block_ref = - modify $ \s -> s {newTxs = M.insert (txHash tx) import_tx (newTxs s)} - where - import_tx = ImportTx {importTx = tx, importTxBlock = maybe_block_ref} - --- | Insert or update a transaction output. -updateOutput :: MonadImport m => OutPoint -> Output -> m () -updateOutput out_point output = - modify $ \s -> s {outputMap = M.insert out_point output (outputMap s)} - --- | Insert or update an address balance. -updateAddress :: MonadImport m => Address -> Balance -> m () -updateAddress address balance = - modify $ \s -> s {addressMap = M.insert address balance (addressMap s)} - --- | Spend an output. -spendOutput :: (MonadBlock m, MonadImport m) => OutPoint -> Spender -> m () -spendOutput out_point spender@Spender {..} = - void . runMaybeT $ do - net <- asks myNetwork - guard (out_point /= nullOutPoint) - output@Output {..} <- - getOutput out_point >>= \case - Nothing -> - throwString $ - "Could not get output to spend at outpoint: " <> - showOutPoint out_point - Just output -> return output - when (isJust outSpender) . throwString $ - "Output to spend already spent at outpoint: " <> showOutPoint out_point - updateOutput out_point output {outSpender = Just spender} - address <- MaybeT (return (scriptToAddressBS net outScript)) - balance@Balance {..} <- getAddress address - updateAddress address $ - if isJust spenderBlock - then balance - { balanceValue = balanceValue - outputValue - , balanceUtxoCount = balanceUtxoCount - 1 - } - else balance - { balanceUnconfirmed = - balanceUnconfirmed - fromIntegral outputValue - , balanceUtxoCount = balanceUtxoCount - 1 - } - --- | Make an output unspent. -unspendOutput :: (MonadBlock m, MonadImport m) => OutPoint -> m () -unspendOutput out_point = - void . runMaybeT $ do - net <- asks myNetwork - guard (out_point /= nullOutPoint) - output@Output {..} <- - getOutput out_point >>= \case - Nothing -> - throwString $ - "Could not get output to unspend at outpoint: " <> - showOutPoint out_point - Just output -> return output - Spender {..} <- MaybeT (return outSpender) - updateOutput out_point output {outSpender = Nothing} - address <- MaybeT (return (scriptToAddressBS net outScript)) - balance@Balance {..} <- getAddress address - updateAddress address $ - if isJust spenderBlock - then balance - { balanceValue = balanceValue + outputValue - , balanceUtxoCount = balanceUtxoCount + 1 - } - else balance - { balanceUnconfirmed = - balanceUnconfirmed + fromIntegral outputValue - , balanceUtxoCount = balanceUtxoCount + 1 - } - --- | Remove unspent output. -removeOutput :: (MonadBlock m, MonadImport m) => OutPoint -> m () -removeOutput out_point@OutPoint {..} = do - net <- asks myNetwork - Output {..} <- - getOutput out_point >>= \case - Nothing -> - throwString $ - "Could not get output to remove at outpoint: " <> show out_point - Just o -> return o - when (isJust outSpender) . throwString $ - "Cannot delete because spent outpoint: " <> show out_point - case scriptToAddressBS net outScript of - Nothing -> return () - Just address -> do - balance@Balance {..} <- getAddress address - updateAddress address $ - if isJust outBlock - then balance - { balanceValue = balanceValue - outputValue - , balanceUtxoCount = balanceUtxoCount - 1 - } - else balance - { balanceUnconfirmed = - balanceUnconfirmed - fromIntegral outputValue - , balanceUtxoCount = balanceUtxoCount - 1 - } - --- | Add a new unspent output. -addOutput :: (MonadBlock m, MonadImport m) => OutPoint -> Output -> m () -addOutput out_point@OutPoint {..} output@Output {..} = do - net <- asks myNetwork - updateOutput out_point output - case scriptToAddressBS net outScript of - Nothing -> return () - Just address -> do - balance@Balance {..} <- getAddress address - updateAddress address $ - if isJust outBlock - then balance - { balanceValue = balanceValue + outputValue - , balanceUtxoCount = balanceUtxoCount + 1 - } - else balance - { balanceUnconfirmed = - balanceUnconfirmed + fromIntegral outputValue - , balanceUtxoCount = balanceUtxoCount + 1 - } - --- | Get transaction. -getTxRecord :: MonadBlock m => TxHash -> m (Maybe TxRecord) -getTxRecord tx_hash = - asks myBlockDB >>= \db -> retrieve db Nothing (TxKey tx_hash) - --- | Delete a transaction. -deleteTransaction :: - (MonadBlock m, MonadImport m) - => TxHash - -> m () -deleteTransaction tx_hash = shouldDelete tx_hash >>= \d -> unless d delete_it - where - delete_it = do - TxRecord {..} <- - getTxRecord tx_hash >>= \case - Nothing -> - throwString $ - "Could not get tx to delete at hash: " <> - cs (txHashToHex tx_hash) - Just r -> return r - let n_out = length (txOut txValue) - prevs = map prevOutput (txIn txValue) - remove_spenders n_out - remove_outputs n_out - unspend_inputs prevs - deleteTx tx_hash - remove_spenders n_out = - forM_ (take n_out [0 ..]) $ \i -> - let out_point = OutPoint tx_hash i - in getOutput out_point >>= \case - Nothing -> - throwString $ - "Could not get spent outpoint: " <> show out_point - Just Output {outSpender = Just Spender {..}} -> - deleteTransaction spenderHash - Just _ -> return () - remove_outputs n_out = - mapM_ (removeOutput . OutPoint tx_hash) (take n_out [0 ..]) - unspend_inputs = mapM_ unspendOutput - --- | Add new block. -addNewBlock :: MonadBlock m => Block -> m () -addNewBlock block@Block {..} = - runMonadImport $ do - new_height <- get_new_height - $(logInfoS) "Block" $ "Importing block height: " <> cs (show new_height) - import_txs new_height - addBlock block - where - import_txs new_height = - mapM_ - (uncurry (import_tx (BlockRef new_hash new_height))) - (zip [0 ..] blockTxns) - import_tx block_ref i tx = importTransaction tx (Just (block_ref i)) - new_hash = headerHash blockHeader - prev_block = prevBlock blockHeader - get_new_height = do - net <- asks myNetwork - if blockHeader == getGenesisHeader net - then return 0 - else do - best <- - asks myBlockDB >>= \db -> withSnapshot db $ getBestBlock db - when (prev_block /= headerHash (blockValueHeader best)) . - throwString $ - "Block does not build on best at hash: " <> show new_hash - return $ blockValueHeight best + 1 - --- | Get write ops for importing or removing a block. -getBlockOps :: (MonadBlock m, MonadImport m) => m [BatchOp] -getBlockOps = - gets blockAction >>= \case - Nothing -> return [] - Just RevertBlock -> get_block_remove_ops - Just (ImportBlock block) -> get_block_insert_ops block - where - get_block_insert_ops block@Block {..} = do - let block_hash = headerHash blockHeader - ch <- asks myChain - bn <- - chainGetBlock block_hash ch >>= \case - Just bn -> return bn - Nothing -> - throwString $ - "Could not get block header for hash: " <> - cs (blockHashToHex block_hash) - let block_value = - BlockValue - { blockValueHeight = nodeHeight bn - , blockValueWork = nodeWork bn - , blockValueHeader = nodeHeader bn - , blockValueSize = fromIntegral (B.length (encode block)) - , blockValueTxs = map txHash blockTxns - } - return - [ insertOp (BlockKey block_hash) block_value - , insertOp (HeightKey (nodeHeight bn)) block_hash - , insertOp BestBlockKey block_hash - ] - get_block_remove_ops = do - db <- asks myBlockDB - BlockValue {..} <- withSnapshot db $ getBestBlock db - let block_hash = headerHash blockValueHeader - block_key = BlockKey block_hash - height_key = HeightKey blockValueHeight - prev_block = prevBlock blockValueHeader - return - [ deleteOp block_key - , deleteOp height_key - , insertOp BestBlockKey prev_block - ] - --- | Get output ops for importing or removing transactions. -outputOps :: (MonadBlock m, MonadImport m) => OutPoint -> m [BatchOp] -outputOps out_point@OutPoint {..} - | out_point == nullOutPoint = return [] - | otherwise = do - net <- asks myNetwork - output@Output {..} <- - getOutput out_point >>= \case - Nothing -> - throwString $ - "Could not get output to unspend at outpoint: " <> - show out_point - Just o -> return o - let output_op = insertOp (OutputKey out_point) output - addr_ops = addressOutOps net out_point output False - return $ output_op : addr_ops - --- | Get address output ops when importing or removing transactions. -addressOutOps :: Network -> OutPoint -> Output -> Bool -> [BatchOp] -addressOutOps net out_point output@Output {..} del = - case scriptToAddressBS net outScript of - Nothing -> [] - Just a - | del -> out_ops a - | otherwise -> tx_op a : spender_ops a <> out_ops a - where - out_ops a = - let key = - AddrOutKey - { addrOutputAddress = a - , addrOutputHeight = blockRefHeight <$> outBlock - , addrOutputPos = blockRefPos <$> outBlock - , addrOutPoint = out_point - } - mem = key {addrOutputHeight = Nothing, addrOutputPos = Nothing} - in if isJust outSpender || del - then [deleteOp mem, deleteOp key] - else [deleteOp mem, insertOp key output] - tx_op a = - let tx_key = - AddrTxKey - { addrTxKey = a - , addrTxHeight = blockRefHeight <$> outBlock - , addrTxPos = blockRefPos <$> outBlock - , addrTxHash = outPointHash out_point - } - in insertOp tx_key () - spender_ops a = - case outSpender of - Nothing -> [] - Just Spender {..} -> - let spender_key = - AddrTxKey - { addrTxKey = a - , addrTxHeight = blockRefHeight <$> spenderBlock - , addrTxPos = blockRefPos <$> spenderBlock - , addrTxHash = spenderHash - } - in [insertOp spender_key ()] - - --- | Get ops for outputs to delete. -deleteOutOps :: (MonadBlock m, MonadImport m) => OutPoint -> m [BatchOp] -deleteOutOps out_point@OutPoint {..} = do - net <- asks myNetwork - output@Output {..} <- - getOutput out_point >>= \case - Nothing -> - throwString $ - "Could not get output to delete at outpoint: " <> show out_point - Just o -> return o - let output_op = deleteOp (OutputKey out_point) - addr_ops = addressOutOps net out_point output True - return $ output_op : addr_ops - --- | Get ops for transactions to delete. -deleteTxOps :: TxHash -> [BatchOp] -deleteTxOps tx_hash = - [ deleteOp (TxKey tx_hash) - , deleteOp (MempoolKey tx_hash) - , deleteOp (OrphanKey tx_hash) - ] - --- | Purge all orphan transactions. -purgeOrphanOps :: (MonadBlock m, MonadImport m) => m [BatchOp] -purgeOrphanOps = - fmap (fromMaybe []) . runMaybeT $ do - db <- asks myBlockDB - guard . isJust =<< gets blockAction - liftIO . runResourceT . runConduit $ - matching db Nothing ShortOrphanKey .| - mapC (\(k, Tx {}) -> deleteOp k) .| - sinkList - --- | Get a transaction record from database. -getSimpleTx :: MonadBlock m => TxHash -> m TxRecord -getSimpleTx tx_hash = - getTxRecord tx_hash >>= \case - Nothing -> throwString $ "Cannot find tx hash: " <> show tx_hash - Just r -> return r - --- | Get outpoints for a transaction. -getTxOutPoints :: Tx -> [OutPoint] -getTxOutPoints tx@Tx {..} = - let tx_hash = txHash tx - in [OutPoint tx_hash i | i <- take (length txOut) [0 ..]] - --- | Get previous outpoints from a transaction. -getPrevOutPoints :: Tx -> [OutPoint] -getPrevOutPoints Tx {..} = map prevOutput txIn - -deleteAddrTxOps :: Network -> TxRecord -> [BatchOp] -deleteAddrTxOps net TxRecord {..} = - let ias = - mapMaybe - (scriptToAddressBS net . prevOutScript . snd) - txValuePrevOuts - oas = mapMaybe (scriptToAddressBS net . scriptOutput) (txOut txValue) - in map del_addr_tx (ias <> oas) - where - del_addr_tx a = - deleteOp $ - AddrTxKey - { addrTxKey = a - , addrTxHeight = blockRefHeight <$> txValueBlock - , addrTxPos = blockRefPos <$> txValueBlock - , addrTxHash = txHash txValue - } - --- | Get ops do delete transactions. -getDeleteTxOps :: (MonadBlock m, MonadImport m) => Network -> m [BatchOp] -getDeleteTxOps net = do - del_txs <- S.toList <$> getDeleteTxs - trs <- mapM getSimpleTx del_txs - let txs = map txValue trs - let prev_outs = concatMap getPrevOutPoints txs - tx_outs = concatMap getTxOutPoints txs - tx_ops = concatMap deleteTxOps del_txs - addr_tx_ops = concatMap (deleteAddrTxOps net) trs - prev_out_ops <- concat <$> mapM outputOps prev_outs - tx_out_ops <- concat <$> mapM deleteOutOps tx_outs - return $ prev_out_ops <> tx_out_ops <> tx_ops <> addr_tx_ops - --- | Get ops to insert transactions. -insertTxOps :: (MonadBlock m, MonadImport m) => ImportTx -> m [BatchOp] -insertTxOps ImportTx {..} = do - prev_outputs <- get_prev_outputs - let key = TxKey (txHash importTx) - mempool_key = MempoolKey (txHash importTx) - orphan_key = OrphanKey (txHash importTx) - value = - TxRecord - { txValueBlock = importTxBlock - , txValue = importTx - , txValuePrevOuts = prev_outputs - } - case importTxBlock of - Nothing -> - return - [ insertOp key value - , insertOp mempool_key () - , deleteOp orphan_key - ] - Just _ -> - return - [insertOp key value, deleteOp mempool_key, deleteOp orphan_key] - where - get_prev_outputs = - let real_inputs = - filter ((/= nullOutPoint) . prevOutput) (txIn importTx) - in forM real_inputs $ \TxIn {..} -> do - Output {..} <- - getOutput prevOutput >>= \case - Nothing -> - throwString $ - "While importing tx hash: " <> - cs (txHashToHex (txHash importTx)) <> - "could not get outpoint: " <> - showOutPoint prevOutput - Just out -> return out - return - ( prevOutput - , PrevOut - { prevOutValue = outputValue - , prevOutBlock = outBlock - , prevOutScript = outScript - }) - --- | Aggregate all transaction insert ops. -getInsertTxOps :: (MonadBlock m, MonadImport m) => m [BatchOp] -getInsertTxOps = do - new_txs <- M.elems <$> gets newTxs - let txs = map importTx new_txs - let prev_outs = concatMap getPrevOutPoints txs - tx_outs = concatMap getTxOutPoints txs - prev_out_ops <- concat <$> mapM outputOps prev_outs - tx_out_ops <- concat <$> mapM outputOps tx_outs - tx_ops <- concat <$> mapM insertTxOps new_txs - return $ prev_out_ops <> tx_out_ops <> tx_ops - --- | Aggregate all balance update ops. -getBalanceOps :: MonadImport m => m [BatchOp] -getBalanceOps = do - address_map <- gets addressMap - return $ map (uncurry (insertOp . BalanceKey)) (M.toList address_map) - --- | Revert best block. -revertBestBlock :: MonadBlock m => m () -revertBestBlock = do - net <- asks myNetwork - db <- asks myBlockDB - BlockValue {..} <- withSnapshot db $ getBestBlock db - when (blockValueHeader == getGenesisHeader net) . throwString $ - "Attempted to revert genesis block" - import_txs <- map txValue <$> mapM getSimpleTx (tail blockValueTxs) - runMonadImport $ do - mapM_ deleteTransaction blockValueTxs - revertBlock - reset_peer (blockValueHeight - 1) - runMonadImport $ mapM_ (`importTransaction` Nothing) import_txs - where - reset_peer height = do - base_height_box <- asks myBaseHeight - peer_box <- asks myPeer - atomically $ do - writeTVar base_height_box height - writeTVar peer_box Nothing - --- | Validate a transaction without script evaluation. -validateTx :: Monad m => OutputMap -> Tx -> ExceptT TxException m () -validateTx outputs tx = do - prev_outs <- - forM (txIn tx) $ \TxIn {..} -> - case M.lookup prevOutput outputs of - Nothing -> throwError OrphanTx - Just o -> return o - when (any (isJust . outSpender) prev_outs) (throwError DoubleSpend) - let sum_inputs = sum (map outputValue prev_outs) - sum_outputs = sum (map outValue (txOut tx)) - when (sum_outputs > sum_inputs) (throwError OverSpend) - --- | Import a transaction. -importTransaction :: - (MonadBlock m, MonadImport m) => Tx -> Maybe BlockRef -> m Bool -importTransaction tx maybe_block_ref = - runExceptT validate_tx >>= \case - Left e -> do - ret <- - case e of - AlreadyImported -> - return True - OrphanTx -> do - import_orphan - return False - _ -> do - $(logErrorS) "Block" $ - "Could not import tx hash: " <> - cs (txHashToHex (txHash tx)) <> - " reason: " <> - cs (show e) - return False - asks myListener >>= \l -> atomically (l (TxException (txHash tx) e)) - return ret - Right () -> do - delete_spenders - spend_inputs - insert_outputs - insertTx tx maybe_block_ref - return True - where - import_orphan = do - $(logInfoS) "BlockStore " $ - "Got orphan tx hash: " <> cs (txHashToHex (txHash tx)) - db <- asks myBlockDB - R.insert db (OrphanKey (txHash tx)) tx - validate_tx - | isJust maybe_block_ref = return () -- only validate unconfirmed - | otherwise = do - getTxRecord (txHash tx) >>= \maybe_tx -> - when (isJust maybe_tx) (throwError AlreadyImported) - prev_outs <- - fmap (M.fromList . catMaybes) . forM (txIn tx) $ \TxIn {..} -> - getOutput prevOutput >>= \case - Nothing -> return Nothing - Just o -> return $ Just (prevOutput, o) - validateTx prev_outs tx - delete_spenders = - forM_ (txIn tx) $ \TxIn {..} -> - getOutput prevOutput >>= \case - Nothing -> - unless (prevOutput == nullOutPoint) . throwString $ - "Could not get output spent by tx hash: " <> - show (txHash tx) - Just Output {outSpender = Just Spender {..}} -> - deleteTransaction spenderHash - _ -> return () - spend_inputs = - forM_ (zip [0 ..] (txIn tx)) $ \(i, TxIn {..}) -> - spendOutput - prevOutput - Spender - { spenderHash = txHash tx - , spenderIndex = i - , spenderBlock = maybe_block_ref - } - insert_outputs = - forM_ (zip [0 ..] (txOut tx)) $ \(i, TxOut {..}) -> - addOutput - OutPoint {outPointHash = txHash tx, outPointIndex = i} - Output - { outputValue = outValue - , outBlock = maybe_block_ref - , outScript = scriptOutput - , outSpender = Nothing - } - --- | Attempt to synchronize blocks. -syncBlocks :: MonadBlock m => m () -syncBlocks = - void . runMaybeT $ do - net <- asks myNetwork - chain_best <- asks myChain >>= chainGetBest - revert_if_needed chain_best - let chain_height = nodeHeight chain_best - base_height_box <- asks myBaseHeight - db <- asks myBlockDB - best_block <- withSnapshot db $ getBestBlock db - let best_height = blockValueHeight best_block - when (best_height == chain_height) $ do - reset_peer best_height - empty - base_height <- readTVarIO base_height_box - p <- get_peer - when (base_height > best_height + 500) empty - when (base_height >= chain_height) empty - ch <- asks myChain - let sync_lowest = min chain_height (base_height + 1) - sync_highest = min chain_height (base_height + 501) - sync_top <- - if sync_highest == chain_height - then return chain_best - else chainGetAncestor sync_highest chain_best ch >>= \case - Nothing -> - throwString - "Could not get syncing header from chain" - Just b -> return b - sync_blocks <- - (++ [sync_top]) <$> - if sync_lowest == chain_height - then return [] - else chainGetParents sync_lowest sync_top ch - update_peer sync_highest (Just p) - peerGetBlocks net p (map (headerHash . nodeHeader) sync_blocks) - where - get_peer = - asks myPeer >>= readTVarIO >>= \case - Just p -> return p - Nothing -> - asks myManager >>= managerGetPeers >>= \case - [] -> empty - p:_ -> return (onlinePeerMailbox p) - reset_peer best_height = update_peer best_height Nothing - update_peer height mp = do - base_height_box <- asks myBaseHeight - peer_box <- asks myPeer - atomically $ do - writeTVar base_height_box height - writeTVar peer_box mp - revert_if_needed chain_best = do - db <- asks myBlockDB - ch <- asks myChain - best <- withSnapshot db $ getBestBlock db - let best_hash = headerHash (blockValueHeader best) - chain_hash = headerHash (nodeHeader chain_best) - when (best_hash /= chain_hash) $ - chainGetBlock best_hash ch >>= \case - Nothing -> do - revertBestBlock - revert_if_needed chain_best - Just best_node -> do - split_hash <- - headerHash . nodeHeader <$> - chainGetSplitBlock chain_best best_node ch - revert_until split_hash - revert_until split = do - best_hash <- - asks myBlockDB >>= \db -> - headerHash . blockValueHeader <$> - withSnapshot db (getBestBlock db) - when (best_hash /= split) $ do - revertBestBlock - revert_until split - --- | Import a block. -importBlock :: - (MonadError String m, MonadBlock m) => Block -> m () -importBlock block@Block {..} = do - bn <- asks myChain >>= chainGetBlock (headerHash blockHeader) - when (isNothing bn) $ - throwString $ - "Not in chain: block hash" <> - cs (blockHashToHex (headerHash blockHeader)) - best <- asks myBlockDB >>= \db -> withSnapshot db $ getBestBlock db - let best_hash = headerHash (blockValueHeader best) - prev_hash = prevBlock blockHeader - when (prev_hash /= best_hash) (throwError "does not build on best") - addNewBlock block - --- | Process incoming messages to the 'BlockStore' mailbox. -processBlockMessage :: (MonadUnliftIO m, MonadBlock m) => BlockMessage -> m () - -processBlockMessage (BlockChainNew _) = syncBlocks - -processBlockMessage (BlockPeerConnect p) = syncBlocks >> syncMempool p - -processBlockMessage (BlockReceived p b) = - runExceptT (importBlock b) >>= \case - Left e -> do - pstr <- peerString p - let hash = headerHash (blockHeader b) - $(logErrorS) "Block" $ - "Could not import from peer" <> pstr <> " block hash:" <> - cs (blockHashToHex hash) <> - " error: " <> - fromString e - Right () -> importOrphans >> syncBlocks >> syncMempool p - -processBlockMessage (TxReceived _ tx) = - isAtHeight >>= \x -> - when x $ do - _ <- runMonadImport $ importTransaction tx Nothing - importOrphans - -processBlockMessage (TxPublished tx) = - void . runMonadImport $ importTransaction tx Nothing - -processBlockMessage (BlockPeerDisconnect p) = do - peer_box <- asks myPeer - base_height_box <- asks myBaseHeight - db <- asks myBlockDB - best <- withSnapshot db $ getBestBlock db - is_my_peer <- - atomically $ - readTVar peer_box >>= \x -> - if x == Just p - then do - writeTVar peer_box Nothing - writeTVar base_height_box (blockValueHeight best) - return True - else return False - when is_my_peer syncBlocks - -processBlockMessage (BlockNotReceived p h) = do - pstr <- peerString p - $(logErrorS) "Block" $ - "Peer " <> pstr <> " unable to serve block hash: " <> cs (show h) - mgr <- asks myManager - managerKill (PeerMisbehaving "Block not found") p mgr - -processBlockMessage (TxAvailable p ts) = - isAtHeight >>= \h -> - when h $ do - pstr <- peerString p - $(logDebugS) "Block" $ - "Received " <> cs (show (length ts)) <> - " tx inventory from peer " <> - pstr - net <- asks myNetwork - db <- asks myBlockDB - has <- - fmap catMaybes . forM ts $ \t -> - let mem = - retrieve db Nothing (MempoolKey t) >>= \case - Nothing -> return Nothing - Just () -> return (Just t) - orp = - retrieve db Nothing (OrphanKey t) >>= \case - Nothing -> return Nothing - Just Tx {} -> return (Just t) - in runMaybeT $ MaybeT mem <|> MaybeT orp - let new = ts \\ has - unless (null new) $ do - $(logDebugS) "Block" $ - "Requesting " <> cs (show (length new)) <> - " new txs from peer " <> - pstr - peerGetTxs net p new - -processBlockMessage (PongReceived p n) = do - pstr <- peerString p - $(logDebugS) "Block" $ - "Pong received with nonce " <> cs (show n) <> " from peer " <> pstr - asks myListener >>= atomically . ($ PeerPong p n) - --- | Import orphan transactions that can be imported. -importOrphans :: (MonadUnliftIO m, MonadBlock m) => m () -importOrphans = do - db <- asks myBlockDB - ret <- - runResourceT . runConduit $ - matching db Nothing ShortOrphanKey .| mapMC (import_tx . snd) .| anyC id - when ret importOrphans - where - import_tx tx' = runMonadImport $ importTransaction tx' Nothing - -getAddrTxs :: - (MonadResource m, MonadUnliftIO m) - => Network - -> Address - -> Maybe BlockHeight - -> DB - -> Snapshot - -> ConduitT () DetailedTx m () -getAddrTxs net a h db s = - matchingSkip db (Just s) (ShortAddrTxKey a) (ShortAddrTxKeyHeight a h) .| - concatMapMC f - where - f (AddrTxKey {..}, ()) = getTx net addrTxHash db s - f _ = throwString "Nonsense! This ship in unsinkable!" - --- | Get unspent outputs for an address. -getUnspent :: - (MonadResource m, MonadUnliftIO m) - => Address - -> Maybe BlockHeight - -> DB - -> Snapshot - -> ConduitT () AddrOutput m () -getUnspent a h db s = - getAddrUnspent a h db s .| mapC (uncurry AddrOutput) - --- | Synchronize mempool against a peer. -syncMempool :: MonadBlock m => Peer -> m () -syncMempool p = - void . runMaybeT $ do - guard =<< lift isAtHeight - $(logInfoS) "Block" "Syncing mempool..." - MMempool `sendMessage` p - --- | Is the block store synchronized? -isAtHeight :: MonadBlock m => m Bool -isAtHeight = do - db <- asks myBlockDB - bb <- withSnapshot db $ getBestBlockHash db - ch <- asks myChain - cb <- chainGetBest ch - time <- liftIO getPOSIXTime - let recent = floor time - blockTimestamp (nodeHeader cb) < 60 * 60 * 4 - return (recent && headerHash (nodeHeader cb) == bb) - -zero :: TxHash -zero = "0000000000000000000000000000000000000000000000000000000000000000" - --- | Show outpoint in log. -showOutPoint :: (IsString a, ConvertibleStrings Text a) => OutPoint -> a -showOutPoint OutPoint {..} = - cs $ txHashToHex outPointHash <> ":" <> cs (show outPointIndex) - --- | Show peer data in log. -peerString :: (MonadBlock m, IsString a) => Peer -> m a -peerString p = do - mgr <- asks myManager - managerGetPeer mgr p >>= \case - Nothing -> return "[unknown]" - Just o -> return $ fromString $ show $ onlinePeerAddress o - -getPeersInformation :: MonadIO m => Manager -> m [PeerInformation] -getPeersInformation mgr = fmap toInfo <$> managerGetPeers mgr - where - toInfo op = PeerInformation - { userAgent = onlinePeerUserAgent op - , address = cs $ show $ onlinePeerAddress op - , connected = onlinePeerConnected op - , version = onlinePeerVersion op - , services = onlinePeerServices op - , relay = onlinePeerRelay op - , block = headerHash $ nodeHeader $ onlinePeerBestBlock op - , height = nodeHeight $ onlinePeerBestBlock op - , nonceLocal = onlinePeerNonce op - , nonceRemote = onlinePeerRemoteNonce op - } +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +module Network.Haskoin.Store.Block + ( blockStore + ) where + +import Control.Monad.Except +import Control.Monad.Logger +import Control.Monad.Reader +import Control.Monad.Trans.Maybe +import Data.Maybe +import Data.String +import Data.Time.Clock.System +import Database.RocksDB +import Haskoin +import Haskoin.Node +import Network.Haskoin.Store.Data +import Network.Haskoin.Store.Data.ImportDB +import Network.Haskoin.Store.Logic +import Network.Haskoin.Store.Messages +import NQE +import System.Random +import UnliftIO +import UnliftIO.Concurrent + +data BlockException + = BlockNotInChain !BlockHash + | Uninitialized + | UnexpectedGenesisNode + | SyncingPeerExpected + | AncestorNotInChain !BlockHeight + !BlockHash + deriving (Show, Eq, Ord, Exception) + +data Syncing = Syncing + { syncingPeer :: !Peer + , syncingTime :: !UnixTime + , syncingHead :: !BlockNode + } + +-- | Block store process state. +data BlockRead = BlockRead + { mySelf :: !BlockStore + , myConfig :: !BlockConfig + , myPeer :: !(TVar (Maybe Syncing)) + } + +-- | Run block store process. +blockStore :: + (MonadUnliftIO m, MonadLoggerIO m) + => BlockConfig + -> Inbox BlockMessage + -> m () +blockStore cfg inbox = do + $(logInfoS) "Block" "Initializing block store..." + pb <- newTVarIO Nothing + runReaderT + (ini >> run) + BlockRead {mySelf = inboxToMailbox inbox, myConfig = cfg, myPeer = pb} + where + ini = do + db <- blockConfDB <$> asks myConfig + net <- blockConfNet <$> asks myConfig + runExceptT (initDB net db) >>= \case + Left e -> do + $(logErrorS) "Block" $ + "Could not initialize block store: " <> fromString (show e) + throwIO e + Right () -> $(logInfoS) "Block" "Initialization complete" + run = + withAsync (pingMe (inboxToMailbox inbox)) $ \_ -> + forever $ receive inbox >>= processBlockMessage + +mempoolWhenSynced :: + (MonadReader BlockRead m, MonadUnliftIO m, MonadLoggerIO m) => m () +mempoolWhenSynced = do + db <- blockConfDB <$> asks myConfig + getBestBlock (db, defaultReadOptions) >>= \case + Nothing -> throwIO Uninitialized + Just bb -> do + ch <- blockConfChain <$> asks myConfig + chainGetBest ch >>= \cb -> + when (headerHash (nodeHeader cb) == bb) $ do + mgr <- blockConfManager <$> asks myConfig + ps <- managerGetPeers mgr + unless (null ps) $ + $(logDebugS) + "Block" + "Syncing mempool against all known peers" + mapM_ ((MMempool `sendMessage`) . onlinePeerMailbox) ps + +processBlock :: + (MonadReader BlockRead m, MonadUnliftIO m, MonadLoggerIO m) + => Peer + -> Block + -> m () +processBlock p b = do + $(logDebugS) "Block" ("Processing incoming block " <> hex) + void . runMaybeT $ do + iss >>= \x -> + unless x $ do + $(logErrorS) + "Block" + ("Cannot accept block " <> hex <> " from non-syncing peer") + mzero + db <- blockConfDB <$> asks myConfig + n <- cbn + upr + net <- blockConfNet <$> asks myConfig + runExceptT (newBlock net db b n) >>= \case + Right () -> do + l <- blockConfListener <$> asks myConfig + atomically $ l (StoreBestBlock (headerHash (blockHeader b))) + lift mempoolWhenSynced + Left e -> do + $(logErrorS) "Block" $ + "Error importing block " <> + fromString (show $ headerHash (blockHeader b)) <> + ": " <> + fromString (show e) + killPeer (PeerMisbehaving (show e)) p + syncMe + where + hex = blockHashToHex (headerHash (blockHeader b)) + upr = + asks myPeer >>= \box -> + readTVarIO box >>= \case + Nothing -> throwIO SyncingPeerExpected + Just s@Syncing {syncingHead = h} -> + if nodeHeader h == blockHeader b + then resetPeer + else do + now <- systemSeconds <$> liftIO getSystemTime + atomically . writeTVar box $ + Just s {syncingTime = now} + iss = + asks myPeer >>= readTVarIO >>= \case + Just Syncing {syncingPeer = p'} -> return $ p == p' + Nothing -> return False + cbn = + blockConfChain <$> asks myConfig >>= + chainGetBlock (headerHash (blockHeader b)) >>= \case + Nothing -> do + killPeer (PeerMisbehaving "Sent unknown block") p + $(logErrorS) + "Block" + ("Block " <> hex <> " rejected as header not found") + mzero + Just n -> return n + +processNoBlocks :: + (MonadReader BlockRead m, MonadUnliftIO m, MonadLoggerIO m) + => Peer + -> [BlockHash] + -> m () +processNoBlocks p _bs = do + $(logErrorS) "Block" "Killing peer that could not find blocks" + killPeer (PeerMisbehaving "Sent notfound message with block hashes") p + +processTx :: + (MonadReader BlockRead m, MonadUnliftIO m, MonadLoggerIO m) + => Peer + -> Tx + -> m () +processTx _p tx = do + $(logInfoS) "Block" $ "Incoming tx: " <> txHashToHex (txHash tx) + now <- preciseUnixTime <$> liftIO getSystemTime + net <- blockConfNet <$> asks myConfig + db <- blockConfDB <$> asks myConfig + runExceptT (runImportDB db $ \i -> newMempoolTx net i tx now) >>= \case + Left e -> + $(logErrorS) "Block" $ + "Error importing tx: " <> txHashToHex (txHash tx) <> ": " <> + fromString (show e) + Right () -> return () + +processTxs :: + (MonadReader BlockRead m, MonadUnliftIO m, MonadLoggerIO m) + => Peer + -> [TxHash] + -> m () +processTxs p hs = do + db <- blockConfDB <$> asks myConfig + $(logDebugS) "Block" $ + "Received " <> fromString (show (length hs)) <> + " tranasaction inventory" + xs <- + fmap catMaybes . forM hs $ \h -> + runMaybeT $ do + t <- getTransaction (db, defaultReadOptions) h + guard (isNothing t) + return (getTxHash h) + $(logDebugS) "Block" $ + "Requesting " <> fromString (show (length xs)) <> " new transactions" + MGetData (GetData (map (InvVector InvTx) xs)) `sendMessage` p + +checkTime :: (MonadReader BlockRead m, MonadUnliftIO m, MonadLoggerIO m) => m () +checkTime = + asks myPeer >>= readTVarIO >>= \case + Nothing -> return () + Just Syncing {syncingTime = t, syncingPeer = p} -> do + n <- systemSeconds <$> liftIO getSystemTime + when (n > t + 60) $ do + $(logErrorS) "Block" "Peer timeout" + killPeer PeerTimeout p + +processDisconnect :: + (MonadReader BlockRead m, MonadUnliftIO m, MonadLoggerIO m) + => Peer + -> m () +processDisconnect p = + asks myPeer >>= readTVarIO >>= \case + Nothing -> return () + Just Syncing {syncingPeer = p'} + | p == p' -> do + $(logErrorS) "Block" "Syncing peer disconnected" + resetPeer + syncMe + | otherwise -> return () + +purgeMempool :: + (MonadReader BlockRead m, MonadUnliftIO m, MonadLoggerIO m) => m () +purgeMempool = $(logErrorS) "Block" "Mempool purging not implemented" + +syncMe :: (MonadReader BlockRead m, MonadUnliftIO m, MonadLoggerIO m) => m () +syncMe = + void . runMaybeT $ do + rev + p <- + gpr >>= \case + Nothing -> do + $(logWarnS) + "Block" + "Not syncing blocks as no peers available" + mzero + Just p -> return p + b <- mbn + d <- dbn + c <- cbn + when (end b d c) mzero + ns <- bls c b + setPeer p (last ns) + vs <- mapM f ns + $(logInfoS) "Block" $ + "Requesting " <> fromString (show (length vs)) <> " blocks" + MGetData (GetData vs) `sendMessage` p + where + gpr = + asks myPeer >>= readTVarIO >>= \case + Just Syncing {syncingPeer = p} -> return (Just p) + Nothing -> + blockConfManager <$> asks myConfig >>= managerGetPeers >>= \case + [] -> return Nothing + OnlinePeer {onlinePeerMailbox = p}:_ -> return (Just p) + cbn = chainGetBest =<< blockConfChain <$> asks myConfig + dbn = do + db <- blockConfDB <$> asks myConfig + bb <- + getBestBlock (db, defaultReadOptions) >>= \case + Nothing -> do + $(logErrorS) "Block" "Best block not in database" + throwIO Uninitialized + Just b -> return b + ch <- blockConfChain <$> asks myConfig + chainGetBlock bb ch >>= \case + Nothing -> do + $(logErrorS) "Block" $ + "Block header not found for best block " <> + blockHashToHex bb + throwIO (BlockNotInChain bb) + Just x -> return x + mbn = + asks myPeer >>= readTVarIO >>= \case + Just Syncing {syncingHead = b} -> return b + Nothing -> dbn + end b d c + | nodeHeader b == nodeHeader c = True + | otherwise = nodeHeight b > nodeHeight d + 500 + f GenesisNode {} = throwIO UnexpectedGenesisNode + f BlockNode {nodeHeader = bh} = + return $ InvVector InvBlock (getBlockHash (headerHash bh)) + bls c b = do + t <- top c (tts (nodeHeight c) (nodeHeight b)) + ch <- blockConfChain <$> asks myConfig + ps <- chainGetParents (nodeHeight b + 1) t ch + return $ + if length ps < 500 + then ps <> [c] + else ps + tts c b + | c <= b + 501 = c + | otherwise = b + 501 + top c t = do + ch <- blockConfChain <$> asks myConfig + if t == nodeHeight c + then return c + else chainGetAncestor t c ch >>= \case + Just x -> return x + Nothing -> do + $(logErrorS) "Block" $ + "Unknown header for ancestor of block " <> + blockHashToHex (headerHash (nodeHeader c)) <> + " at height " <> + fromString (show t) + throwIO $ + AncestorNotInChain t (headerHash (nodeHeader c)) + rev = do + d <- headerHash . nodeHeader <$> dbn + ch <- blockConfChain <$> asks myConfig + chainBlockMain d ch >>= \m -> + unless m $ do + $(logErrorS) "Block" $ + "Reverting best block " <> blockHashToHex d <> + " as it is not in main chain..." + resetPeer + db <- blockConfDB <$> asks myConfig + runExceptT (runImportDB db $ \i -> revertBlock i d) >>= \case + Left e -> do + $(logErrorS) "Block" $ + "Could not revert best block: " <> + fromString (show e) + throwIO e + Right () -> rev + +resetPeer :: (MonadReader BlockRead m, MonadLoggerIO m) => m () +resetPeer = do + $(logDebugS) "Block" "Resetting syncing peer..." + box <- asks myPeer + atomically $ writeTVar box Nothing + +setPeer :: (MonadReader BlockRead m, MonadIO m) => Peer -> BlockNode -> m () +setPeer p b = do + box <- asks myPeer + now <- systemSeconds <$> liftIO getSystemTime + atomically . writeTVar box $ + Just Syncing {syncingPeer = p, syncingHead = b, syncingTime = now} + +processBlockMessage :: + (MonadReader BlockRead m, MonadUnliftIO m, MonadLoggerIO m) + => BlockMessage + -> m () +processBlockMessage (BlockNewBest bn) = do + $(logDebugS) "Block" $ + "New best block header " <> fromString (show (nodeHeight bn)) <> ": " <> + blockHashToHex (headerHash (nodeHeader bn)) + syncMe +processBlockMessage (BlockPeerConnect _p sa) = do + $(logDebugS) "Block" $ "New peer connected: " <> fromString (show sa) + syncMe +processBlockMessage (BlockPeerDisconnect p _sa) = processDisconnect p +processBlockMessage (BlockReceived p b) = processBlock p b +processBlockMessage (BlockNotFound p bs) = processNoBlocks p bs +processBlockMessage (BlockTxReceived p tx) = processTx p tx +processBlockMessage (BlockTxAvailable p ts) = processTxs p ts +processBlockMessage BlockPing = checkTime +processBlockMessage PurgeMempool = purgeMempool + +pingMe :: MonadIO m => Mailbox BlockMessage -> m () +pingMe mbox = forever $ do + threadDelay =<< liftIO (randomRIO (5 * 1000 * 1000, 10 * 1000 * 1000)) + BlockPing `send` mbox diff --git a/src/Network/Haskoin/Store/Data.hs b/src/Network/Haskoin/Store/Data.hs new file mode 100644 --- /dev/null +++ b/src/Network/Haskoin/Store/Data.hs @@ -0,0 +1,411 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +module Network.Haskoin.Store.Data where + +import Conduit +import Data.Aeson as A +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.Hashable +import Data.Int +import Data.Maybe +import Data.Serialize as S +import Data.String.Conversions +import Data.Time.Clock.System +import Data.Word +import GHC.Generics +import Haskoin +import Network.Socket (SockAddr) +import UnliftIO.Exception + +type UnixTime = Int64 + +newtype InitException = IncorrectVersion Word32 + deriving (Show, Read, Eq, Ord, Exception) + +class StoreRead r m where + isInitialized :: r -> m (Either InitException Bool) + getBestBlock :: r -> m (Maybe BlockHash) + getBlocksAtHeight :: r -> BlockHeight -> m [BlockHash] + getBlock :: r -> BlockHash -> m (Maybe BlockData) + getTransaction :: r -> TxHash -> m (Maybe Transaction) + getBalance :: r -> Address -> m Balance + +class StoreStream r m where + getMempool :: r -> ConduitT () (PreciseUnixTime, TxHash) m () + getAddressUnspents :: r -> Address -> ConduitT () Unspent m () + getAddressTxs :: r -> Address -> ConduitT () AddressTx m () + +class StoreWrite w m where + setInit :: w -> m () + setBest :: w -> BlockHash -> m () + insertBlock :: w -> BlockData -> m () + insertAtHeight :: w -> BlockHash -> BlockHeight -> m () + insertTx :: w -> Transaction -> m () + setBalance :: w -> Balance -> m () + insertAddrTx :: w -> AddressTx -> m () + removeAddrTx :: w -> AddressTx -> m () + insertAddrUnspent :: w -> Address -> Unspent -> m () + removeAddrUnspent :: w -> Address -> Unspent -> m () + insertMempoolTx :: w -> TxHash -> PreciseUnixTime -> m () + deleteMempoolTx :: w -> TxHash -> PreciseUnixTime -> m () + +-- | Unix time with nanosecond precision for mempool transactions +newtype PreciseUnixTime = PreciseUnixTime Word64 + deriving (Show, Eq, Read, Generic, Ord, Hashable, Serialize) + +preciseUnixTime :: SystemTime -> PreciseUnixTime +preciseUnixTime s = + PreciseUnixTime . fromIntegral $ + (systemSeconds s * 1000) + + (fromIntegral (systemNanoseconds s) `div` (1000 * 1000)) + +instance ToJSON PreciseUnixTime where + toJSON (PreciseUnixTime w) = toJSON w + toEncoding (PreciseUnixTime w) = toEncoding w + +-- | Reference to a block where a transaction is stored. +data BlockRef + = BlockRef { blockRefHeight :: !BlockHeight + -- ^ block height in the chain + , blockRefPos :: !Word32 + -- ^ position of transaction within the block + } + | MemRef { memRefTime :: !PreciseUnixTime } + deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable) + +-- | JSON serialization for 'BlockRef'. +blockRefPairs :: A.KeyValue kv => BlockRef -> [kv] +blockRefPairs BlockRef {blockRefHeight = h, blockRefPos = p} = + ["height" .= h, "position" .= p] +blockRefPairs MemRef {memRefTime = t} = ["mempool" .= t] + +confirmed :: BlockRef -> Bool +confirmed BlockRef {} = True +confirmed MemRef {} = False + +instance ToJSON BlockRef where + toJSON = object . blockRefPairs + toEncoding = pairs . mconcat . blockRefPairs + +-- | Transaction in relation to an address. +data AddressTx = AddressTx + { addressTxAddress :: !Address + -- ^ transaction address + , addressTxBlock :: !BlockRef + -- ^ block information + , addressTxHash :: !TxHash + -- ^ transaction hash + } deriving (Show, Eq, Ord, Generic, Serialize, Hashable) + +-- | JSON serialization for 'AddressTx'. +addressTxPairs :: A.KeyValue kv => Network -> AddressTx -> [kv] +addressTxPairs net atx = + [ "address" .= addrToJSON net (addressTxAddress atx) + , "txid" .= addressTxHash atx + , "block" .= addressTxBlock atx + ] + +addressTxToJSON :: Network -> AddressTx -> Value +addressTxToJSON net = object . addressTxPairs net + +addressTxToEncoding :: Network -> AddressTx -> Encoding +addressTxToEncoding net = pairs . mconcat . addressTxPairs net + +-- | Address balance information. +data Balance = Balance + { balanceAddress :: !Address + -- ^ address balance + , balanceAmount :: !Word64 + -- ^ confirmed balance + , balanceZero :: !Int64 + -- ^ unconfirmed balance (can be negative) + , balanceCount :: !Word64 + -- ^ number of unspent outputs + } deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable) + +-- | JSON serialization for 'Balance'. +balancePairs :: A.KeyValue kv => Network -> Balance -> [kv] +balancePairs net ab = + [ "address" .= addrToJSON net (balanceAddress ab) + , "confirmed" .= balanceAmount ab + , "unconfirmed" .= balanceZero ab + , "utxo" .= balanceCount ab + ] + +balanceToJSON :: Network -> Balance -> Value +balanceToJSON net = object . balancePairs net + +balanceToEncoding :: Network -> Balance -> Encoding +balanceToEncoding net = pairs . mconcat . balancePairs net + +-- | Unspent output. +data Unspent = Unspent + { unspentBlock :: !BlockRef + -- ^ block information for output + , unspentAmount :: !Word64 + -- ^ value of output in satoshi + , unspentScript :: !ByteString + -- ^ pubkey (output) script + , unspentPoint :: !OutPoint + -- ^ txid and index where output located + } deriving (Show, Eq, Ord, Generic, Serialize, Hashable) + +unspentPairs :: A.KeyValue kv => Network -> Unspent -> [kv] +unspentPairs net u = + [ "address" .= + eitherToMaybe (addrToJSON net <$> scriptToAddressBS (unspentScript u)) + , "block" .= unspentBlock u + , "txid" .= outPointHash (unspentPoint u) + , "index" .= outPointIndex (unspentPoint u) + , "pkscript" .= String (encodeHex (unspentScript u)) + , "value" .= unspentAmount u + ] + +unspentToJSON :: Network -> Unspent -> Value +unspentToJSON net = object . unspentPairs net + +unspentToEncoding :: Network -> Unspent -> Encoding +unspentToEncoding net = pairs . mconcat . unspentPairs net + +-- | Database value for a block entry. +data BlockData = BlockData + { blockDataHeight :: !BlockHeight + -- ^ height of the block in the chain + , blockDataMainChain :: !Bool + -- ^ is this block in the main chain? + , blockDataWork :: !BlockWork + -- ^ accumulated work in that block + , blockDataHeader :: !BlockHeader + -- ^ block header + , blockDataSize :: !Word32 + -- ^ size of the block including witnesses + , blockDataTxs :: ![TxHash] + -- ^ block transactions + } deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable) + +-- | JSON serialization for 'BlockData'. +blockDataPairs :: A.KeyValue kv => BlockData -> [kv] +blockDataPairs bv = + [ "hash" .= headerHash (blockDataHeader bv) + , "height" .= blockDataHeight bv + , "mainchain" .= blockDataMainChain bv + , "previous" .= prevBlock (blockDataHeader bv) + , "time" .= blockTimestamp (blockDataHeader bv) + , "version" .= blockVersion (blockDataHeader bv) + , "bits" .= blockBits (blockDataHeader bv) + , "nonce" .= bhNonce (blockDataHeader bv) + , "size" .= blockDataSize bv + , "tx" .= blockDataTxs bv + ] + +instance ToJSON BlockData where + toJSON = object . blockDataPairs + toEncoding = pairs . mconcat . blockDataPairs + +-- | Input information. +data Input + = Coinbase { inputPoint :: !OutPoint + -- ^ output being spent (should be null) + , inputSequence :: !Word32 + -- ^ sequence + , inputSigScript :: !ByteString + -- ^ input script data (not valid script) + , inputWitness :: !(Maybe WitnessStack) + -- ^ witness data for this input (only segwit) + } + -- ^ coinbase details + | Input { inputPoint :: !OutPoint + -- ^ output being spent + , inputSequence :: !Word32 + -- ^ sequence + , inputSigScript :: !ByteString + -- ^ signature (input) script + , inputPkScript :: !ByteString + -- ^ pubkey (output) script from previous tx + , inputAmount :: !Word64 + -- ^ amount in satoshi being spent spent + , inputWitness :: !(Maybe WitnessStack) + -- ^ witness data for this input (only segwit) + } + -- ^ input details + deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable) + +-- | Is 'Input' a Coinbase? +isCoinbase :: Input -> Bool +isCoinbase Coinbase {} = True +isCoinbase Input {} = False + +-- | JSON serialization for 'Input'. +inputPairs :: A.KeyValue kv => Network -> Input -> [kv] +inputPairs net Input { inputPoint = OutPoint oph opi + , inputSequence = sq + , inputSigScript = ss + , inputPkScript = ps + , inputAmount = val + , inputWitness = wit + } = + [ "coinbase" .= False + , "txid" .= oph + , "output" .= opi + , "sigscript" .= String (encodeHex ss) + , "sequence" .= sq + , "pkscript" .= String (encodeHex ps) + , "value" .= val + , "address" .= eitherToMaybe (addrToJSON net <$> scriptToAddressBS ps) + ] ++ + ["witness" .= fmap (map encodeHex) wit | getSegWit net] +inputPairs net Coinbase { inputPoint = OutPoint oph opi + , inputSequence = sq + , inputSigScript = ss + , inputWitness = wit + } = + [ "coinbase" .= False + , "txid" .= oph + , "output" .= opi + , "sigscript" .= String (encodeHex ss) + , "sequence" .= sq + , "pkscript" .= Null + , "value" .= Null + , "address" .= Null + ] ++ + ["witness" .= fmap (map encodeHex) wit | getSegWit net] + +inputToJSON :: Network -> Input -> Value +inputToJSON net = object . inputPairs net + +inputToEncoding :: Network -> Input -> Encoding +inputToEncoding net = pairs . mconcat . inputPairs net + +-- | Information about input spending output. +data Spender = Spender + { spenderHash :: !TxHash + -- ^ input transaction hash + , spenderIndex :: !Word32 + -- ^ input position in transaction + } deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable) + +-- | JSON serialization for 'Spender'. +spenderPairs :: A.KeyValue kv => Spender -> [kv] +spenderPairs n = + ["txid" .= spenderHash n, "input" .= spenderIndex n] + +instance ToJSON Spender where + toJSON = object . spenderPairs + toEncoding = pairs . mconcat . spenderPairs + +-- | Output information. +data Output = Output + { outputAmount :: !Word64 + -- ^ amount in satoshi + , outputScript :: !ByteString + -- ^ pubkey (output) script + , outputSpender :: !(Maybe Spender) + -- ^ input spending this transaction + } deriving (Show, Read, Eq, Ord, Generic, Serialize, Hashable) + +-- | JSON serialization for 'Output'. +outputPairs :: A.KeyValue kv => Network -> Output -> [kv] +outputPairs net d = + [ "address" .= + eitherToMaybe (addrToJSON net <$> scriptToAddressBS (outputScript d)) + , "pkscript" .= String (encodeHex (outputScript d)) + , "value" .= outputAmount d + , "spent" .= isJust (outputSpender d) + ] ++ + ["spender" .= outputSpender d | isJust (outputSpender d)] + +outputToJSON :: Network -> Output -> Value +outputToJSON net = object . outputPairs net + +outputToEncoding :: Network -> Output -> Encoding +outputToEncoding net = pairs . mconcat . outputPairs net + +-- | Detailed transaction information. +data Transaction = Transaction + { transactionBlock :: !BlockRef + -- ^ block information for this transaction + , transactionVersion :: !Word32 + -- ^ transaction version + , transactionLockTime :: !Word32 + -- ^ lock time + , transactionFee :: !Word64 + -- ^ transaction fees paid to miners in satoshi + , transactionInputs :: ![Input] + -- ^ transaction inputs + , transactionOutputs :: ![Output] + -- ^ transaction outputs + , transactionDeleted :: !Bool + -- ^ this transaction has been deleted and is no longer valid + , transactionRBF :: !Bool + -- ^ this transaction can be replaced in the mempool + } deriving (Show, Eq, Ord, Generic, Hashable, Serialize) + +transactionData :: Transaction -> Tx +transactionData t = + Tx + { txVersion = transactionVersion t + , txIn = map i (transactionInputs t) + , txOut = map o (transactionOutputs t) + , txWitness = mapMaybe inputWitness (transactionInputs t) + , txLockTime = transactionLockTime t + } + where + i Coinbase {inputPoint = p, inputSequence = q, inputSigScript = s} = + TxIn {prevOutput = p, scriptInput = s, txInSequence = q} + i Input {inputPoint = p, inputSequence = q, inputSigScript = s} = + TxIn {prevOutput = p, scriptInput = s, txInSequence = q} + o Output {outputAmount = v, outputScript = s} = + TxOut {outValue = v, scriptOutput = s} + +-- | JSON serialization for 'Transaction'. +transactionPairs :: A.KeyValue kv => Network -> Transaction -> [kv] +transactionPairs net dtx = + [ "txid" .= txHash (transactionData dtx) + , "size" .= B.length (S.encode (transactionData dtx)) + , "version" .= transactionVersion dtx + , "locktime" .= transactionLockTime dtx + , "fee" .= transactionFee dtx + , "inputs" .= map (object . inputPairs net) (transactionInputs dtx) + , "outputs" .= map (object . outputPairs net) (transactionOutputs dtx) + , "block" .= transactionBlock dtx + , "deleted" .= transactionDeleted dtx + ] ++ + ["rbf" .= transactionRBF dtx | getReplaceByFee net] + +transactionToJSON :: Network -> Transaction -> Value +transactionToJSON net = object . transactionPairs net + +transactionToEncoding :: Network -> Transaction -> Encoding +transactionToEncoding net = pairs . mconcat . transactionPairs net + +-- | Information about a connected peer. +data PeerInformation + = PeerInformation { peerUserAgent :: !ByteString + -- ^ user agent string + , peerAddress :: !SockAddr + -- ^ network address + , peerVersion :: !Word32 + -- ^ version number + , peerServices :: !Word64 + -- ^ services field + , peerRelay :: !Bool + -- ^ will relay transactions + } + deriving (Show, Eq, Ord, Generic) + +-- | JSON serialization for 'PeerInformation'. +peerInformationPairs :: A.KeyValue kv => PeerInformation -> [kv] +peerInformationPairs p = + [ "useragent" .= String (cs (peerUserAgent p)) + , "address" .= String (cs (show (peerAddress p))) + , "version" .= peerVersion p + , "services" .= peerServices p + , "relay" .= peerRelay p + ] + +instance ToJSON PeerInformation where + toJSON = object . peerInformationPairs + toEncoding = pairs . mconcat . peerInformationPairs diff --git a/src/Network/Haskoin/Store/Data/HashMap.hs b/src/Network/Haskoin/Store/Data/HashMap.hs new file mode 100644 --- /dev/null +++ b/src/Network/Haskoin/Store/Data/HashMap.hs @@ -0,0 +1,256 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-orphans #-} +module Network.Haskoin.Store.Data.HashMap where + +import Conduit +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as M +import Data.List +import Data.Maybe +import Haskoin +import Network.Haskoin.Store.Data +import Network.Haskoin.Store.Data.KeyValue +import UnliftIO + +data HashMapDB = HashMapDB + { hBest :: !(Maybe BlockHash) + , hBlock :: !(HashMap BlockHash BlockData) + , hHeight :: !(HashMap BlockHeight [BlockHash]) + , hTx :: !(HashMap TxHash Transaction) + , hBalance :: !(HashMap Address (Maybe BalVal)) + , hAddrTx :: !(HashMap Address (HashMap BlockRef (HashMap TxHash Bool))) + , hAddrOut :: !(HashMap Address (HashMap BlockRef (HashMap OutPoint (Maybe OutVal)))) + , hMempool :: !(HashMap PreciseUnixTime (HashMap TxHash Bool)) + , hInit :: !Bool + } deriving (Eq, Show) + +emptyHashMapDB :: HashMapDB +emptyHashMapDB = + HashMapDB + { hBest = Nothing + , hBlock = M.empty + , hHeight = M.empty + , hTx = M.empty + , hBalance = M.empty + , hAddrTx = M.empty + , hAddrOut = M.empty + , hMempool = M.empty + , hInit = False + } + +isInitializedH :: HashMapDB -> Either InitException Bool +isInitializedH = Right . hInit + +getBestBlockH :: HashMapDB -> Maybe BlockHash +getBestBlockH = hBest + +getBlocksAtHeightH :: + HashMapDB -> BlockHeight -> [BlockHash] +getBlocksAtHeightH db h = M.lookupDefault [] h (hHeight db) + +getBlockH :: HashMapDB -> BlockHash -> Maybe BlockData +getBlockH db h = M.lookup h (hBlock db) + +getTransactionH :: HashMapDB -> TxHash -> Maybe Transaction +getTransactionH db t = M.lookup t (hTx db) + +getBalanceH :: HashMapDB -> Address -> Maybe Balance +getBalanceH db a = + case M.lookup a (hBalance db) of + Nothing -> Nothing + Just Nothing -> + Just + Balance + { balanceAddress = a + , balanceAmount = 0 + , balanceZero = 0 + , balanceCount = 0 + } + Just (Just b) -> + Just + Balance + { balanceAddress = a + , balanceAmount = balValAmount b + , balanceZero = balValZero b + , balanceCount = balValCount b + } + +getMempoolH :: HashMapDB -> HashMap PreciseUnixTime (HashMap TxHash Bool) +getMempoolH = hMempool + +getAddressTxsH :: HashMapDB -> Address -> [Maybe AddressTx] +getAddressTxsH db a = + concatMap (uncurry f) . M.toList $ M.lookupDefault M.empty a (hAddrTx db) + where + f b hm = map (uncurry (g b)) $ M.toList hm + g b h True = + Just + AddressTx + {addressTxAddress = a, addressTxBlock = b, addressTxHash = h} + g _ _ False = Nothing + +getAddressUnspentsH :: + HashMapDB -> Address -> [Maybe Unspent] +getAddressUnspentsH db a = + concatMap (uncurry f) . M.toList $ M.lookupDefault M.empty a (hAddrOut db) + where + f b hm = map (uncurry (g b)) $ M.toList hm + g b p (Just u) = + Just + Unspent + { unspentBlock = b + , unspentAmount = outValAmount u + , unspentScript = outValScript u + , unspentPoint = p + } + g _ _ Nothing = Nothing + +setInitH :: HashMapDB -> HashMapDB +setInitH db = db {hInit = True} + +setBestH :: BlockHash -> HashMapDB -> HashMapDB +setBestH h db = db {hBest = Just h} + +insertBlockH :: BlockData -> HashMapDB -> HashMapDB +insertBlockH bd db = + db {hBlock = M.insert (headerHash (blockDataHeader bd)) bd (hBlock db)} + +insertAtHeightH :: BlockHash -> BlockHeight -> HashMapDB -> HashMapDB +insertAtHeightH h g db = db {hHeight = M.insertWith f g [h] (hHeight db)} + where + f xs ys = nub $ xs <> ys + +insertTxH :: Transaction -> HashMapDB -> HashMapDB +insertTxH tx db = db {hTx = M.insert (txHash (transactionData tx)) tx (hTx db)} + +setBalanceH :: Balance -> HashMapDB -> HashMapDB +setBalanceH b db = db {hBalance = M.insert (balanceAddress b) x (hBalance db)} + where + x = + case b of + Balance {balanceAmount = 0, balanceZero = 0, balanceCount = 0} -> + Nothing + Balance {balanceAmount = v, balanceZero = z, balanceCount = c} -> + Just BalVal {balValAmount = v, balValZero = z, balValCount = c} + +insertAddrTxH :: AddressTx -> HashMapDB -> HashMapDB +insertAddrTxH a db = + let s = + M.singleton + (addressTxAddress a) + (M.singleton + (addressTxBlock a) + (M.singleton (addressTxHash a) True)) + in db {hAddrTx = M.unionWith (M.unionWith M.union) s (hAddrTx db)} + +removeAddrTxH :: AddressTx -> HashMapDB -> HashMapDB +removeAddrTxH a db = + let s = + M.singleton + (addressTxAddress a) + (M.singleton + (addressTxBlock a) + (M.singleton (addressTxHash a) False)) + in db {hAddrTx = M.unionWith (M.unionWith M.union) s (hAddrTx db)} + +insertAddrUnspentH :: Address -> Unspent -> HashMapDB -> HashMapDB +insertAddrUnspentH a u db = + let uns = + OutVal + { outValAmount = unspentAmount u + , outValScript = 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)} + +removeAddrUnspentH :: Address -> Unspent -> HashMapDB -> HashMapDB +removeAddrUnspentH 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)} + +insertMempoolTxH :: TxHash -> PreciseUnixTime -> HashMapDB -> HashMapDB +insertMempoolTxH h u db = + let s = M.singleton u (M.singleton h True) + in db {hMempool = M.unionWith M.union s (hMempool db)} + +deleteMempoolTxH :: TxHash -> PreciseUnixTime -> HashMapDB -> HashMapDB +deleteMempoolTxH h u db = + let s = M.singleton u (M.singleton h False) + in db {hMempool = M.unionWith M.union s (hMempool db)} + +instance Applicative m => StoreRead HashMapDB m where + isInitialized = pure . isInitializedH + getBestBlock = pure . getBestBlockH + getBlocksAtHeight db = pure . getBlocksAtHeightH db + getBlock db = pure . getBlockH db + getTransaction db = pure . getTransactionH db + getBalance db a = pure . fromMaybe b $ getBalanceH db a + where + b = Balance { balanceAddress = a + , balanceAmount = 0 + , balanceZero = 0 + , balanceCount = 0 + } + +instance Monad m => StoreStream HashMapDB m where + getMempool db = + let ls = M.toList . M.map (M.keys . M.filter id) $ getMempoolH db + in yieldMany [(u, h) | (u, hs) <- ls, h <- hs] + getAddressTxs db = yieldMany . sort . catMaybes . getAddressTxsH db + getAddressUnspents db = + yieldMany . sort . catMaybes . getAddressUnspentsH db + +instance MonadIO m => StoreRead (TVar HashMapDB) m where + isInitialized v = atomically $ readTVar v >>= isInitialized + getBestBlock v = atomically $ readTVar v >>= getBestBlock + getBlocksAtHeight v h = + atomically $ readTVar v >>= \db -> getBlocksAtHeight db h + getBlock v b = atomically $ readTVar v >>= \db -> getBlock db b + getTransaction v t = atomically $ readTVar v >>= \db -> getTransaction db t + getBalance v t = atomically $ readTVar v >>= \db -> getBalance db t + +instance MonadIO m => StoreStream (TVar HashMapDB) m where + getMempool v = readTVarIO v >>= getMempool + getAddressTxs v a = readTVarIO v >>= \db -> getAddressTxs db a + getAddressUnspents v a = readTVarIO v >>= \db -> getAddressUnspents db a + +instance StoreWrite ((HashMapDB -> HashMapDB) -> m ()) m where + setInit f = f setInitH + setBest f = f . setBestH + insertBlock f = f . insertBlockH + insertAtHeight f h = f . insertAtHeightH h + insertTx f = f . insertTxH + setBalance f = f . setBalanceH + insertAddrTx f = f . insertAddrTxH + removeAddrTx f = f . removeAddrTxH + insertAddrUnspent f a = f . insertAddrUnspentH a + removeAddrUnspent f a = f . removeAddrUnspentH a + insertMempoolTx f h = f . insertMempoolTxH h + deleteMempoolTx f h = f . deleteMempoolTxH h + +instance MonadIO m => StoreWrite (TVar HashMapDB) m where + setInit v = atomically $ setInit (modifyTVar v) + setBest v = atomically . setBest (modifyTVar v) + insertBlock v = atomically . insertBlock (modifyTVar v) + insertAtHeight v h = atomically . insertAtHeight (modifyTVar v) h + insertTx v = atomically . insertTx (modifyTVar v) + setBalance v = atomically . setBalance (modifyTVar v) + insertAddrTx v = atomically . insertAddrTx (modifyTVar v) + removeAddrTx v = atomically . removeAddrTx (modifyTVar v) + insertAddrUnspent v a = atomically . insertAddrUnspent (modifyTVar v) a + removeAddrUnspent v a = atomically . removeAddrUnspent (modifyTVar v) a + insertMempoolTx v h = atomically . insertMempoolTx (modifyTVar v) h + deleteMempoolTx v h = atomically . deleteMempoolTx (modifyTVar v) h diff --git a/src/Network/Haskoin/Store/Data/ImportDB.hs b/src/Network/Haskoin/Store/Data/ImportDB.hs new file mode 100644 --- /dev/null +++ b/src/Network/Haskoin/Store/Data/ImportDB.hs @@ -0,0 +1,183 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Network.Haskoin.Store.Data.ImportDB where + +import Conduit +import Control.Applicative +import Control.Monad.Except +import Control.Monad.Trans.Maybe +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as M +import Data.List +import Database.RocksDB as R +import Database.RocksDB.Query as R +import Haskoin +import Network.Haskoin.Store.Data +import Network.Haskoin.Store.Data.HashMap +import Network.Haskoin.Store.Data.KeyValue +import Network.Haskoin.Store.Data.RocksDB +import UnliftIO + +data ImportDB = ImportDB + { importRocksDB :: !(DB, ReadOptions) + , importHashMap :: !(TVar HashMapDB) + } + +runImportDB :: + (MonadError e m, MonadIO m) + => DB + -> (ImportDB -> m a) + -> m a +runImportDB db f = do + hm <- newTVarIO emptyHashMapDB + x <- f ImportDB {importRocksDB = d, importHashMap = hm} + ops <- hashMapOps <$> readTVarIO hm + writeBatch db ops + return x + where + d = (db, defaultReadOptions) + +hashMapOps :: HashMapDB -> [BatchOp] +hashMapOps db = + bestBlockOp (hBest db) <> + blockHashOps (hBlock db) <> + blockHeightOps (hHeight db) <> + txOps (hTx db) <> + balOps (hBalance db) <> + addrTxOps (hAddrTx db) <> + addrOutOps (hAddrOut db) <> + mempoolOps (hMempool db) + +bestBlockOp :: Maybe BlockHash -> [BatchOp] +bestBlockOp Nothing = [] +bestBlockOp (Just b) = [insertOp BestKey b] + +blockHashOps :: HashMap BlockHash BlockData -> [BatchOp] +blockHashOps = map f . M.toList + where + f (h, d) = insertOp (BlockKey h) d + +blockHeightOps :: HashMap BlockHeight [BlockHash] -> [BatchOp] +blockHeightOps = map f . M.toList + where + f (g, ls) = insertOp (HeightKey g) ls + +txOps :: HashMap TxHash Transaction -> [BatchOp] +txOps = map f . M.toList + where + f (h, t) = insertOp (TxKey h) t + +balOps :: HashMap Address (Maybe BalVal) -> [BatchOp] +balOps = map (uncurry f) . M.toList + where + f a (Just b) = insertOp (BalKey a) b + f a Nothing = deleteOp (BalKey a) + +addrTxOps :: + HashMap Address (HashMap BlockRef (HashMap TxHash Bool)) -> [BatchOp] +addrTxOps = concat . concatMap (uncurry f) . M.toList + where + f a = map (uncurry (g a)) . M.toList + g a b = map (uncurry (h a b)) . M.toList + h a b t True = + insertOp + (AddrTxKey + { addrTxKey = + AddressTx + { addressTxAddress = a + , addressTxBlock = b + , addressTxHash = t + } + }) + () + h a b t False = + deleteOp + AddrTxKey + { addrTxKey = + AddressTx + { addressTxAddress = a + , addressTxBlock = b + , addressTxHash = t + } + } + +addrOutOps :: + HashMap Address (HashMap BlockRef (HashMap OutPoint (Maybe OutVal))) + -> [BatchOp] +addrOutOps = concat . concatMap (uncurry f) . M.toList + where + f a = map (uncurry (g a)) . M.toList + g a b = map (uncurry (h a b)) . M.toList + h a b p (Just l) = + insertOp + (AddrOutKey {addrOutKeyA = a, addrOutKeyB = b, addrOutKeyP = p}) + l + h a b p Nothing = + deleteOp AddrOutKey {addrOutKeyA = a, addrOutKeyB = b, addrOutKeyP = p} + +mempoolOps :: + HashMap PreciseUnixTime (HashMap TxHash Bool) -> [BatchOp] +mempoolOps = concatMap (uncurry f) . M.toList + where + f u = map (uncurry (g u)) . M.toList + g u t True = insertOp (MemKey u t) () + g u t False = deleteOp (MemKey u t) + +unspentOps :: HashMap OutPoint (Maybe OutVal) -> [BatchOp] +unspentOps = map (uncurry f) . M.toList + where + f p (Just o) = insertOp (UnspentKey p) o + f p Nothing = deleteOp (UnspentKey p) + +isInitializedI :: MonadIO m => ImportDB -> m (Either InitException Bool) +isInitializedI ImportDB {importRocksDB = db}= isInitialized db + +getBestBlockI :: MonadIO m => ImportDB -> m (Maybe BlockHash) +getBestBlockI ImportDB {importHashMap = hm, importRocksDB = db} = + runMaybeT $ MaybeT (getBestBlock hm) <|> MaybeT (getBestBlock db) + +getBlocksAtHeightI :: MonadIO m => ImportDB -> BlockHeight -> m [BlockHash] +getBlocksAtHeightI ImportDB {importHashMap = hm, importRocksDB = db} bh = do + xs <- getBlocksAtHeight hm bh + ys <- getBlocksAtHeight db bh + return . nub $ xs <> ys + +getBlockI :: MonadIO m => ImportDB -> BlockHash -> m (Maybe BlockData) +getBlockI ImportDB {importRocksDB = db, importHashMap = hm} bh = + runMaybeT $ MaybeT (getBlock hm bh) <|> MaybeT (getBlock db bh) + +getTransactionI :: + MonadIO m => ImportDB -> TxHash -> m (Maybe Transaction) +getTransactionI ImportDB {importRocksDB = db, importHashMap = hm} th = + runMaybeT $ MaybeT (getTransaction hm th) <|> MaybeT (getTransaction db th) + +getBalanceI :: MonadIO m => ImportDB -> Address -> m Balance +getBalanceI ImportDB {importRocksDB = db, importHashMap = hm} a = + getBalanceH <$> readTVarIO hm <*> pure a >>= \case + Just b -> return b + Nothing -> getBalance db a + +instance MonadIO m => StoreRead ImportDB m where + isInitialized = isInitializedI + getBestBlock = getBestBlockI + getBlocksAtHeight = getBlocksAtHeightI + getBlock = getBlockI + getTransaction = getTransactionI + getBalance = getBalanceI + +instance MonadIO m => StoreWrite ImportDB m where + setInit ImportDB {importHashMap = hm, importRocksDB = (db, _)} = + setInit hm >> setInitDB db + setBest ImportDB {importHashMap = hm} = setBest hm + insertBlock ImportDB {importHashMap = hm} = insertBlock hm + insertAtHeight ImportDB {importHashMap = hm} = insertAtHeight hm + insertTx ImportDB {importHashMap = hm} = insertTx hm + setBalance ImportDB {importHashMap = hm} = setBalance hm + insertAddrTx ImportDB {importHashMap = hm} = insertAddrTx hm + removeAddrTx ImportDB {importHashMap = hm} = removeAddrTx hm + insertAddrUnspent ImportDB {importHashMap = hm} = insertAddrUnspent hm + removeAddrUnspent ImportDB {importHashMap = hm} = removeAddrUnspent hm + insertMempoolTx ImportDB {importHashMap = hm} = insertMempoolTx hm + deleteMempoolTx ImportDB {importHashMap = hm} = deleteMempoolTx hm diff --git a/src/Network/Haskoin/Store/Data/KeyValue.hs b/src/Network/Haskoin/Store/Data/KeyValue.hs new file mode 100644 --- /dev/null +++ b/src/Network/Haskoin/Store/Data/KeyValue.hs @@ -0,0 +1,250 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Network.Haskoin.Store.Data.KeyValue where + +import Control.Monad.Reader +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.Default +import Data.Hashable +import Data.Int +import Data.Serialize as S +import Data.Word +import Database.RocksDB.Query +import GHC.Generics +import Haskoin +import Network.Haskoin.Store.Data + +-- | Database key for an address transaction. +data AddrTxKey + = AddrTxKey { addrTxKey :: !AddressTx } + -- ^ key for a transaction affecting an address + | AddrTxKeyA { addrTxKeyA :: !Address } + -- ^ short key that matches all entries + deriving (Show, Eq, Ord, Generic, Hashable) + +instance Serialize AddrTxKey + -- 0x05 · Address · Maybe (BlockHeight, BlockPos) · TxHash + where + put AddrTxKey {addrTxKey = AddressTx { addressTxAddress = a + , addressTxBlock = b + , addressTxHash = t + }} = do + putWord8 0x05 + put a + put b + put t + -- 0x05 · Address + put AddrTxKeyA {addrTxKeyA = a} = do + putWord8 0x05 + put a + get = do + guard . (== 0x05) =<< getWord8 + a <- get + b <- get + t <- get + return + AddrTxKey + { addrTxKey = + AddressTx + { addressTxAddress = a + , addressTxBlock = b + , addressTxHash = t + } + } + +instance Key AddrTxKey + +instance KeyValue AddrTxKey () + +-- | Database key for an address output. +data AddrOutKey + = AddrOutKey { addrOutKeyA :: !Address + , addrOutKeyB :: !BlockRef + , addrOutKeyP :: !OutPoint } + -- ^ full key + | AddrOutKeyA { addrOutKeyA :: !Address } + -- ^ short key for all spent or unspent outputs + deriving (Show, Read, Eq, Ord, Generic, Hashable) + +instance Serialize AddrOutKey where + -- 0x06 · StoreAddr · BlockHeight · MainChain · BlockPos · BlockHash · OutPoint + put AddrOutKey {addrOutKeyA = a, addrOutKeyB = b, addrOutKeyP = p} = do + putWord8 0x06 + put a + put b + put p + -- 0x06 · StoreAddr + put AddrOutKeyA {addrOutKeyA = a} = do + putWord8 0x06 + put a + get = do + guard . (== 0x06) =<< getWord8 + AddrOutKey <$> get <*> get <*> get + +instance Key AddrOutKey + +data OutVal = OutVal + { outValAmount :: !Word64 + , outValScript :: !ByteString + } deriving (Show, Read, Eq, Ord, Generic, Hashable, Serialize) + +instance KeyValue AddrOutKey OutVal + +-- | Transaction database key. +newtype TxKey = TxKey + { txKey :: TxHash + } deriving (Show, Read, Eq, Ord, Generic, Hashable) + +instance Serialize TxKey where + -- 0x02 · TxHash + put (TxKey h) = do + putWord8 0x02 + put h + get = do + guard . (== 0x02) =<< getWord8 + TxKey <$> get + +instance Key TxKey + +instance KeyValue TxKey Transaction + +-- | Unspent output database key. +newtype UnspentKey + = UnspentKey { unspentKey :: OutPoint } + deriving (Show, Read, Eq, Ord, Generic, Hashable) + +instance Serialize UnspentKey where + -- 0x09 · OutPoint + put UnspentKey {unspentKey = k} = do + putWord8 0x09 + put k + get = do + guard . (== 0x09) =<< getWord8 + UnspentKey <$> get + +instance Key UnspentKey + +instance KeyValue UnspentKey OutVal + +-- | Mempool transaction database key. +data MemKey + = MemKey { memTime :: !PreciseUnixTime, memKey :: !TxHash } + | MemKeyS + deriving (Show, Read, Eq, Ord, Generic, Hashable) + +instance Serialize MemKey where + -- 0x07 · TxHash + put (MemKey t h) = do + putWord8 0x07 + put t + put h + -- 0x07 + put MemKeyS = putWord8 0x07 + get = do + guard . (== 0x07) =<< getWord8 + MemKey <$> get <*> get + +instance Key MemKey +instance KeyValue MemKey () + +-- | Block entry database key. +newtype BlockKey = BlockKey + { blockKey :: BlockHash + } deriving (Show, Read, Eq, Ord, Generic, Hashable) + +instance Serialize BlockKey where + put (BlockKey h) = do + putWord8 0x01 + put h + get = do + guard . (== 0x01) =<< getWord8 + BlockKey <$> get + +instance KeyValue BlockKey BlockData + +-- | Block height database key. +newtype HeightKey = HeightKey + { heightKey :: BlockHeight + } deriving (Show, Read, Eq, Ord, Generic, Hashable) + +instance Serialize HeightKey where + -- 0x03 · BlockHeight + put (HeightKey height) = do + putWord8 0x03 + put height + get = do + guard . (== 0x03) =<< getWord8 + HeightKey <$> get + +instance Key HeightKey + +instance KeyValue HeightKey [BlockHash] + +-- | Address balance database key. +newtype BalKey + = BalKey { balanceKey :: Address } + deriving (Show, Read, Eq, Ord, Generic, Hashable) + +instance Serialize BalKey where + -- 0x04 · StoreAddr + put BalKey {balanceKey = a} = do + putWord8 0x04 + put a + get = do + guard . (== 0x04) =<< getWord8 + BalKey <$> get + +instance Key BalKey + +-- | Address balance database value. +data BalVal = BalVal + { balValAmount :: !Word64 + -- ^ balance in satoshi + , balValZero :: !Int64 + -- ^ unconfirmed balance in satoshi (can be negative) + , balValCount :: !Word64 + -- ^ number of unspent outputs + } deriving (Show, Read, Eq, Ord, Generic, Hashable, Serialize) + +-- | Default balance for an address. +instance Default BalVal where + def = BalVal {balValAmount = 0, balValZero = 0, balValCount = 0} + +instance KeyValue BalKey BalVal + +-- | Key for best block in database. +data BestKey = + BestKey + deriving (Show, Read, Eq, Ord, Generic, Hashable) + +instance Serialize BestKey where + -- 0x00 (x32) + put BestKey = put (B.replicate 32 0x00) + get = do + guard . (== B.replicate 32 0x00) =<< getBytes 32 + return BestKey + +instance Key BestKey + +instance KeyValue BestKey BlockHash + +-- | Key for database version. +data VersionKey = + VersionKey + deriving (Eq, Show, Read, Ord, Generic, Hashable) + +instance Serialize VersionKey where + -- 0x0a + put VersionKey = putWord8 0x0a + get = do + guard . (== 0x0a) =<< getWord8 + return VersionKey + +instance Key VersionKey + +instance KeyValue VersionKey Word32 diff --git a/src/Network/Haskoin/Store/Data/RocksDB.hs b/src/Network/Haskoin/Store/Data/RocksDB.hs new file mode 100644 --- /dev/null +++ b/src/Network/Haskoin/Store/Data/RocksDB.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# OPTIONS_GHC -Wno-orphans #-} +module Network.Haskoin.Store.Data.RocksDB where + +import Conduit +import Data.Maybe +import Data.Word +import Database.RocksDB (DB, ReadOptions) +import Database.RocksDB.Query +import Haskoin +import Network.Haskoin.Store.Data +import Network.Haskoin.Store.Data.KeyValue +import UnliftIO + +dataVersion :: Word32 +dataVersion = 5 + +data ExceptRocksDB = + MempoolTxNotFound + deriving (Eq, Show, Read, Exception) + +isInitializedDB :: MonadIO m => DB -> ReadOptions -> m (Either InitException Bool) +isInitializedDB db opts = + retrieve db opts VersionKey >>= \case + Just v + | v == dataVersion -> return (Right True) + | otherwise -> return (Left (IncorrectVersion v)) + Nothing -> return (Right False) + +getBestBlockDB :: MonadIO m => DB -> ReadOptions -> m (Maybe BlockHash) +getBestBlockDB db opts = retrieve db opts BestKey + +getBlocksAtHeightDB :: + MonadIO m => DB -> ReadOptions -> BlockHeight -> m [BlockHash] +getBlocksAtHeightDB db opts h = + retrieve db opts (HeightKey h) >>= \case + Nothing -> return [] + Just ls -> return ls + +getBlockDB :: MonadIO m => DB -> ReadOptions -> BlockHash -> m (Maybe BlockData) +getBlockDB db opts h = retrieve db opts (BlockKey h) + +getTransactionDB :: + MonadIO m => DB -> ReadOptions -> TxHash -> m (Maybe Transaction) +getTransactionDB db opts th = retrieve db opts (TxKey th) + +getBalanceDB :: MonadIO m => DB -> ReadOptions -> Address -> m (Maybe Balance) +getBalanceDB db opts a = fmap f <$> retrieve db opts (BalKey a) + where + f BalVal {balValAmount = v, balValZero = z, balValCount = c} = + Balance + { balanceAddress = a + , balanceAmount = v + , balanceZero = z + , balanceCount = c + } + +getMempoolDB :: + (MonadIO m, MonadResource m) + => DB + -> ReadOptions + -> ConduitT () (PreciseUnixTime, TxHash) m () +getMempoolDB db opts = matching db opts MemKeyS .| mapC (uncurry f) + where + f (MemKey u t) () = (u, t) + f _ _ = undefined + +getAddressTxsDB :: + (MonadIO m, MonadResource m) + => DB + -> ReadOptions + -> Address + -> ConduitT () AddressTx m () +getAddressTxsDB db opts a = + matching db opts (AddrTxKeyA a) .| mapC (uncurry f) + where + f AddrTxKey {addrTxKey = t} () = t + f _ _ = undefined + +getAddressUnspentsDB :: + (MonadIO m, MonadResource m) + => DB + -> ReadOptions + -> Address + -> ConduitT () Unspent m () +getAddressUnspentsDB db opts a = + matching db opts (AddrOutKeyA a) .| mapC (uncurry f) + where + f AddrOutKey { addrOutKeyB = b + , addrOutKeyP = p + } + OutVal { outValAmount = v + , outValScript = s + } = + Unspent + { unspentBlock = b + , unspentAmount = v + , unspentScript = s + , unspentPoint = p + } + f _ _ = undefined + +instance MonadIO m => StoreRead (DB, ReadOptions) m where + isInitialized (db, opts) = isInitializedDB db opts + getBestBlock (db, opts) = getBestBlockDB db opts + getBlocksAtHeight (db, opts) = getBlocksAtHeightDB db opts + getBlock (db, opts) = getBlockDB db opts + getTransaction (db, opts) = getTransactionDB db opts + getBalance (db, opts) a = fromMaybe b <$> getBalanceDB db opts a + where + b = + Balance + { balanceAddress = a + , balanceAmount = 0 + , balanceZero = 0 + , balanceCount = 0 + } + +instance (MonadIO m, MonadResource m) => StoreStream (DB, ReadOptions) m where + getMempool (db, opts) = getMempoolDB db opts + getAddressTxs (db, opts) = getAddressTxsDB db opts + getAddressUnspents (db, opts) = getAddressUnspentsDB db opts + +setInitDB :: MonadIO m => DB -> m () +setInitDB db = insert db VersionKey dataVersion diff --git a/src/Network/Haskoin/Store/Logic.hs b/src/Network/Haskoin/Store/Logic.hs new file mode 100644 --- /dev/null +++ b/src/Network/Haskoin/Store/Logic.hs @@ -0,0 +1,575 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +module Network.Haskoin.Store.Logic where + +import Control.Monad +import Control.Monad.Except +import qualified Data.ByteString as B +import Data.List +import Data.Maybe +import Data.Serialize +import Data.Word +import Database.RocksDB +import Haskoin +import Network.Haskoin.Store.Data +import Network.Haskoin.Store.Data.ImportDB +import UnliftIO + +data ImportException + = PrevBlockNotBest !BlockHash + | BestBlockUnknown + | BestBlockNotFound !BlockHash + | BlockNotBest !BlockHash + | TxNotFound !TxHash + | DuplicateTx !TxHash + | TxDeleted !TxHash + | TxDoubleSpend !TxHash + | TxOutputsSpent !TxHash + | TxConfirmed !TxHash + | OutputOutOfRange !OutPoint + | OutputAlreadyUnspent !OutPoint + | OutputAlreadySpent !OutPoint + | OutputDoesNotExist !OutPoint + | BalanceNotFound !Address + | InsufficientBalance !Address + | InsufficientOutputs !Address + | InsufficientFunds !TxHash + | InitException !InitException + | DuplicatePrevOutput !TxHash + deriving (Show, Read, Eq, Ord, Exception) + +initDB :: (MonadIO m, MonadError ImportException m) => Network -> DB -> m () +initDB net db = + runImportDB db $ \i -> + isInitialized i >>= \case + Left e -> throwError (InitException e) + Right True -> return () + Right False -> do + importBlock net i (genesisBlock net) (genesisNode net) + setInit i + +newMempoolTx :: + (MonadError ImportException m, StoreRead i m, StoreWrite i m) + => Network + -> i + -> Tx + -> PreciseUnixTime + -> m () +newMempoolTx net i tx now = + getTransaction i (txHash tx) >>= \case + Just _ -> throwError (DuplicateTx (txHash tx)) + Nothing -> go + where + go = do + orp <- + any isNothing <$> + mapM (getTransaction i . outPointHash . prevOutput) (txIn tx) + unless orp f + f = do + us <- + forM (txIn tx) $ \TxIn {prevOutput = op} -> do + t <- getImportTx i (outPointHash op) + getTxOutput (outPointIndex op) t + let ds = map spenderHash (mapMaybe outputSpender us) + if null ds + then importTx net i (MemRef now) tx + else g ds + g ds = do + rbf <- + if getReplaceByFee net + then and <$> mapM isrbf ds + else return False + if rbf + then r ds + else n + r ds = do + forM_ ds (recursiveDeleteTx net i) + importTx net i (MemRef now) tx + n = insertDeletedMempoolTx i tx now + isrbf th = transactionRBF <$> getImportTx i th + +newBlock :: + (MonadError ImportException m, MonadIO m) + => Network + -> DB + -> Block + -> BlockNode + -> m () +newBlock net db b n = runImportDB db $ \i -> importBlock net i b n + +revertBlock :: + (MonadError ImportException m, StoreRead i m, StoreWrite i m) + => i + -> BlockHash + -> m () +revertBlock i bh = do + bd <- + getBestBlock i >>= \case + Nothing -> throwError BestBlockUnknown + Just h -> + getBlock i h >>= \case + Nothing -> throwError (BestBlockNotFound h) + Just b + | h == bh -> return b + | otherwise -> throwError (BlockNotBest bh) + forM_ (blockDataTxs bd) $ deleteTx i False + setBest i (prevBlock (blockDataHeader bd)) + insertBlock i bd {blockDataMainChain = False} + +importBlock :: + (MonadError ImportException m, StoreRead i m, StoreWrite i m) + => Network + -> i + -> Block + -> BlockNode + -> m () +importBlock net i b n = do + getBestBlock i >>= \case + Nothing + | isGenesis n -> return () + | otherwise -> throwError BestBlockUnknown + Just h + | prevBlock (blockHeader b) == h -> return () + | otherwise -> + throwError (PrevBlockNotBest (prevBlock (nodeHeader n))) + insertBlock + i + BlockData + { blockDataHeight = nodeHeight n + , blockDataMainChain = True + , blockDataWork = nodeWork n + , blockDataHeader = nodeHeader n + , blockDataSize = fromIntegral (B.length (encode b)) + , blockDataTxs = map txHash (blockTxns b) + } + insertAtHeight i (headerHash (nodeHeader n)) (nodeHeight n) + setBest i (headerHash (nodeHeader n)) + txs <- concat <$> mapM (getRecursiveTx i . txHash) (tail (blockTxns b)) + mapM_ (deleteTx i False . txHash . transactionData) (reverse txs) + zipWithM_ (\x t -> importTx net i (br x) t) [0 ..] (blockTxns b) + forM_ txs $ \tr -> do + let tx = transactionData tr + when (tx `notElem` blockTxns b) $ + case transactionBlock tr of + MemRef t -> newMempoolTx net i tx t + BlockRef {} -> throwError (TxConfirmed (txHash tx)) + where + br pos = BlockRef {blockRefHeight = nodeHeight n, blockRefPos = pos} + +importTx :: + ( MonadError ImportException m + , StoreRead i m + , StoreWrite i m + ) + => Network + -> i + -> BlockRef + -> Tx + -> m () +importTx net i br tx = + getTransaction i th >>= \case + Just t + | not (transactionDeleted t) -> throwError (DuplicateTx th) + | otherwise -> go + Nothing -> go + where + th = txHash tx + go = do + when (length (nub (map prevOutput (txIn tx))) < length (txIn tx)) $ + throwError (DuplicatePrevOutput (txHash tx)) + us <- + if iscb + then return [] + else forM (txIn tx) $ \TxIn {prevOutput = op} -> + getImportTx i (outPointHash op) >>= + getTxOutput (outPointIndex op) + unless iscb $ do + when (sum (map outputAmount us) < sum (map outValue (txOut tx))) $ + throwError (InsufficientFunds th) + when (confirmed br && any (isJust . outputSpender) us) $ do + let ds = map spenderHash (mapMaybe outputSpender us) + mapM_ (recursiveDeleteTx net i) ds + when (not (confirmed br) && any (isJust . outputSpender) us) $ + throwError (TxDoubleSpend th) + zipWithM_ + (spendOutput i br (txHash tx)) + [0 ..] + (map prevOutput (txIn tx)) + zipWithM_ (insertOutput i br (txHash tx)) [0 ..] (txOut tx) + rbf <- getrbf + insertTx + i + Transaction + { transactionBlock = br + , transactionVersion = txVersion tx + , transactionLockTime = txLockTime tx + , transactionFee = fee us + , transactionInputs = + if iscb + then zipWith mkcb (txIn tx) ws + else zipWith3 mkin us (txIn tx) ws + , transactionOutputs = map mkout (txOut tx) + , transactionDeleted = False + , transactionRBF = rbf + } + unless (confirmed br) $ insertMempoolTx i (txHash tx) (memRefTime br) + iscb = all (== nullOutPoint) (map prevOutput (txIn tx)) + fee us = + if iscb + then 0 + else sum (map outputAmount us) - sum (map outValue (txOut tx)) + ws = map Just (txWitness tx) <> repeat Nothing + getrbf + | iscb = return False + | any ((< 0xffffffff - 1) . txInSequence) (txIn tx) = return True + | otherwise = + let hs = nub $ map (outPointHash . prevOutput) (txIn tx) + in fmap or . forM hs $ \h -> + getTransaction i h >>= \case + Nothing -> throwError (TxNotFound h) + Just t + | confirmed (transactionBlock t) -> return False + | transactionRBF t -> return True + | otherwise -> return False + mkcb ip w = + Coinbase + { inputPoint = prevOutput ip + , inputSequence = txInSequence ip + , inputSigScript = scriptInput ip + , inputWitness = w + } + mkin u ip w = + Input + { inputPoint = prevOutput ip + , inputSequence = txInSequence ip + , inputSigScript = scriptInput ip + , inputPkScript = outputScript u + , inputAmount = outputAmount u + , inputWitness = w + } + mkout o = + Output + { outputAmount = outValue o + , outputScript = scriptOutput o + , outputSpender = Nothing + } + +getRecursiveTx :: (Monad m, StoreRead i m) => i -> TxHash -> m [Transaction] +getRecursiveTx i th = + getTransaction i th >>= \case + Nothing -> return [] + Just t -> + fmap (t :) $ do + let ss = + nub + (map spenderHash + (mapMaybe outputSpender (transactionOutputs t))) + concat <$> mapM (getRecursiveTx i) ss + + +recursiveDeleteTx :: + (MonadError ImportException m, StoreRead i m, StoreWrite i m) + => Network + -> i + -> TxHash + -> m () +recursiveDeleteTx net i th = + getTransaction i th >>= \case + Nothing -> throwError (TxNotFound th) + Just tx + | not (transactionDeleted tx) -> do + let ss = + map + spenderHash + (mapMaybe outputSpender (transactionOutputs tx)) + forM_ ss (recursiveDeleteTx net i) + deleteTx i True th + | otherwise -> throwError (TxDeleted th) + +deleteTx :: + (MonadError ImportException m, StoreRead i m, StoreWrite i m) + => i + -> Bool -- ^ only delete transaction if unconfirmed + -> TxHash + -> m () +deleteTx i mo h = + getTransaction i h >>= \case + Nothing -> throwError (TxNotFound h) + Just t + | not (transactionDeleted t) -> + if mo && confirmed (transactionBlock t) + then throwError (TxConfirmed h) + else go t + | otherwise -> throwError (TxDeleted h) + where + go t = do + when (any (isJust . outputSpender) (transactionOutputs t)) $ + throwError (TxOutputsSpent h) + forM_ (take (length (transactionOutputs t)) [0 ..]) $ \n -> + deleteOutput i (OutPoint h n) + forM_ (map inputPoint (transactionInputs t)) $ \op -> + unspendOutput i op (transactionBlock t) + unless (confirmed (transactionBlock t)) $ + deleteMempoolTx i h (memRefTime (transactionBlock t)) + insertTx i t {transactionDeleted = True} + +insertDeletedMempoolTx :: + (MonadError ImportException m, StoreRead i m, StoreWrite i m) + => i + -> Tx + -> PreciseUnixTime + -> m () +insertDeletedMempoolTx i tx now = do + us <- + forM (txIn tx) $ \TxIn {prevOutput = op} -> + getImportTx i (outPointHash op) >>= getTxOutput (outPointIndex op) + rbf <- getrbf + insertTx + i + Transaction + { transactionBlock = MemRef now + , transactionVersion = txVersion tx + , transactionLockTime = txLockTime tx + , transactionFee = fee us + , transactionInputs = zipWith3 mkin us (txIn tx) ws + , transactionOutputs = map mkout (txOut tx) + , transactionDeleted = True + , transactionRBF = rbf + } + where + ws = map Just (txWitness tx) <> repeat Nothing + getrbf + | any ((< 0xffffffff - 1) . txInSequence) (txIn tx) = return True + | otherwise = + let hs = nub $ map (outPointHash . prevOutput) (txIn tx) + in fmap or . forM hs $ \h -> + getTransaction i h >>= \case + Nothing -> throwError (TxNotFound h) + Just t + | confirmed (transactionBlock t) -> return False + | transactionRBF t -> return True + | otherwise -> return False + fee us = sum (map outputAmount us) - sum (map outValue (txOut tx)) + mkin u ip w = + Input + { inputPoint = prevOutput ip + , inputSequence = txInSequence ip + , inputSigScript = scriptInput ip + , inputPkScript = outputScript u + , inputAmount = outputAmount u + , inputWitness = w + } + mkout o = + Output + { outputAmount = outValue o + , outputScript = scriptOutput o + , outputSpender = Nothing + } + +insertOutput :: + (MonadError ImportException m, StoreRead i m, StoreWrite i m) + => i + -> BlockRef + -> TxHash + -> Word32 + -> TxOut + -> m () +insertOutput i tb th ix to = + case scriptToAddressBS (scriptOutput to) of + Left _ -> return () + Right a -> do + insertAddrUnspent i a u + insertAddrTx + i + AddressTx + { addressTxAddress = a + , addressTxHash = th + , addressTxBlock = tb + } + increaseBalance i (confirmed tb) a (outValue to) + where + u = + Unspent + { unspentBlock = tb + , unspentAmount = outValue to + , unspentScript = scriptOutput to + , unspentPoint = OutPoint th ix + } + +deleteOutput :: + (MonadError ImportException m, StoreRead i m, StoreWrite i m) + => i + -> OutPoint + -> m () +deleteOutput i op = do + t <- getImportTx i (outPointHash op) + u <- getTxOutput (outPointIndex op) t + case scriptToAddressBS (outputScript u) of + Left _ -> return () + Right a -> do + removeAddrUnspent + i + a + Unspent + { unspentScript = outputScript u + , unspentBlock = transactionBlock t + , unspentPoint = op + , unspentAmount = outputAmount u + } + removeAddrTx + i + AddressTx + { addressTxAddress = a + , addressTxHash = outPointHash op + , addressTxBlock = transactionBlock t + } + reduceBalance + i + (confirmed (transactionBlock t)) + a + (outputAmount u) + +getImportTx :: + (MonadError ImportException m, StoreRead i m) + => i + -> TxHash + -> m Transaction +getImportTx i th = + getTransaction i th >>= \case + Nothing -> throwError $ TxNotFound th + Just t + | transactionDeleted t -> throwError $ TxDeleted th + | otherwise -> return t + +getTxOutput :: + (MonadError ImportException m) => Word32 -> Transaction -> m Output +getTxOutput i tx = do + unless (fromIntegral i < length (transactionOutputs tx)) $ + throwError $ + OutputOutOfRange + OutPoint + {outPointHash = txHash (transactionData tx), outPointIndex = i} + return $ transactionOutputs tx !! fromIntegral i + +spendOutput :: + (MonadError ImportException m, StoreRead i m, StoreWrite i m) + => i + -> BlockRef + -> TxHash + -> Word32 + -> OutPoint + -> m () +spendOutput i tb th ix op = do + tx <- getImportTx i (outPointHash op) + out <- getTxOutput (outPointIndex op) tx + when (isJust (outputSpender out)) $ throwError (OutputAlreadySpent op) + insertTx + i + tx {transactionOutputs = zipWith f [0 ..] (transactionOutputs tx)} + case scriptToAddressBS (outputScript out) of + Left _ -> return () + Right a -> do + removeAddrUnspent + i + a + Unspent + { unspentScript = outputScript out + , unspentAmount = outputAmount out + , unspentBlock = transactionBlock tx + , unspentPoint = op + } + reduceBalance i (confirmed tb) a (outputAmount out) + insertAddrTx + i + AddressTx + { addressTxAddress = a + , addressTxHash = th + , addressTxBlock = tb + } + where + f n o + | n == outPointIndex op = o {outputSpender = Just (Spender th ix)} + | otherwise = o + +unspendOutput :: + (MonadError ImportException m, StoreRead i m, StoreWrite i m) + => i + -> OutPoint + -> BlockRef + -> m () +unspendOutput i op br = do + tx <- getImportTx i (outPointHash op) + out <- getTxOutput (outPointIndex op) tx + when (isNothing (outputSpender out)) $ throwError (OutputAlreadyUnspent op) + insertTx + i + tx {transactionOutputs = zipWith f [0 ..] (transactionOutputs tx)} + let u = + Unspent + { unspentAmount = outputAmount out + , unspentBlock = transactionBlock tx + , unspentScript = outputScript out + , unspentPoint = op + } + case scriptToAddressBS (outputScript out) of + Left _ -> return () + Right a -> do + insertAddrUnspent i a u + increaseBalance i (confirmed br) a (outputAmount out) + where + f n o + | n == outPointIndex op = o {outputSpender = Nothing} + | otherwise = o + +reduceBalance :: + (MonadError ImportException m, StoreRead i m, StoreWrite i m) + => i + -> Bool -- ^ confirmed + -> Address + -> Word64 + -> m () +reduceBalance i c a v = do + b <- getBalance i a + setBalance i =<< + if c + then do + unless (v <= balanceAmount b) $ + throwError (InsufficientBalance a) + unless (balanceCount b > 0) $ throwError (InsufficientOutputs a) + return + b + { balanceAmount = balanceAmount b - v + , balanceCount = balanceCount b - 1 + } + else do + unless + (fromIntegral v <= + fromIntegral (balanceAmount b) + balanceZero b) $ + throwError (InsufficientBalance a) + unless (balanceCount b > 0) $ throwError (InsufficientOutputs a) + return + b + { balanceZero = balanceZero b - fromIntegral v + , balanceCount = balanceCount b - 1 + } + +increaseBalance :: + (MonadError ImportException m, StoreRead i m, StoreWrite i m) + => i + -> Bool -- ^ confirmed + -> Address + -> Word64 + -> m () +increaseBalance i c a v = do + b <- getBalance i a + setBalance i $ + if c + then b + { balanceAmount = balanceAmount b + v + , balanceCount = balanceCount b + 1 + } + else b + { balanceZero = balanceZero b + fromIntegral v + , balanceCount = balanceCount b + 1 + } diff --git a/src/Network/Haskoin/Store/Messages.hs b/src/Network/Haskoin/Store/Messages.hs new file mode 100644 --- /dev/null +++ b/src/Network/Haskoin/Store/Messages.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Network.Haskoin.Store.Messages where + +import Data.Word +import Database.RocksDB (DB) +import Haskoin +import Haskoin.Node +import Network.Socket +import NQE + +-- | Mailbox for block store. +type BlockStore = Mailbox BlockMessage + +-- | Store mailboxes. +data Store = Store + { storeManager :: !Manager + -- ^ peer manager mailbox + , storeChain :: !Chain + -- ^ chain header process mailbox + , storeBlock :: !BlockStore + -- ^ block storage mailbox + } + +-- | Configuration for a 'Store'. +data StoreConfig = StoreConfig + { storeConfMaxPeers :: !Int + -- ^ max peers to connect to + , storeConfInitPeers :: ![HostPort] + -- ^ static set of peers to connect to + , storeConfDiscover :: !Bool + -- ^ discover new peers? + , storeConfDB :: !DB + -- ^ RocksDB database handler + , storeConfNetwork :: !Network + -- ^ network constants + , storeConfListen :: !(Listen StoreEvent) + } + +-- | Configuration for a block store. +data BlockConfig = BlockConfig + { blockConfManager :: !Manager + -- ^ peer manager from running node + , blockConfChain :: !Chain + -- ^ chain from a running node + , blockConfListener :: !(Listen StoreEvent) + -- ^ listener for store events + , blockConfDB :: !DB + -- ^ RocksDB database handle + , blockConfNet :: !Network + -- ^ network constants + } + +-- | Messages that a 'BlockStore' can accept. +data BlockMessage + = BlockNewBest !BlockNode + -- ^ new block header in chain + | BlockPeerConnect !Peer + !SockAddr + -- ^ new peer connected + | BlockPeerDisconnect !Peer + !SockAddr + -- ^ peer disconnected + | BlockReceived !Peer + !Block + -- ^ new block received from a peer + | BlockNotFound !Peer + ![BlockHash] + -- ^ block not found + | BlockTxReceived !Peer + !Tx + -- ^ transaction received from peer + | BlockTxAvailable !Peer + ![TxHash] + -- ^ peer has transactions available + | BlockPing + -- ^ internal housekeeping ping + | PurgeMempool + -- ^ purge mempool transactions + +-- | Events that the store can generate. +data StoreEvent + = StoreBestBlock !BlockHash + -- ^ new best block + | StoreMempoolNew !TxHash + -- ^ new mempool transaction + | StorePeerConnected !Peer + !SockAddr + -- ^ new peer connected + | StorePeerDisconnected !Peer + !SockAddr + -- ^ peer has disconnected + | StorePeerPong !Peer + !Word64 + -- ^ peer responded 'Ping' + diff --git a/src/Network/Haskoin/Store/Types.hs b/src/Network/Haskoin/Store/Types.hs deleted file mode 100644 --- a/src/Network/Haskoin/Store/Types.hs +++ /dev/null @@ -1,982 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -module Network.Haskoin.Store.Types where - -import Control.Applicative -import Control.Exception -import Control.Monad.Reader -import Data.Aeson as A -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import Data.Function -import Data.Int -import Data.Maybe -import Data.Serialize as S -import Data.String.Conversions -import Data.Word -import Database.RocksDB (DB) -import Database.RocksDB.Query as R -import Haskoin -import Haskoin.Node -import NQE - --- | Reasons why a transaction may not get imported. -data TxException - = DoubleSpend - -- ^ outputs already spent by another transaction - | OverSpend - -- ^ outputs larger than inputs - | OrphanTx - -- ^ inputs unknown - | NonStandard - -- ^ non-standard transaction rejected by peer - | LowFee - -- ^ pony up - | Dust - -- ^ an output is too small - | NoPeers - -- ^ no peers to send the transaction to - | InvalidTx - -- ^ transaction is invalid in some other way - | CouldNotImport - -- ^ could not import for an unknown reason - | PeerIsGone - -- ^ the peer that got the transaction disconnected - | AlreadyImported - -- ^ the transaction is already in the database - | PublishTimeout - -- ^ some timeout was reached while publishing - | PeerRejectOther - -- ^ peer rejected transaction for unknown reason - | NotAtHeight - -- ^ this node is not yet synchronized - deriving (Eq) - -instance Show TxException where - show InvalidTx = "invalid" - show DoubleSpend = "double-spend" - show OverSpend = "not enough funds" - show OrphanTx = "orphan" - show AlreadyImported = "already imported" - show NoPeers = "no peers" - show NonStandard = "non-standard" - show LowFee = "low fee" - show Dust = "dust" - show PeerIsGone = "peer disconnected" - show CouldNotImport = "could not import" - show PublishTimeout = "publish timeout" - show PeerRejectOther = "peer rejected for unknown reason" - show NotAtHeight = "not at height" - -instance Exception TxException - --- | Wrapper for an transaction that can be deserialized from a JSON object. -newtype NewTx = NewTx - { newTx :: Tx - } deriving (Show, Eq, Ord) - --- | Configuration for a block store. -data BlockConfig = BlockConfig - { blockConfMailbox :: !BlockStore - -- ^ block store mailbox - , blockConfManager :: !Manager - -- ^ peer manager from running node - , blockConfChain :: !Chain - -- ^ chain from a running node - , blockConfListener :: !(Listen StoreEvent) - -- ^ listener for store events - , blockConfDB :: !DB - -- ^ RocksDB database handle - , blockConfNet :: !Network - -- ^ network constants - } - --- | Event that the store can generate. -data StoreEvent - = BestBlock !BlockHash - -- ^ new best block - | MempoolNew !TxHash - -- ^ new mempool transaction - | TxException !TxHash - !TxException - -- ^ published tx could not be imported - | PeerConnected !Peer - -- ^ new peer connected - | PeerDisconnected !Peer - -- ^ peer has disconnected - | PeerPong !Peer - !Word64 - -- ^ peer responded 'Ping' - --- | Messages that a 'BlockStore' can accept. -data BlockMessage - = BlockChainNew !BlockNode - -- ^ new block header in chain - | BlockPeerConnect !Peer - -- ^ new peer connected - | BlockPeerDisconnect !Peer - -- ^ peer disconnected - | BlockReceived !Peer - !Block - -- ^ new block received from a peer - | BlockNotReceived !Peer - !BlockHash - -- ^ peer could not deliver a block - | TxReceived !Peer - !Tx - -- ^ transaction received from a peer - | TxAvailable !Peer - ![TxHash] - -- ^ peer has transactions available - | TxPublished !Tx - -- ^ transaction has been published successfully - | PongReceived !Peer - !Word64 - -- ^ peer responded to a 'Ping' - --- | Mailbox for block store. -type BlockStore = Inbox BlockMessage - --- | Database key for an address transaction. -data AddrTxKey - = AddrTxKey { addrTxKey :: !Address - , addrTxHeight :: !(Maybe BlockHeight) - , addrTxPos :: !(Maybe Word32) - , addrTxHash :: !TxHash } - -- ^ key for a transaction affecting an address - | ShortAddrTxKey { addrTxKey :: !Address } - | ShortAddrTxKeyHeight { addrTxKey :: !Address - , addrTxHeight :: !(Maybe BlockHeight)} - -- ^ short key that matches all entries - deriving (Show, Eq) - --- | Database key for an address output. -data AddrOutKey - = AddrOutKey { addrOutputAddress :: !Address - , addrOutputHeight :: !(Maybe BlockHeight) - , addrOutputPos :: !(Maybe Word32) - , addrOutPoint :: !OutPoint } - -- ^ full key - | ShortAddrOutKey { addrOutputAddress :: !Address } - -- ^ short key for all spent or unspent outputs - | ShortAddrOutKeyHeight { addrOutputAddress :: !Address - , addrOutputHeight :: !(Maybe BlockHeight) } - -- ^ short key for all outputs at a given height - deriving (Show, Eq) - -instance Ord AddrOutKey where - compare = compare `on` f - where - f AddrOutKey {..} = - ( fromMaybe maxBound addrOutputHeight - , fromMaybe maxBound addrOutputPos - , outPointIndex addrOutPoint) - f _ = undefined - --- | Database value for a block entry. -data BlockValue = BlockValue - { blockValueHeight :: !BlockHeight - -- ^ height of the block in the chain - , blockValueWork :: !BlockWork - -- ^ accumulated work in that block - , blockValueHeader :: !BlockHeader - -- ^ block header - , blockValueSize :: !Word32 - -- ^ size of the block including witnesses - , blockValueTxs :: ![TxHash] - -- ^ block transactions - } deriving (Show, Eq, Ord) - --- | Reference to a block where a transaction is stored. -data BlockRef = BlockRef - { blockRefHash :: !BlockHash - -- ^ block header hash - , blockRefHeight :: !BlockHeight - -- ^ block height in the chain - , blockRefPos :: !Word32 - -- ^ position of transaction within the block - } deriving (Show, Eq) - -instance Ord BlockRef where - compare = compare `on` f - where - f BlockRef {..} = (blockRefHeight, blockRefPos) - --- | Detailed transaction information. -data DetailedTx = DetailedTx - { detailedTxData :: !Tx - -- ^ 'Tx' object - , detailedTxFee :: !Word64 - -- ^ transaction fees paid to miners in satoshi - , detailedTxInputs :: ![DetailedInput] - -- ^ transaction inputs - , detailedTxOutputs :: ![DetailedOutput] - -- ^ transaction outputs - , detailedTxBlock :: !(Maybe BlockRef) - -- ^ block information for this transaction - } deriving (Show, Eq) - --- | Input information. -data DetailedInput - = DetailedCoinbase { detInOutPoint :: !OutPoint - -- ^ output being spent (should be zeroes) - , detInSequence :: !Word32 - -- ^ sequence - , detInSigScript :: !ByteString - -- ^ input script data (not valid script) - , detInNetwork :: !Network - -- ^ network constants - } - -- ^ coinbase input details - | DetailedInput { detInOutPoint :: !OutPoint - -- ^ output being spent - , detInSequence :: !Word32 - -- ^ sequence - , detInSigScript :: !ByteString - -- ^ signature (input) script - , detInPkScript :: !ByteString - -- ^ pubkey (output) script from previous tx - , detInValue :: !Word64 - -- ^ amount in satoshi being spent spent - , detInBlock :: !(Maybe BlockRef) - -- ^ block where this input is found - , detInNetwork :: !Network - -- ^ network constants - } - -- ^ regular input details - deriving (Show, Eq) - -data PeerInformation - = PeerInformation { userAgent :: !ByteString - , address :: !ByteString - , connected :: !Bool - , version :: !Word32 - , services :: !Word64 - , relay :: !Bool - , block :: !BlockHash - , height :: !BlockHeight - , nonceLocal :: !Word64 - , nonceRemote :: !Word64 - } - deriving (Show, Eq) - -isCoinbase :: DetailedInput -> Bool -isCoinbase DetailedCoinbase {} = True -isCoinbase _ = False - --- | Output information. -data DetailedOutput = DetailedOutput - { detOutValue :: !Word64 - -- ^ amount in satoshi - , detOutScript :: !ByteString - -- ^ pubkey (output) script - , detOutSpender :: !(Maybe Spender) - -- ^ input spending this transaction - , detOutNetwork :: !Network - -- ^ network constants - } deriving (Show, Eq) - --- | Address balance information. -data AddressBalance = AddressBalance - { addressBalAddress :: !Address - -- ^ address balance - , addressBalConfirmed :: !Word64 - -- ^ confirmed balance - , addressBalUnconfirmed :: !Int64 - -- ^ unconfirmed balance (can be negative) - , addressUtxoCount :: !Word64 - -- ^ number of unspent outputs - } deriving (Show, Eq) - --- | Transaction record in database. -data TxRecord = TxRecord - { txValueBlock :: !(Maybe BlockRef) - -- ^ block information - , txValue :: !Tx - -- ^ transaction data - , txValuePrevOuts :: [(OutPoint, PrevOut)] - -- ^ previous output information - } deriving (Show, Eq, Ord) - --- | Output key in database. -newtype OutputKey = OutputKey - { outPoint :: OutPoint - } deriving (Show, Eq, Ord) - --- | Previous output data. -data PrevOut = PrevOut - { prevOutValue :: !Word64 - -- ^ value of output in satoshi - , prevOutBlock :: !(Maybe BlockRef) - -- ^ block information for spent output - , prevOutScript :: !ByteString - -- ^ pubkey (output) script - } deriving (Show, Eq, Ord) - --- | Output data. -data Output = Output - { outputValue :: !Word64 - -- ^ value of output in satoshi - , outBlock :: !(Maybe BlockRef) - -- ^ block infromation for output - , outScript :: !ByteString - -- ^ pubkey (output) script - , outSpender :: !(Maybe Spender) - -- ^ input spending this output - } deriving (Show, Eq, Ord) - --- | Prepare previous output. -outputToPrevOut :: Output -> PrevOut -outputToPrevOut Output {..} = - PrevOut - { prevOutValue = outputValue - , prevOutBlock = outBlock - , prevOutScript = outScript - } - --- | Convert previous output to unspent output. -prevOutToOutput :: PrevOut -> Output -prevOutToOutput PrevOut {..} = - Output - { outputValue = prevOutValue - , outBlock = prevOutBlock - , outScript = prevOutScript - , outSpender = Nothing - } - --- | Information about input spending output. -data Spender = Spender - { spenderHash :: !TxHash - -- ^ input transaction hash - , spenderIndex :: !Word32 - -- ^ input position in transaction - , spenderBlock :: !(Maybe BlockRef) - -- ^ block information - } deriving (Show, Eq, Ord) - --- | Aggregate key for transactions and outputs. -data MultiTxKey - = MultiTxKey !TxKey - -- ^ key for transaction - | MultiTxOutKey !OutputKey - -- ^ key for output - | ShortMultiTxKey !TxHash - -- ^ short key that matches all - deriving (Show, Eq, Ord) - --- | Aggregate database key for transactions and outputs. -data MultiTxValue - = MultiTx !TxRecord - -- ^ transaction record - | MultiTxOutput !Output - -- ^ records for all outputs - deriving (Show, Eq, Ord) - --- | Transaction database key. -newtype TxKey = - TxKey TxHash - deriving (Show, Eq, Ord) - --- | Mempool transaction database key. -data MempoolKey - = MempoolKey TxHash - -- ^ key for a mempool transaction - | ShortMempoolKey - -- ^ short key that matches all - deriving (Show, Eq, Ord) - --- | Orphan transaction database key. -data OrphanKey - = OrphanKey TxHash - -- ^ key for an orphan transaction - | ShortOrphanKey - -- ^ short key that matches all - deriving (Show, Eq, Ord) - --- | Block entry database key. -newtype BlockKey = - BlockKey BlockHash - deriving (Show, Eq, Ord) - --- | Block height database key. -newtype HeightKey = - HeightKey BlockHeight - deriving (Show, Eq, Ord) - --- | Address balance database key. -newtype BalanceKey = BalanceKey - { balanceAddress :: Address - } deriving (Show, Eq) - --- | Address balance database value. -data Balance = Balance - { balanceValue :: !Word64 - -- ^ balance in satoshi - , balanceUnconfirmed :: !Int64 - -- ^ unconfirmed balance in satoshi (can be negative) - , balanceUtxoCount :: !Word64 - -- ^ number of unspent outputs - } deriving (Show, Eq, Ord) - --- | Default balance for an address. -emptyBalance :: Balance -emptyBalance = - Balance - { balanceValue = 0 - , balanceUnconfirmed = 0 - , balanceUtxoCount = 0 - } - --- | Key for best block in database. -data BestBlockKey = BestBlockKey deriving (Show, Eq, Ord) - --- | Address output. -data AddrOutput = AddrOutput - { addrOutputKey :: !AddrOutKey - , addrOutput :: !Output - } deriving (Eq, Show) - -instance Ord AddrOutput where - compare = compare `on` addrOutputKey - --- | Serialization format for addresses in database. -newtype StoreAddress = StoreAddress Address - deriving (Show, Eq) - -instance Key BestBlockKey - -- 0x00 -instance Key BlockKey - -- 0x01 · BlockHash -instance Key TxKey - -- 0x02 · TxHash · 0x00 -instance Key OutputKey - -- 0x02 · TxHash · 0x01 · OutputIndex -instance Key MultiTxKey - -- 0x02 · TxHash - -- 0x02 · TxHash · 0x00 - -- 0x02 · TxHash · 0x01 · OutputIndex -instance Key HeightKey - -- 0x03 · InvBlockHeight -instance Key BalanceKey - -- 0x04 · Storeaddress -instance Key AddrTxKey - -- 0x05 · StoreAddress · InvBlockHeight · InvBlockPos · TxHash - -- 0x05 · StoreAddress · InvBlockHeight - -- 0x05 · StoreAddress -instance Key AddrOutKey - -- 0x06 · StoreAddress · InvBlockHeight · InvBlockPos - -- 0x06 · StoreAddress · InvBlockHeight - -- 0x06 · StoreAddress -instance Key MempoolKey - -- 0x07 · TxHash - -- 0x07 -instance Key OrphanKey - -- 0x08 · TxHash - -- 0x08 - -instance R.KeyValue BestBlockKey BlockHash -instance R.KeyValue BlockKey BlockValue -instance R.KeyValue TxKey TxRecord -instance R.KeyValue AddrOutKey Output -instance R.KeyValue MultiTxKey MultiTxValue -instance R.KeyValue HeightKey BlockHash -instance R.KeyValue BalanceKey Balance -instance R.KeyValue AddrTxKey () -instance R.KeyValue OutputKey Output -instance R.KeyValue MempoolKey () -instance R.KeyValue OrphanKey Tx - -instance Serialize MempoolKey where - put (MempoolKey h) = do - putWord8 0x07 - put h - put ShortMempoolKey = putWord8 0x07 - get = do - guard . (== 0x07) =<< getWord8 - MempoolKey <$> get - -instance Serialize OrphanKey where - put (OrphanKey h) = do - putWord8 0x08 - put h - put ShortOrphanKey = putWord8 0x08 - get = do - guard . (== 0x08) =<< getWord8 - OrphanKey <$> get - -instance Serialize BalanceKey where - put BalanceKey {..} = do - putWord8 0x04 - put (StoreAddress balanceAddress) - get = do - guard . (== 0x04) =<< getWord8 - StoreAddress balanceAddress <- get - return BalanceKey {..} - -instance Serialize Balance where - put Balance {..} = do - put balanceValue - put balanceUnconfirmed - put balanceUtxoCount - get = do - balanceValue <- get - balanceUnconfirmed <- get - balanceUtxoCount <- get - return Balance {..} - -instance Serialize AddrTxKey where - put AddrTxKey {..} = do - putWord8 0x05 - put $ StoreAddress addrTxKey - put (maybe 0 (maxBound -) addrTxHeight) - put (maybe 0 (maxBound -) addrTxPos) - put addrTxHash - put ShortAddrTxKey {..} = do - putWord8 0x05 - put $ StoreAddress addrTxKey - put ShortAddrTxKeyHeight {..} = do - putWord8 0x05 - put $ StoreAddress addrTxKey - put (maybe 0 (maxBound -) addrTxHeight) - get = do - guard . (== 0x05) =<< getWord8 - StoreAddress addrTxKey <- get - h <- (maxBound -) <$> get - let addrTxHeight - | h == 0 = Nothing - | otherwise = Just h - p <- (maxBound -) <$> get - let addrTxPos - | p == 0 = Nothing - | otherwise = Just p - addrTxHash <- get - return AddrTxKey {..} - --- | Beginning of address output database key. -addrKeyStart :: Address -> Put -addrKeyStart a = put (StoreAddress a) - -instance Serialize AddrOutKey where - put AddrOutKey {..} = do - putWord8 0x06 - put $ StoreAddress addrOutputAddress - put (maybe 0 (maxBound -) addrOutputHeight) - put (maybe 0 (maxBound -) addrOutputPos) - put addrOutPoint - put ShortAddrOutKey {..} = do - putWord8 0x06 - put $ StoreAddress addrOutputAddress - put ShortAddrOutKeyHeight {..} = do - putWord8 0x06 - put $ StoreAddress addrOutputAddress - put (maybe 0 (maxBound -) addrOutputHeight) - get = do - guard . (== 0x06) =<< getWord8 - StoreAddress addrOutputAddress <- get - record addrOutputAddress - where - record addrOutputAddress = do - h <- (maxBound -) <$> get - let addrOutputHeight | h == 0 = Nothing - | otherwise = Just h - p <- (maxBound -) <$> get - let addrOutputPos | p == 0 = Nothing - | otherwise = Just p - addrOutPoint <- get - return AddrOutKey {..} - -instance Serialize MultiTxKey where - put (MultiTxKey k) = put k - put (MultiTxOutKey k) = put k - put (ShortMultiTxKey k) = putWord8 0x02 >> put k - get = MultiTxKey <$> get <|> MultiTxOutKey <$> get - -instance Serialize MultiTxValue where - put (MultiTx v) = put v - put (MultiTxOutput v) = put v - get = MultiTx <$> get <|> MultiTxOutput <$> get - -instance Serialize Spender where - put Spender {..} = do - put spenderHash - put spenderIndex - put spenderBlock - get = do - spenderHash <- get - spenderIndex <- get - spenderBlock <- get - return Spender {..} - -instance Serialize OutputKey where - put OutputKey {..} = do - putWord8 0x02 - put (outPointHash outPoint) - putWord8 0x01 - put (outPointIndex outPoint) - get = do - guard . (== 0x02) =<< getWord8 - outPointHash <- get - guard . (== 0x01) =<< getWord8 - outPointIndex <- get - let outPoint = OutPoint {..} - return OutputKey {..} - -instance Serialize PrevOut where - put PrevOut {..} = do - put prevOutValue - put prevOutBlock - put (B.length prevOutScript) - putByteString prevOutScript - get = do - prevOutValue <- get - prevOutBlock <- get - prevOutScript <- getByteString =<< get - return PrevOut {..} - -instance Serialize Output where - put Output {..} = do - putWord8 0x01 - put outputValue - put outBlock - put outScript - put outSpender - get = do - guard . (== 0x01) =<< getWord8 - outputValue <- get - outBlock <- get - outScript <- get - outSpender <- get - return Output {..} - -instance Serialize BlockRef where - put BlockRef {..} = do - put blockRefHash - put blockRefHeight - put blockRefPos - get = do - blockRefHash <- get - blockRefHeight <- get - blockRefPos <- get - return BlockRef {..} - -instance Serialize TxRecord where - put TxRecord {..} = do - putWord8 0x00 - put txValueBlock - put txValue - put txValuePrevOuts - get = do - guard . (== 0x00) =<< getWord8 - txValueBlock <- get - txValue <- get - txValuePrevOuts <- get - return TxRecord {..} - -instance Serialize BestBlockKey where - put BestBlockKey = put (B.replicate 32 0x00) - get = do - guard . (== B.replicate 32 0x00) =<< getBytes 32 - return BestBlockKey - -instance Serialize BlockValue where - put BlockValue {..} = do - put blockValueHeight - put blockValueWork - put blockValueHeader - put blockValueSize - put blockValueTxs - get = do - blockValueHeight <- get - blockValueWork <- get - blockValueHeader <- get - blockValueSize <- get - blockValueTxs <- get - return BlockValue {..} - --- | Byte identifying network for an address. -netByte :: Network -> Word8 -netByte net | net == btc = 0x00 - | net == btcTest = 0x01 - | net == btcRegTest = 0x02 - | net == bch = 0x04 - | net == bchTest = 0x05 - | net == bchRegTest = 0x06 - | otherwise = 0xff - --- | Network from its corresponding byte. -byteNet :: Word8 -> Maybe Network -byteNet 0x00 = Just btc -byteNet 0x01 = Just btcTest -byteNet 0x02 = Just btcRegTest -byteNet 0x04 = Just bch -byteNet 0x05 = Just bchTest -byteNet 0x06 = Just bchRegTest -byteNet _ = Nothing - --- | Deserializer for network byte. -getByteNet :: Get Network -getByteNet = - byteNet <$> getWord8 >>= \case - Nothing -> fail "Could not decode network byte" - Just net -> return net - -instance Serialize StoreAddress where - put (StoreAddress addr) = - case addr of - PubKeyAddress h net -> do - putWord8 0x01 - putWord8 (netByte net) - put h - ScriptAddress h net -> do - putWord8 0x02 - putWord8 (netByte net) - put h - WitnessPubKeyAddress h net -> do - putWord8 0x03 - putWord8 (netByte net) - put h - WitnessScriptAddress h net -> do - putWord8 0x04 - putWord8 (netByte net) - put h - get = fmap StoreAddress $ pk <|> sa <|> wa <|> ws - where - pk = do - guard . (== 0x01) =<< getWord8 - net <- getByteNet - h <- get - return (PubKeyAddress h net) - sa = do - guard . (== 0x02) =<< getWord8 - net <- getByteNet - h <- get - return (ScriptAddress h net) - wa = do - guard . (== 0x03) =<< getWord8 - net <- getByteNet - h <- get - return (WitnessPubKeyAddress h net) - ws = do - guard . (== 0x04) =<< getWord8 - net <- getByteNet - h <- get - return (WitnessScriptAddress h net) - --- | JSON serialization for 'BlockValue'. -blockValuePairs :: A.KeyValue kv => BlockValue -> [kv] -blockValuePairs BlockValue {..} = - [ "hash" .= headerHash blockValueHeader - , "height" .= blockValueHeight - , "previous" .= prevBlock blockValueHeader - , "time" .= blockTimestamp blockValueHeader - , "version" .= blockVersion blockValueHeader - , "bits" .= blockBits blockValueHeader - , "nonce" .= bhNonce blockValueHeader - , "size" .= blockValueSize - , "tx" .= blockValueTxs - ] - -instance ToJSON BlockValue where - toJSON = object . blockValuePairs - toEncoding = pairs . mconcat . blockValuePairs - -instance ToJSON Spender where - toJSON = object . spenderPairs - toEncoding = pairs . mconcat . spenderPairs - --- | JSON serialization for 'BlockRef'. -blockRefPairs :: A.KeyValue kv => BlockRef -> [kv] -blockRefPairs BlockRef {..} = - [ "hash" .= blockRefHash - , "height" .= blockRefHeight - , "position" .= blockRefPos - ] - --- | JSON serialization for 'Spender'. -spenderPairs :: A.KeyValue kv => Spender -> [kv] -spenderPairs Spender {..} = - ["txid" .= spenderHash, "input" .= spenderIndex, "block" .= spenderBlock] - --- | JSON serialization for a 'DetailedOutput'. -detailedOutputPairs :: A.KeyValue kv => DetailedOutput -> [kv] -detailedOutputPairs DetailedOutput {..} = - [ "address" .= scriptToAddressBS detOutNetwork detOutScript - , "pkscript" .= String (cs (encodeHex detOutScript)) - , "value" .= detOutValue - , "spent" .= isJust detOutSpender - , "spender" .= detOutSpender - ] - -instance ToJSON DetailedOutput where - toJSON = object . detailedOutputPairs - toEncoding = pairs . mconcat . detailedOutputPairs - --- | JSON serialization for 'PeerInformation'. -peerInformationPairs :: A.KeyValue kv => PeerInformation -> [kv] -peerInformationPairs PeerInformation {..} = - [ "useragent" .= String (cs userAgent) - , "address" .= String (cs address) - , "connected" .= connected - , "version" .= version - , "services" .= services - , "relay" .= relay - , "block" .= block - , "height" .= height - , "noncelocal" .= nonceLocal - , "nonceremote" .= nonceRemote - ] - -instance ToJSON PeerInformation where - toJSON = object . peerInformationPairs - toEncoding = pairs . mconcat . peerInformationPairs - - --- | JSON serialization for 'DetailedInput'. -detailedInputPairs :: A.KeyValue kv => DetailedInput -> [kv] -detailedInputPairs DetailedInput {..} = - [ "txid" .= outPointHash detInOutPoint - , "output" .= outPointIndex detInOutPoint - , "coinbase" .= False - , "sequence" .= detInSequence - , "sigscript" .= String (cs (encodeHex detInSigScript)) - , "pkscript" .= String (cs (encodeHex detInPkScript)) - , "address" .= scriptToAddressBS detInNetwork detInPkScript - , "value" .= detInValue - , "block" .= detInBlock - ] -detailedInputPairs DetailedCoinbase {..} = - [ "txid" .= outPointHash detInOutPoint - , "output" .= outPointIndex detInOutPoint - , "coinbase" .= True - , "sequence" .= detInSequence - , "sigscript" .= String (cs (encodeHex detInSigScript)) - , "pkscript" .= Null - , "address" .= Null - , "value" .= Null - , "block" .= Null - ] - -instance ToJSON DetailedInput where - toJSON = object . detailedInputPairs - toEncoding = pairs . mconcat . detailedInputPairs - --- | JSON serialization for 'DetailedTx'. -detailedTxPairs :: A.KeyValue kv => DetailedTx -> [kv] -detailedTxPairs DetailedTx {..} = - [ "txid" .= txHash detailedTxData - , "size" .= B.length (S.encode detailedTxData) - , "version" .= txVersion detailedTxData - , "locktime" .= txLockTime detailedTxData - , "fee" .= detailedTxFee - , "inputs" .= detailedTxInputs - , "outputs" .= detailedTxOutputs - , "hex" .= String (cs (encodeHex (S.encode detailedTxData))) - , "block" .= detailedTxBlock - ] - -instance ToJSON DetailedTx where - toJSON = object . detailedTxPairs - toEncoding = pairs . mconcat . detailedTxPairs - -instance ToJSON BlockRef where - toJSON = object . blockRefPairs - toEncoding = pairs . mconcat . blockRefPairs - --- | JSON serialization for 'AddrOutput'. -addrOutputPairs :: A.KeyValue kv => AddrOutput -> [kv] -addrOutputPairs AddrOutput {..} = - [ "address" .= addrOutputAddress - , "txid" .= outPointHash addrOutPoint - , "index" .= outPointIndex addrOutPoint - , "block" .= outBlock - , "output" .= dout - ] - where - Output {..} = addrOutput - AddrOutKey {..} = addrOutputKey - dout = - DetailedOutput - { detOutValue = outputValue - , detOutScript = outScript - , detOutSpender = outSpender - , detOutNetwork = getAddrNet addrOutputAddress - } - -instance ToJSON AddrOutput where - toJSON = object . addrOutputPairs - toEncoding = pairs . mconcat . addrOutputPairs - --- | JSON serialization for 'AddressBalance'. -addressBalancePairs :: A.KeyValue kv => AddressBalance -> [kv] -addressBalancePairs AddressBalance {..} = - [ "address" .= addressBalAddress - , "confirmed" .= addressBalConfirmed - , "unconfirmed" .= addressBalUnconfirmed - , "utxo" .= addressUtxoCount - ] - -instance FromJSON NewTx where - parseJSON = withObject "transaction" $ \v -> NewTx <$> v .: "transaction" - -instance ToJSON AddressBalance where - toJSON = object . addressBalancePairs - toEncoding = pairs . mconcat . addressBalancePairs - -instance Serialize HeightKey where - put (HeightKey height) = do - putWord8 0x03 - put (maxBound - height) - put height - get = do - guard . (== 0x03) =<< getWord8 - iheight <- get - return (HeightKey (maxBound - iheight)) - -instance Serialize BlockKey where - put (BlockKey hash) = do - putWord8 0x01 - put hash - get = do - guard . (== 0x01) =<< getWord8 - BlockKey <$> get - -instance Serialize TxKey where - put (TxKey hash) = do - putWord8 0x02 - put hash - putWord8 0x00 - get = do - guard . (== 0x02) =<< getWord8 - hash <- get - guard . (== 0x00) =<< getWord8 - return (TxKey hash) - --- | Configuration for a 'Store'. -data StoreConfig = StoreConfig - { storeConfMaxPeers :: !Int - -- ^ max peers to connect to - , storeConfInitPeers :: ![HostPort] - -- ^ static set of peers to connect to - , storeConfDiscover :: !Bool - -- ^ discover new peers? - , storeConfDB :: !DB - -- ^ RocksDB database handler - , storeConfNetwork :: !Network - -- ^ network constants - } - --- | Store mailboxes. -data Store = Store - { storeManager :: !Manager - -- ^ peer manager mailbox - , storeChain :: !Chain - -- ^ chain header process mailbox - , storeBlock :: !BlockStore - -- ^ block storage mailbox - , storePublisher :: !(Publisher StoreEvent) - -- ^ store event publisher mailbox - } diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -28,8 +28,8 @@ it "gets 8 blocks" $ withTestStore net "eight-blocks" $ \TestStore {..} -> do bs <- - replicateM 9 . receiveMatch testStoreEvents $ \case - BestBlock b -> Just b + replicateM 8 . receiveMatch testStoreEvents $ \case + StoreBestBlock b -> Just b _ -> Nothing let bestHash = last bs bestNodeM <- chainGetBlock bestHash testStoreChain @@ -41,32 +41,33 @@ withTestStore net "get-block-txs" $ \TestStore {..} -> do let get_the_block h = receive testStoreEvents >>= \case - BestBlock b | h == 0 -> return b - | otherwise -> get_the_block ((h :: Int) - 1) + StoreBestBlock b + | h == 0 -> return b + | otherwise -> get_the_block ((h :: Int) - 1) _ -> get_the_block h - bh <- get_the_block 381 - m <- withSnapshot testStoreDB $ getBlock bh testStoreDB - let BlockValue {..} = - fromMaybe (error "Could not get block") m - blockValueHeight `shouldBe` 381 - length blockValueTxs `shouldBe` 2 + bh <- get_the_block 380 + m <- getBlock (testStoreDB, defaultReadOptions) bh + let bd = fromMaybe (error "Could not get block") m + blockDataHeight bd `shouldBe` 381 + length (blockDataTxs bd) `shouldBe` 2 let h1 = "e8588129e146eeb0aa7abdc3590f8c5920cc5ff42daf05c23b29d4ae5b51fc22" h2 = "7e621eeb02874ab039a8566fd36f4591e65eca65313875221842c53de6907d6c" - head blockValueTxs `shouldBe` h1 - last blockValueTxs `shouldBe` h2 - t1 <- withSnapshot testStoreDB $ getTx net h1 testStoreDB + head (blockDataTxs bd) `shouldBe` h1 + last (blockDataTxs bd) `shouldBe` h2 + t1 <- getTransaction (testStoreDB, defaultReadOptions) h1 t1 `shouldSatisfy` isJust - txHash (detailedTxData (fromJust t1)) `shouldBe` h1 - t2 <- withSnapshot testStoreDB $ getTx net h2 testStoreDB + txHash (transactionData (fromJust t1)) `shouldBe` h1 + t2 <- getTransaction (testStoreDB, defaultReadOptions) h2 t2 `shouldSatisfy` isJust - txHash (detailedTxData (fromJust t2)) `shouldBe` h2 + txHash (transactionData (fromJust t2)) `shouldBe` h2 withTestStore :: MonadUnliftIO m => Network -> String -> (TestStore -> m a) -> m a withTestStore net t f = - withSystemTempDirectory ("haskoin-store-test-" <> t <> "-") $ \w -> + withSystemTempDirectory ("haskoin-store-test-" <> t <> "-") $ \w -> do + x <- newInbox runNoLoggingT $ do db <- open @@ -82,14 +83,14 @@ , storeConfDiscover = True , storeConfDB = db , storeConfNetwork = net + , storeConfListen = (`sendSTM` x) } withStore cfg $ \Store {..} -> - withPubSub storePublisher newTQueueIO $ \sub -> - lift $ - f - TestStore - { testStoreDB = db - , testStoreBlockStore = storeBlock - , testStoreChain = storeChain - , testStoreEvents = sub - } + lift $ + f + TestStore + { testStoreDB = db + , testStoreBlockStore = storeBlock + , testStoreChain = storeChain + , testStoreEvents = x + }