haskoin-store 0.2.3 → 0.3.0
raw patch · 14 files changed
+2747/−2708 lines, 14 filesdep +binarydep +data-defaultdep +hashabledep ~base
Dependencies added: binary, data-default, hashable, unordered-containers
Dependency ranges changed: base
Files
- CHANGELOG.md +26/−0
- app/Main.hs +271/−271
- haskoin-store.cabal +23/−6
- src/Haskoin/Store.hs +132/−231
- src/Network/Haskoin/Store/Block.hs +366/−1192
- src/Network/Haskoin/Store/Data.hs +411/−0
- src/Network/Haskoin/Store/Data/HashMap.hs +256/−0
- src/Network/Haskoin/Store/Data/ImportDB.hs +183/−0
- src/Network/Haskoin/Store/Data/KeyValue.hs +250/−0
- src/Network/Haskoin/Store/Data/RocksDB.hs +129/−0
- src/Network/Haskoin/Store/Logic.hs +575/−0
- src/Network/Haskoin/Store/Messages.hs +98/−0
- src/Network/Haskoin/Store/Types.hs +0/−982
- test/Spec.hs +27/−26
CHANGELOG.md view
@@ -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.
app/Main.hs view
@@ -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)
haskoin-store.cabal view
@@ -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
src/Haskoin/Store.hs view
@@ -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+ }
src/Network/Haskoin/Store/Block.hs view
@@ -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
+ src/Network/Haskoin/Store/Data.hs view
@@ -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
+ src/Network/Haskoin/Store/Data/HashMap.hs view
@@ -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
+ src/Network/Haskoin/Store/Data/ImportDB.hs view
@@ -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
+ src/Network/Haskoin/Store/Data/KeyValue.hs view
@@ -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
+ src/Network/Haskoin/Store/Data/RocksDB.hs view
@@ -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
+ src/Network/Haskoin/Store/Logic.hs view
@@ -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+ }
+ src/Network/Haskoin/Store/Messages.hs view
@@ -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'+
− src/Network/Haskoin/Store/Types.hs
@@ -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- }
test/Spec.hs view
@@ -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+ }